From f769a6fb8ba09e3ef7229880808de308712242d8 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Mon, 18 Nov 2024 13:02:52 -0500 Subject: [PATCH] Fix location for span infos --- pact-lsp/Pact/Core/LanguageServer.hs | 121 +++++++++------ pact-lsp/Pact/Core/LanguageServer/Renaming.hs | 24 +-- pact-lsp/Pact/Core/LanguageServer/Utils.hs | 21 +-- .../Pact/Core/IR/Eval/Direct/ReplBuiltin.hs | 81 +++++----- pact-repl/Pact/Core/Repl.hs | 48 ++++-- pact-repl/Pact/Core/Repl/Compile.hs | 144 +++++++----------- .../Pact/Core/Repl/Runtime/ReplBuiltin.hs | 81 +++++----- pact-repl/Pact/Core/Repl/UserDocs.hs | 2 +- pact-repl/Pact/Core/Repl/Utils.hs | 21 +-- pact-tests/Pact/Core/Test/DocsTests.hs | 2 +- pact-tests/Pact/Core/Test/GasGolden.hs | 16 +- .../Pact/Core/Test/LegacySerialiseTests.hs | 2 +- pact-tests/Pact/Core/Test/ReplTests.hs | 33 +++- pact-tests/Pact/Core/Test/StaticErrorTests.hs | 28 ++-- pact-tests/gas-goldens/builtinGas.golden | 2 +- pact/Pact/Core/Builtin.hs | 9 +- pact/Pact/Core/Environment/Types.hs | 22 ++- pact/Pact/Core/IR/Desugar.hs | 2 + pact/Pact/Core/Info.hs | 21 +++ pact/Pact/Core/Serialise.hs | 13 ++ pact/Pact/Core/Serialise/CBOR_V1.hs | 16 ++ pact/Pact/Core/SizeOf.hs | 5 + pact/Pact/Core/Syntax/ParseTree.hs | 2 +- 23 files changed, 424 insertions(+), 292 deletions(-) diff --git a/pact-lsp/Pact/Core/LanguageServer.hs b/pact-lsp/Pact/Core/LanguageServer.hs index 771d79e07..f002e664d 100644 --- a/pact-lsp/Pact/Core/LanguageServer.hs +++ b/pact-lsp/Pact/Core/LanguageServer.hs @@ -40,6 +40,8 @@ import qualified Data.Text.IO as T import qualified Data.Text as T import System.Exit +import Control.Monad +import Control.Monad.State.Strict(put) import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Monad.Trans (lift) import Control.Concurrent.MVar @@ -49,6 +51,7 @@ import qualified Pact.Core.Syntax.ParseTree as Lisp import qualified Pact.Core.Syntax.Lexer as Lisp import qualified Pact.Core.Syntax.Parser as Lisp import Pact.Core.IR.Term +import Pact.Core.Persistence import Pact.Core.LanguageServer.Utils import Pact.Core.LanguageServer.Renaming import Pact.Core.Repl.BuiltinDocs @@ -59,12 +62,13 @@ import qualified Pact.Core.IR.ModuleHashing as MHash import qualified Pact.Core.IR.ConstEval as ConstEval import qualified Pact.Core.Repl.Compile as Repl import Pact.Core.Interpreter +import Data.Default data LSState = LSState { _lsReplState :: M.Map NormalizedUri (ReplState ReplCoreBuiltin) -- ^ Post-Compilation State for each opened file - , _lsTopLevel :: M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin SpanInfo] + , _lsTopLevel :: M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin FileLocSpanInfo] -- ^ Top-level terms for each opened file. Used to find the match of a -- particular (cursor) position inside the file. } @@ -201,9 +205,9 @@ sendDiagnostics nuri mv content = liftIO (setupAndProcessFile nuri content) >>= -- We emit an empty set of diagnostics publishDiagnostics 0 nuri mv $ partitionBySource [] where - pactErrorToDiagnostic :: PactError SpanInfo -> Diagnostic + pactErrorToDiagnostic :: PactError FileLocSpanInfo -> Diagnostic pactErrorToDiagnostic err = Diagnostic - { _range = err ^. peInfo .to spanInfoToRange + { _range = err ^. peInfo . spanInfo . to spanInfoToRange , _severity = Just DiagnosticSeverity_Error , _code = Nothing -- We do not have any error code right now , _codeDescription = Nothing @@ -226,12 +230,11 @@ sendDiagnostics nuri mv content = liftIO (setupAndProcessFile nuri content) >>= setupAndProcessFile :: NormalizedUri -> Text - -> IO (Either (PactError SpanInfo) + -> IO (Either (PactError FileLocSpanInfo) (ReplState ReplCoreBuiltin - ,M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin SpanInfo])) + ,M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin FileLocSpanInfo])) setupAndProcessFile nuri content = do - pdb <- mockPactDb serialisePact_repl_spaninfo - gasLog <- newIORef Nothing + pdb <- mockPactDb serialisePact_repl_flspaninfo let builtinMap = if isReplScript fp then replBuiltinMap @@ -242,7 +245,6 @@ setupAndProcessFile nuri content = do src = SourceCode (takeFileName fp) content rstate = ReplState { _replFlags = mempty - , _replEvalLog = gasLog , _replCurrSource = src , _replEvalEnv = ee , _replTx = Nothing @@ -252,10 +254,13 @@ setupAndProcessFile nuri content = do -- since there may be no way for us to set it for the LSP from pact directly. -- Once this is possible, we can set it to `False` as is the default , _replNativesEnabled = True + , _replLoad = doLoad + , _replLogType = ReplStdOut + , _replLoadedFiles = mempty , _replOutputLine = const (pure ()) } stateRef <- newIORef rstate - res <- runReplT stateRef (processFile Repl.interpretEvalBigStep nuri content) + res <- runReplT stateRef (processFile Repl.interpretEvalBigStep nuri src) st <- readIORef stateRef pure $ (st,) <$> res where @@ -270,9 +275,10 @@ spanInfoToRange (SpanInfo sl sc el ec) = mkRange getMatch - :: Position - -> [EvalTopLevel ReplCoreBuiltin SpanInfo] - -> Maybe (PositionMatch ReplCoreBuiltin SpanInfo) + :: HasSpanInfo i + => Position + -> [EvalTopLevel ReplCoreBuiltin i] + -> Maybe (PositionMatch ReplCoreBuiltin i) getMatch pos tl = getAlt (foldMap (Alt . topLevelTermAt pos) tl) documentDefinitionRequestHandler :: Handlers LSM @@ -292,7 +298,7 @@ documentDefinitionRequestHandler = requestHandler SMethod_TextDocumentDefinition pure Nothing _ -> pure Nothing debug $ "documentDefinition request: " <> renderText nuri - let loc = Location uri' . spanInfoToRange + let loc = Location uri' . spanInfoToRange . view spanInfo case loc <$> tlDefSpan of Just x -> resp (Right $ InL $ Definition (InL x)) Nothing -> resp (Right $ InR $ InR Null) @@ -311,7 +317,7 @@ documentHoverRequestHandler = requestHandler SMethod_TextDocumentHover $ \req re (M.lookup (replCoreBuiltinToUserText builtin) builtinDocs) mc = MarkupContent MarkupKind_Markdown (_markdownDoc docs) - range = spanInfoToRange i + range = spanInfoToRange (view spanInfo i) hover = Hover (InL mc) (Just range) in resp (Right (InL hover)) @@ -350,40 +356,67 @@ documentRenameRequestHandler = requestHandler SMethod_TextDocumentRename $ \req we = WorkspaceEdit Nothing (Just [InL te]) Nothing resp (Right (InL we)) +doLoad :: FilePath -> Bool -> EvalM ReplRuntime ReplCoreBuiltin FileLocSpanInfo () +doLoad fp reset = do + oldSrc <- useReplState replCurrSource + fp' <- mangleFilePath fp + res <- liftIO $ E.try (T.readFile fp') + pactdb <- liftIO (mockPactDb serialisePact_repl_flspaninfo) + oldEE <- useReplState replEvalEnv + when reset $ do + ee <- liftIO (defaultEvalEnv pactdb replBuiltinMap) + put def + replEvalEnv .== ee + when (Repl.isPactFile fp) $ esLoaded . loToplevel .= mempty + _ <- case res of + Left (_e:: E.IOException) -> + throwExecutionError def $ EvalError $ "File not found: " <> T.pack fp + Right txt -> do + let source = SourceCode fp txt + replCurrSource .== source + let nfp = normalizedFilePathToUri (toNormalizedFilePath fp') + processFile Repl.interpretEvalBigStep nfp source + replCurrSource .== oldSrc + unless reset $ do + replEvalEnv .== oldEE + pure () + + +mangleFilePath :: FilePath -> EvalM ReplRuntime b FileLocSpanInfo FilePath +mangleFilePath fp = do + (SourceCode currFile _) <- useReplState replCurrSource + case currFile of + "" -> pure fp + _ | isAbsolute fp -> pure fp + | takeFileName currFile == currFile -> pure fp + | otherwise -> pure $ combine (takeDirectory currFile) fp + processFile - :: Interpreter ReplRuntime ReplCoreBuiltin SpanInfo + :: Interpreter ReplRuntime ReplCoreBuiltin FileLocSpanInfo -> NormalizedUri - -> Text - -> ReplM ReplCoreBuiltin (M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin SpanInfo]) -processFile replEnv nuri source = do - lexx <- liftEither (Lisp.lexer source) - parsed <- liftEither $ Lisp.parseReplProgram lexx + -> SourceCode + -> ReplM ReplCoreBuiltin (M.Map NormalizedUri [EvalTopLevel ReplCoreBuiltin FileLocSpanInfo]) +processFile replEnv nuri (SourceCode f source) = do + lexx <- liftEither $ over _Left (fmap toFileLoc) (Lisp.lexer source) + parsed <- liftEither $ bimap (fmap toFileLoc) ((fmap.fmap) toFileLoc) $ Lisp.parseReplProgram lexx M.unionsWith (<>) <$> traverse pipe parsed where - currFile = maybe "" fromNormalizedFilePath (uriToNormalizedFilePath nuri) - mangleFilePath fp = case currFile of - "" -> pure fp - _ | isAbsolute fp -> pure fp - | takeFileName currFile == currFile -> pure fp - | otherwise -> pure $ combine (takeDirectory currFile) fp - pipe rtl = case Repl.topLevelIsReplLoad rtl of - Right (Repl.ReplLoadFile fp _ i) -> do - fp' <- mangleFilePath (T.unpack fp) - res <- liftIO $ E.try (T.readFile fp') - case res of - Left (_e:: E.IOException) -> - throwExecutionError i $ EvalError $ "File not found: " <> fp - Right txt -> do - let nfp = normalizedFilePathToUri (toNormalizedFilePath fp') - processFile replEnv nfp txt - Left (Lisp.RTLTopLevel tl) -> do - functionDocs tl - (ds, deps) <- compileDesugarOnly replEnv tl - constEvaled <- ConstEval.evalTLConsts replEnv ds - tlFinal <- MHash.hashTopLevel constEvaled - let act = M.singleton nuri [ds] <$ evalTopLevel replEnv (RawCode mempty) tlFinal deps - catchError act (const (pure mempty)) - _ -> pure mempty + toFileLoc = FileLocSpanInfo f + -- currFile = maybe "" fromNormalizedFilePath (uriToNormalizedFilePath nuri) + -- mangleFilePath fp = case currFile of + -- "" -> pure fp + -- _ | isAbsolute fp -> pure fp + -- | takeFileName currFile == currFile -> pure fp + -- | otherwise -> pure $ combine (takeDirectory currFile) fp + pipe (Lisp.RTLTopLevel tl) = do + functionDocs tl + (ds, deps) <- compileDesugarOnly replEnv tl + constEvaled <- ConstEval.evalTLConsts replEnv ds + tlFinal <- MHash.hashTopLevel constEvaled + let act = M.singleton nuri [ds] <$ evalTopLevel replEnv (RawCode mempty) tlFinal deps + catchError act (const (pure mempty)) + pipe _ = pure mempty + sshow :: Show a => a -> Text sshow = T.pack . show diff --git a/pact-lsp/Pact/Core/LanguageServer/Renaming.hs b/pact-lsp/Pact/Core/LanguageServer/Renaming.hs index 80c68da8a..5dc9baa62 100644 --- a/pact-lsp/Pact/Core/LanguageServer/Renaming.hs +++ b/pact-lsp/Pact/Core/LanguageServer/Renaming.hs @@ -17,10 +17,10 @@ import Data.Maybe matchingDefs - :: [EvalTopLevel ReplCoreBuiltin SpanInfo] + :: [EvalTopLevel ReplCoreBuiltin i] -> ModuleName -> Text - -> (Maybe (EvalIfDef ReplCoreBuiltin SpanInfo), Maybe (EvalDef ReplCoreBuiltin SpanInfo)) + -> (Maybe (EvalIfDef ReplCoreBuiltin i), Maybe (EvalDef ReplCoreBuiltin i)) matchingDefs tls mn n = (interfaceDef, moduleDef) where interfaceDef = do @@ -41,23 +41,25 @@ matchingDefs tls mn n = (interfaceDef, moduleDef) matchingTerms - :: (EvalTerm ReplCoreBuiltin SpanInfo -> Bool) - -> EvalTopLevel ReplCoreBuiltin SpanInfo - -> [EvalTerm ReplCoreBuiltin SpanInfo] + :: forall i. () + => (EvalTerm ReplCoreBuiltin i -> Bool) + -> EvalTopLevel ReplCoreBuiltin i + -> [EvalTerm ReplCoreBuiltin i] matchingTerms predicate topLevel = let terms = toListOf topLevelTerms topLevel in concatMap (toListOf filteredTerms) terms where filteredTerms :: Traversal' - (EvalTerm ReplCoreBuiltin SpanInfo) (EvalTerm ReplCoreBuiltin SpanInfo) + (EvalTerm ReplCoreBuiltin i) (EvalTerm ReplCoreBuiltin i) filteredTerms = traverseTerm . filtered predicate getRenameSpanInfo - :: [EvalTopLevel ReplCoreBuiltin SpanInfo] - -> PositionMatch ReplCoreBuiltin SpanInfo + :: HasSpanInfo i + => [EvalTopLevel ReplCoreBuiltin i] + -> PositionMatch ReplCoreBuiltin i -> [SpanInfo] getRenameSpanInfo tls = \case TermMatch (Var (Name n vt) _) -> case vt of @@ -68,13 +70,13 @@ getRenameSpanInfo tls = \case _ -> False termOccurences = toListOf (each . termInfo) $ concatMap (matchingTerms isSameVar) tls (mInterfPos, mDefPos) = bimap (fmap ifDefNameInfo) (fmap defNameInfo) (matchingDefs tls mn n) - concat [maybeToList mInterfPos, maybeToList mDefPos, termOccurences] + fmap (view spanInfo) $ concat [maybeToList mInterfPos, maybeToList mDefPos, termOccurences] _ -> mempty DefunMatch (Defun spec _args _body _) -> do let dName = _argName spec isSameVar = \case Var (Name n _) _ -> n == dName _ -> False - termOccurences = toListOf (each . termInfo) $ concatMap (matchingTerms isSameVar) tls - _argInfo spec : termOccurences + termOccurences = toListOf (each . termInfo . spanInfo) $ concatMap (matchingTerms isSameVar) tls + view spanInfo (_argInfo spec) : termOccurences _ -> mempty diff --git a/pact-lsp/Pact/Core/LanguageServer/Utils.hs b/pact-lsp/Pact/Core/LanguageServer/Utils.hs index fcfa92c6b..2b2cb2f4b 100644 --- a/pact-lsp/Pact/Core/LanguageServer/Utils.hs +++ b/pact-lsp/Pact/Core/LanguageServer/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | module Pact.Core.LanguageServer.Utils where @@ -13,9 +14,10 @@ import Control.Lens hiding (inside) import Pact.Core.Imports termAt - :: Position - -> EvalTerm ReplCoreBuiltin SpanInfo - -> Maybe (EvalTerm ReplCoreBuiltin SpanInfo) + :: HasSpanInfo i + => Position + -> EvalTerm ReplCoreBuiltin i + -> Maybe (EvalTerm ReplCoreBuiltin i) termAt p term | p `inside` view termInfo term = case term of t@(Lam _ b _) -> termAt p b <|> Just t @@ -55,9 +57,10 @@ data PositionMatch b i deriving Show topLevelTermAt - :: Position - -> EvalTopLevel ReplCoreBuiltin SpanInfo - -> Maybe (PositionMatch ReplCoreBuiltin SpanInfo) + :: HasSpanInfo i + => Position + -> EvalTopLevel ReplCoreBuiltin i + -> Maybe (PositionMatch ReplCoreBuiltin i) topLevelTermAt p = \case TLModule m -> goModule m TLInterface i -> goInterface i @@ -77,7 +80,7 @@ topLevelTermAt p = \case -- otherwise, we follow as usual. case termAt p tm of Nothing -> Just (DefunMatch d) - Just tm' -> if i == view termInfo tm' + Just tm' -> if view spanInfo i == view (termInfo.spanInfo) tm' then Just (DefunMatch d) else TermMatch <$> termAt p tm | otherwise -> Nothing @@ -107,8 +110,8 @@ topLevelTermAt p = \case StepWithRollback tm1 tm2 -> TermMatch <$> (termAt p tm1 <|> termAt p tm2) -- | Check if a `Position` is contained within a `Span` -inside :: Position -> SpanInfo -> Bool -inside pos (SpanInfo sl sc el ec) = sPos <= pos && pos < ePos +inside :: HasSpanInfo i => Position -> i -> Bool +inside pos (view spanInfo -> SpanInfo sl sc el ec) = sPos <= pos && pos < ePos where sPos = Position (fromIntegral sl) (fromIntegral sc) ePos = Position (fromIntegral el) (fromIntegral ec) diff --git a/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs b/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs index 260d717cd..4d26d5078 100644 --- a/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs +++ b/pact-repl/Pact/Core/IR/Eval/Direct/ReplBuiltin.hs @@ -60,7 +60,7 @@ prettyShowValue = \case VTable (TableValue (TableName tn mn) _ _) -> "table{" <> renderModuleName mn <> "_" <> tn <> "}" VClosure _ -> "<#closure>" -corePrint :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +corePrint :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo corePrint info b _env = \case [v] -> do liftIO $ putStrLn $ T.unpack (prettyShowValue v) @@ -68,7 +68,7 @@ corePrint info b _env = \case args -> argsError info b args -coreExpect :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +coreExpect :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpect info b _env = \case [VLiteral (LString msg), VClosure expected, VClosure provided] -> do es <- get @@ -85,12 +85,10 @@ coreExpect info b _env = \case throwUserRecoverableError info $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison" Left err -> do put es - currSource <- useReplState replCurrSource - return $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <> - replError currSource err + return $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <> renderCompactText err args -> argsError info b args -coreExpectThat :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +coreExpectThat :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpectThat info b _env = \case [VLiteral (LString msg), VClosure vclo, v] -> do applyLamUnsafe vclo [v] >>= \case @@ -100,7 +98,7 @@ coreExpectThat info b _env = \case _ -> throwNativeExecutionError info b "Expect-that: condition did not return a boolean" args -> argsError info b args -coreExpectFailure :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +coreExpectFailure :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpectFailure info b _env = \case [VString doc, VClosure vclo] -> do es <- get @@ -128,7 +126,7 @@ coreExpectFailure info b _env = \case args -> argsError info b args -continuePact :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +continuePact :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo continuePact info b env = \case [VInteger s] -> go s False Nothing Nothing [VInteger s, VBool r] -> go s r Nothing Nothing @@ -159,7 +157,7 @@ continuePact info b env = \case replEvalEnv . eeDefPactStep .== Nothing liftEither merr -pactState :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +pactState :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo pactState info b _env = \case [] -> go False [VBool clear] -> go clear @@ -180,14 +178,14 @@ pactState info b _env = \case return (VObject (M.fromList ps)) Nothing -> throwUserRecoverableError info $ UserEnforceError "pact-state: no pact exec in context" -coreplEvalEnvStackFrame :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +coreplEvalEnvStackFrame :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreplEvalEnvStackFrame info b _env = \case [] -> do sfs <- fmap (PString . T.pack . show) <$> use esStack return $ VList (V.fromList sfs) args -> argsError info b args -envEvents :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envEvents :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envEvents info b _env = \case [VBool clear] -> do events <- reverse . fmap envToObj <$> use esEvents @@ -203,7 +201,7 @@ envEvents info b _env = \case , ("module-hash", PString (hashToText (_mhHash mh)))] args -> argsError info b args -envHash :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envHash :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envHash info b _env = \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of @@ -213,7 +211,7 @@ envHash info b _env = \case return $ VString $ "Set tx hash to " <> s args -> argsError info b args -envData :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envData :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envData info b _env = \case [VPactValue pv] -> do -- to mimic prod, we must roundtrip here @@ -223,7 +221,7 @@ envData info b _env = \case return (VString "Setting transaction data") args -> argsError info b args -envChainData :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envChainData :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envChainData info b _env = \case [VObject cdataObj] -> do pd <- viewEvalEnv eePublicData @@ -254,7 +252,7 @@ envChainData info b _env = \case throwUserRecoverableError info $ UserEnforceError $ "envChainData: bad public metadata value for key: " <> _field k args -> argsError info b args -envKeys :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envKeys :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envKeys info b _env = \case [VList ks] -> do keys <- traverse (asString info b) ks @@ -262,7 +260,7 @@ envKeys info b _env = \case return (VString "Setting transaction keys") args -> argsError info b args -envSigs :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envSigs :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envSigs info b _env = \case [VList ks] -> case traverse keyCapObj ks of @@ -284,7 +282,7 @@ envSigs info b _env = \case _ -> Nothing args -> argsError info b args -beginTx :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +beginTx :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo beginTx info b _env = \case [VString s] -> begin' info (Just s) >>= renderTx info "Begin Tx" [] -> begin' info Nothing >>= renderTx info "Begin Tx" @@ -296,7 +294,7 @@ renderTx _info start (Just (TxId tid, mt)) = renderTx info start Nothing = throwUserRecoverableError info $ UserEnforceError ("tx-function failure " <> start) -begin' :: SpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) +begin' :: FileLocSpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) begin' info mt = do pdb <- useReplState (replEvalEnv . eePactDb) mode <- viewEvalEnv eeMode @@ -315,7 +313,7 @@ emptyTxState = do $ set esCheckRecursion esc def put newEvalState -envSetDebug :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envSetDebug :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envSetDebug info b _env = \case [VString flag] -> do flags <- case T.strip flag of @@ -340,7 +338,7 @@ envSetDebug info b _env = \case return VUnit args -> argsError info b args -commitTx :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +commitTx :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo commitTx info b _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -354,7 +352,7 @@ commitTx info b _env = \case args -> argsError info b args -rollbackTx :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +rollbackTx :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo rollbackTx info b _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -367,7 +365,7 @@ rollbackTx info b _env = \case Nothing -> renderTx info "Rollback Tx" Nothing args -> argsError info b args -sigKeyset :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +sigKeyset :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo sigKeyset info b _env = \case [] -> do sigs <- S.fromList . M.keys <$> viewEvalEnv eeMsgSigs @@ -375,7 +373,7 @@ sigKeyset info b _env = \case args -> argsError info b args -testCapability :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +testCapability :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo testCapability info b env = \case [VCapToken origToken] -> do d <- getDefCap info (_ctName origToken) @@ -389,7 +387,7 @@ testCapability info b env = \case installCap info env origToken False *> evalCap info env origToken PopCapInvoke TestCapEval cBody args -> argsError info b args -envExecConfig :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envExecConfig :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envExecConfig info b _env = \case [VList s] -> do s' <- traverse go (V.toList s) @@ -405,7 +403,7 @@ envExecConfig info b _env = \case --failInvariant info $ "Invalid flag, allowed: " <> T.pack (show (M.keys flagReps)) args -> argsError info b args -envNamespacePolicy :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envNamespacePolicy :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envNamespacePolicy info b _env = \case [VBool allowRoot, VClosure (C clo)] -> do let qn = fqnToQualName (_cloFqName clo) @@ -420,7 +418,7 @@ envNamespacePolicy info b _env = \case throwUserRecoverableError info $ UserEnforceError "invalid namespace manager function type" args -> argsError info b args -envGas :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envGas :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGas info b _env = \case [] -> do Gas gas <- milliGasToGas <$> getGas @@ -430,7 +428,7 @@ envGas info b _env = \case return $ VString $ "Set gas to " <> T.pack (show g) args -> argsError info b args -envMilliGas :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envMilliGas :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envMilliGas info b _env = \case [] -> do MilliGas gas <- getGas @@ -440,14 +438,14 @@ envMilliGas info b _env = \case return $ VString $ "Set milligas to" <> T.pack (show g) args -> argsError info b args -envGasLimit :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envGasLimit :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasLimit info b _env = \case [VInteger g] -> do (replEvalEnv . eeGasEnv . geGasModel . gmGasLimit) .== Just (MilliGasLimit (gasToMilliGas (Gas (fromInteger g)))) return $ VString $ "Set gas limit to " <> T.pack (show g) args -> argsError info b args -envGasLog :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envGasLog :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasLog info b _env = \case [] -> do (gasLogRef, logsJustEnabled) <- viewEvalEnv (eeGasEnv . geGasLog) >>= \case @@ -467,7 +465,7 @@ envGasLog info b _env = \case return (VList $ V.fromList (totalLine:logLines)) args -> argsError info b args -envEnableReplNatives :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envEnableReplNatives :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envEnableReplNatives info b _env = \case [VBool enabled] -> do let s = if enabled then "enabled" else "disabled" @@ -475,7 +473,7 @@ envEnableReplNatives info b _env = \case return $ VString $ "repl natives " <> s args -> argsError info b args -envGasModel :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envGasModel :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasModel info b _env = \case [] -> do gm <- viewEvalEnv (eeGasEnv . geGasModel) @@ -523,7 +521,7 @@ coreEnforceVersion info b _env = \case Left _msg -> throwExecutionError info (EnforcePactVersionParseFailure s) Right li -> pure (V.makeVersion li) -envModuleAdmin :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envModuleAdmin :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envModuleAdmin info b _env = \case [VModRef modRef] -> do let modName = _mrModule modRef @@ -531,7 +529,7 @@ envModuleAdmin info b _env = \case return $ VString $ "Acquired module admin for: " <> renderModuleName modName args -> argsError info b args -envVerifiers :: NativeFunction ReplRuntime ReplCoreBuiltin SpanInfo +envVerifiers :: NativeFunction ReplRuntime ReplCoreBuiltin FileLocSpanInfo envVerifiers info b _env = \case [VList ks] -> case traverse verifCapObj ks of @@ -553,15 +551,26 @@ envVerifiers info b _env = \case _ -> Nothing args -> argsError info b args +load :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo +load info b _env = \case + [VString s] -> load' s False + [VString s, VBool reset] -> load' s reset + args -> argsError info b args + where + load' sourceFile reset = do + replPrintLn $ PString $ "Loading " <> sourceFile <> "..." + fload <- useReplState replLoad + fload (T.unpack sourceFile) reset + return VUnit replBuiltinEnv - :: BuiltinEnv ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo + :: BuiltinEnv ReplRuntime (ReplBuiltin CoreBuiltin) FileLocSpanInfo replBuiltinEnv i b env = mkDirectBuiltinFn i b env (replCoreBuiltinRuntime b) replCoreBuiltinRuntime :: ReplBuiltin CoreBuiltin - -> NativeFunction ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo + -> NativeFunction ReplRuntime (ReplBuiltin CoreBuiltin) FileLocSpanInfo replCoreBuiltinRuntime = \case RBuiltinWrap cb -> coreBuiltinRuntime cb @@ -608,3 +617,5 @@ replCoreBuiltinRuntime = \case REnvModuleAdmin -> envModuleAdmin REnvVerifiers -> envVerifiers REnvSetDebugFlag -> envSetDebug + RLoad -> load + RLoadWithEnv -> load diff --git a/pact-repl/Pact/Core/Repl.hs b/pact-repl/Pact/Core/Repl.hs index 35eb27b3f..07110d90b 100644 --- a/pact-repl/Pact/Core/Repl.hs +++ b/pact-repl/Pact/Core/Repl.hs @@ -2,6 +2,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} -- | @@ -14,7 +16,7 @@ -- -module Pact.Core.Repl(runRepl, execScript) where +module Pact.Core.Repl(runRepl, execScript, defaultReplState) where import Control.Monad.IO.Class import Control.Exception.Safe @@ -35,28 +37,45 @@ import Pact.Core.Repl.Utils import Pact.Core.Serialise import Pact.Core.Info import Pact.Core.Errors +import Control.Lens +import qualified Data.Map.Strict as M -execScript :: Bool -> FilePath -> IO (Either (PactError SpanInfo) [ReplCompileValue]) +execScript :: Bool -> FilePath -> IO (Either (PactError FileLocSpanInfo) [ReplCompileValue]) execScript dolog f = do - pdb <- mockPactDb serialisePact_repl_spaninfo - evalLog <- newIORef Nothing - ee <- defaultEvalEnv pdb replBuiltinMap - ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False logger) - runReplT ref $ loadFile f interpretEvalDirect + ref <- newIORef =<< defaultReplState logger + runReplT ref $ loadFile interpretEvalDirect f True where - defaultSrc = SourceCode "(interactive)" mempty logger :: Text -> EvalM e b i () logger | dolog = liftIO . T.putStrLn | otherwise = const (pure ()) + +defaultReplState :: (forall b. Text -> EvalM 'ReplRuntime b FileLocSpanInfo ()) -> IO (ReplState ReplCoreBuiltin) +defaultReplState dolog = do + pdb <- mockPactDb serialisePact_repl_flspaninfo + ee <- defaultEvalEnv pdb replBuiltinMap + let rstate = ReplState + { _replLogType = ReplStdOut + , _replUserDocs= mempty + , _replTx = Nothing + , _replTLDefPos = mempty + , _replOutputLine = dolog + , _replNativesEnabled = False + , _replLoadedFiles = mempty + , _replLoad = defaultLoadFile + , _replFlags = mempty + , _replEvalEnv = ee + , _replCurrSource = defaultSrc} + pure rstate + where + defaultSrc = SourceCode "(interactive)" mempty + + runRepl :: IO () runRepl = do - pdb <- mockPactDb serialisePact_repl_spaninfo - evalLog <- newIORef Nothing - ee <- defaultEvalEnv pdb replBuiltinMap let display' rcv = runInputT replSettings (displayOutput rcv) - ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False display') + ref <- newIORef =<< defaultReplState display' runReplT ref (runInputT replSettings loop) >>= \case Left err -> do putStrLn "Exited repl session with error:" @@ -79,7 +98,10 @@ runRepl = do case eout of Right _ -> pure () Left err -> do - rs <- lift (useReplState replCurrSource) + let replInfo = view peInfo err + rs <- lift (usesReplState replLoadedFiles (M.lookup (_flsiFile replInfo))) >>= \case + Just sc -> pure sc + Nothing -> lift (useReplState replCurrSource) lift (replCurrSource .== defaultSrc) outputStrLn (T.unpack (replError rs err)) loop diff --git a/pact-repl/Pact/Core/Repl/Compile.hs b/pact-repl/Pact/Core/Repl/Compile.hs index 232ca9cc5..edd831b29 100644 --- a/pact-repl/Pact/Core/Repl/Compile.hs +++ b/pact-repl/Pact/Core/Repl/Compile.hs @@ -12,15 +12,14 @@ module Pact.Core.Repl.Compile ( ReplCompileValue(..) , interpretReplProgramBigStep - , loadFile , interpretReplProgramDirect , interpretEvalBigStep , interpretEvalDirect , interpretReplProgram , ReplInterpreter , isPactFile - , ReplLoadFile(..) - , topLevelIsReplLoad + , loadFile + , defaultLoadFile ) where import Control.Lens @@ -35,7 +34,6 @@ import System.FilePath.Posix import qualified Data.Map.Strict as M -import qualified Data.Text as T import qualified Data.Text.IO as T import Pact.Core.Persistence @@ -49,12 +47,10 @@ import Pact.Core.Compile import Pact.Core.Type import Pact.Core.Environment import Pact.Core.Info -import Pact.Core.PactValue import Pact.Core.Errors import Pact.Core.Interpreter -import Pact.Core.Literal import Pact.Core.Pretty hiding (pipe) -import Pact.Core.Serialise (serialisePact_repl_spaninfo) +import Pact.Core.Serialise import Pact.Core.IR.Eval.Runtime @@ -70,16 +66,16 @@ import qualified Pact.Core.IR.Eval.CEK.Evaluator as CEK import qualified Pact.Core.IR.Eval.Direct.Evaluator as Direct import qualified Pact.Core.IR.Eval.Direct.ReplBuiltin as Direct -type ReplInterpreter = Interpreter ReplRuntime ReplCoreBuiltin SpanInfo +type ReplInterpreter = Interpreter ReplRuntime ReplCoreBuiltin FileLocSpanInfo -- Small internal debugging function for playing with file loading within -- this module data ReplCompileValue - = RCompileValue (CompileValue SpanInfo) + = RCompileValue (CompileValue FileLocSpanInfo) | RLoadedDefun Text | RLoadedDefConst Text | RBuiltinDoc Text - | RUserDoc (EvalDef ReplCoreBuiltin SpanInfo) (Maybe Text) + | RUserDoc (EvalDef ReplCoreBuiltin FileLocSpanInfo) (Maybe Text) deriving Show instance Pretty ReplCompileValue where @@ -94,17 +90,6 @@ instance Pretty ReplCompileValue where vsep [pretty qn, "Docs:", maybe mempty pretty doc] --- | Internal function for loading a file. --- Exported because it is used in the tests. -loadFile - :: FilePath - -> ReplInterpreter - -> ReplM ReplCoreBuiltin [ReplCompileValue] -loadFile loc rEnv = do - source <- SourceCode loc <$> liftIO (T.readFile loc) - replCurrSource .== source - interpretReplProgram rEnv source - interpretReplProgramBigStep :: SourceCode @@ -117,7 +102,7 @@ interpretReplProgramDirect -> ReplM ReplCoreBuiltin [ReplCompileValue] interpretReplProgramDirect = interpretReplProgram interpretEvalDirect -checkReplNativesEnabled :: TopLevel n t (ReplBuiltin b) SpanInfo -> ReplM ReplCoreBuiltin () +checkReplNativesEnabled :: TopLevel n t (ReplBuiltin b) FileLocSpanInfo -> ReplM ReplCoreBuiltin () checkReplNativesEnabled = \case TLModule m -> do flag <- useReplState replNativesEnabled @@ -166,90 +151,71 @@ interpretEvalDirect = isPactFile :: FilePath -> Bool isPactFile f = takeExtension f == ".pact" -pattern PReplLoadWithClear :: Text -> Bool -> i -> Lisp.ReplTopLevel i -pattern PReplLoadWithClear file reset info <- - Lisp.RTLTopLevel ( - Lisp.TLTerm (Lisp.App (Lisp.Var (BN (BareName "load")) _) - [ Lisp.Constant (LString file) _ - , Lisp.Constant (LBool reset) _] - info) - ) -pattern PReplLoad :: Text -> i -> Lisp.ReplTopLevel i -pattern PReplLoad file info <- - Lisp.RTLTopLevel ( - Lisp.TLTerm (Lisp.App (Lisp.Var (BN (BareName "load")) _) - [ Lisp.Constant (LString file) _] - info) - ) +setBuiltinResolution :: SourceCode -> ReplM (ReplBuiltin CoreBuiltin) () +setBuiltinResolution (SourceCode fp _) + | sourceIsPactFile = + replEvalEnv . eeNatives .== replCoreBuiltinOnlyMap + | otherwise = + replEvalEnv . eeNatives .== replBuiltinMap + where + sourceIsPactFile = isPactFile fp + +defaultLoadFile :: FilePath -> Bool -> EvalM ReplRuntime ReplCoreBuiltin FileLocSpanInfo () +defaultLoadFile f reset = () <$ loadFile interpretEvalDirect f reset -data ReplLoadFile i - = ReplLoadFile - { _rlFile :: Text - , _rlReset :: Bool - , _rlInfo :: i - } deriving (Show) +loadFile :: ReplInterpreter -> FilePath -> Bool -> EvalM ReplRuntime ReplCoreBuiltin FileLocSpanInfo [ReplCompileValue] +loadFile interpreter txt reset = do + oldSrc <- useReplState replCurrSource + pactdb <- liftIO (mockPactDb serialisePact_repl_flspaninfo) + oldEE <- useReplState replEvalEnv + when reset $ do + ee <- liftIO (defaultEvalEnv pactdb replBuiltinMap) + put def + replEvalEnv .== ee + fp <- mangleFilePath txt + when (isPactFile fp) $ esLoaded . loToplevel .= mempty + source <- SourceCode fp <$> liftIO (T.readFile fp) + replCurrSource .== source + out <- interpretReplProgram interpreter source + replCurrSource .== oldSrc + unless reset $ do + replEvalEnv .== oldEE + setBuiltinResolution oldSrc + pure out -topLevelIsReplLoad :: Lisp.ReplTopLevel i -> Either (Lisp.ReplTopLevel i) (ReplLoadFile i) -topLevelIsReplLoad = \case - PReplLoad file i -> Right (ReplLoadFile file False i) - PReplLoadWithClear file reset i -> Right (ReplLoadFile file reset i) - t -> Left t +mangleFilePath :: FilePath -> EvalM ReplRuntime b FileLocSpanInfo FilePath +mangleFilePath fp = do + (SourceCode currFile _) <- useReplState replCurrSource + case currFile of + "(interactive)" -> pure fp + _ | isAbsolute fp -> pure fp + | takeFileName currFile == currFile -> pure fp + | otherwise -> pure $ combine (takeDirectory currFile) fp interpretReplProgram :: ReplInterpreter -> SourceCode -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgram interpreter (SourceCode sourceFp source) = do - lexx <- liftEither (Lisp.lexer source) +interpretReplProgram interpreter sc@(SourceCode sourceFp source) = do + replLoadedFiles %== M.insert sourceFp sc + lexx <- liftEither $ over _Left (fmap toFileLoc) (Lisp.lexer source) debugIfFlagSet ReplDebugLexer lexx - parsed <- parseSource lexx - setBuiltinResolution - concat <$> traverse pipe parsed + parsed <- liftEither $ bimap (fmap toFileLoc) ((fmap.fmap) toFileLoc) (parseSource lexx) + setBuiltinResolution sc + traverse pipe' parsed where + toFileLoc = FileLocSpanInfo sourceFp sourceIsPactFile = isPactFile sourceFp parseSource lexerOutput - | sourceIsPactFile = (fmap.fmap) (Lisp.RTLTopLevel) $ liftEither $ Lisp.parseProgram lexerOutput - | otherwise = liftEither $ Lisp.parseReplProgram lexerOutput - setBuiltinResolution - | sourceIsPactFile = - replEvalEnv . eeNatives .== replCoreBuiltinOnlyMap - | otherwise = - replEvalEnv . eeNatives .== replBuiltinMap - pipe t = case topLevelIsReplLoad t of - Left tl -> pure <$> pipe' tl - Right (ReplLoadFile file reset info) -> doLoadFile file reset info + | sourceIsPactFile = (fmap.fmap) (Lisp.RTLTopLevel) $ Lisp.parseProgram lexerOutput + | otherwise = Lisp.parseReplProgram lexerOutput displayValue p = p <$ replPrintLn p sliceCode = \case Lisp.TLModule{} -> sliceFromSource Lisp.TLInterface{} -> sliceFromSource Lisp.TLTerm{} -> \_ _ -> mempty Lisp.TLUse{} -> \_ _ -> mempty - doLoadFile txt reset i = do - let loading = RCompileValue (InterpretValue (PString ("Loading " <> txt <> "...")) i) - replPrintLn loading - oldSrc <- useReplState replCurrSource - pactdb <- liftIO (mockPactDb serialisePact_repl_spaninfo) - oldEE <- useReplState replEvalEnv - when reset $ do - ee <- liftIO (defaultEvalEnv pactdb replBuiltinMap) - put def - replEvalEnv .== ee - fp <- mangleFilePath (T.unpack txt) - when (isPactFile fp) $ esLoaded . loToplevel .= mempty - out <- loadFile fp interpreter - replCurrSource .== oldSrc - unless reset $ do - replEvalEnv .== oldEE - setBuiltinResolution - pure out - mangleFilePath fp = do - (SourceCode currFile _) <- useReplState replCurrSource - case currFile of - "(interactive)" -> pure fp - _ | isAbsolute fp -> pure fp - | takeFileName currFile == currFile -> pure fp - | otherwise -> pure $ combine (takeDirectory currFile) fp pipe' tl = case tl of Lisp.RTLTopLevel toplevel -> case topLevelHasDocs toplevel of Just doc -> displayValue $ RBuiltinDoc doc @@ -268,7 +234,7 @@ interpretReplProgram interpreter (SourceCode sourceFp source) = do Nothing -> throwExecutionError varI $ EvalError "repl invariant violated: resolved to a top level free variable without a binder" _ -> do - let sliced = sliceCode toplevel source (view Lisp.topLevelInfo toplevel) + let sliced = sliceCode toplevel source (view (Lisp.topLevelInfo.spanInfo) toplevel) v <- evalTopLevel interpreter (RawCode sliced) ds deps emitWarnings replPrintLn v diff --git a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs b/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs index 53578934f..2c88c9f6b 100644 --- a/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs +++ b/pact-repl/Pact/Core/Repl/Runtime/ReplBuiltin.hs @@ -58,14 +58,14 @@ prettyShowValue = \case VTable (TableValue (TableName tn mn) _ _) -> "table{" <> renderModuleName mn <> "_" <> tn <> "}" VClosure _ -> "<#closure>" -corePrint :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +corePrint :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo corePrint info b cont handler _env = \case [v] -> do liftIO $ putStrLn $ T.unpack (prettyShowValue v) returnCEKValue cont handler (VLiteral LUnit) args -> argsError info b args -coreExpect :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +coreExpect :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpect info b cont handler _env = \case [VLiteral (LString msg), VClosure expected, VClosure provided] -> do es <- get @@ -86,12 +86,10 @@ coreExpect info b cont handler _env = \case returnCEKError info cont handler $ UserEnforceError "FAILURE: expect expression did not return a pact value for comparison" Left err -> do put es - currSource <- useReplState replCurrSource - returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <> - replError currSource err + returnCEKValue cont handler $ VString $ "FAILURE: " <> msg <> " evaluation of actual failed with error message:\n" <> renderCompactText err args -> argsError info b args -coreExpectThat :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +coreExpectThat :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpectThat info b cont handler _env = \case [VLiteral (LString msg), VClosure vclo, v] -> do applyLamUnsafe vclo [v] Mt CEKNoHandler >>= \case @@ -102,7 +100,7 @@ coreExpectThat info b cont handler _env = \case ve@VError{} -> returnCEK cont handler ve args -> argsError info b args -coreExpectFailure :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +coreExpectFailure :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreExpectFailure info b cont handler _env = \case [VString doc, VClosure vclo] -> do es <- get @@ -137,7 +135,7 @@ coreExpectFailure info b cont handler _env = \case args -> argsError info b args -continuePact :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +continuePact :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo continuePact info b cont handler env = \case [VInteger s] -> go s False Nothing Nothing [VInteger s, VBool r] -> go s r Nothing Nothing @@ -169,7 +167,7 @@ continuePact info b cont handler env = \case v <- liftEither merr returnCEK cont handler v -pactState :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +pactState :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo pactState info b cont handler _env = \case [] -> go False [VBool clear] -> go clear @@ -190,14 +188,14 @@ pactState info b cont handler _env = \case returnCEKValue cont handler (VObject (M.fromList ps)) Nothing -> returnCEKError info cont handler $ UserEnforceError "pact-state: no pact exec in context" -coreplEvalEnvStackFrame :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +coreplEvalEnvStackFrame :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo coreplEvalEnvStackFrame info b cont handler _env = \case [] -> do sfs <- fmap (PString . T.pack . show) <$> use esStack returnCEKValue cont handler $ VList (V.fromList sfs) args -> argsError info b args -envEvents :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envEvents :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envEvents info b cont handler _env = \case [VBool clear] -> do events <- reverse . fmap envToObj <$> use esEvents @@ -213,7 +211,7 @@ envEvents info b cont handler _env = \case , ("module-hash", PString (hashToText (_mhHash mh)))] args -> argsError info b args -envHash :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envHash :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envHash info b cont handler _env = \case [VString s] -> do case decodeBase64UrlUnpadded (T.encodeUtf8 s) of @@ -223,7 +221,7 @@ envHash info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set tx hash to " <> s args -> argsError info b args -envData :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envData :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envData info b cont handler _env = \case [VPactValue pv] -> do -- to mimic prod, we must roundtrip here @@ -233,7 +231,7 @@ envData info b cont handler _env = \case returnCEKValue cont handler (VString "Setting transaction data") args -> argsError info b args -envChainData :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envChainData :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envChainData info b cont handler _env = \case [VObject cdataObj] -> do pd <- viewEvalEnv eePublicData @@ -263,7 +261,7 @@ envChainData info b cont handler _env = \case _ -> returnCEKError info cont handler $ UserEnforceError $ "envChainData: bad public metadata value for key: " <> _field k args -> argsError info b args -envKeys :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envKeys :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envKeys info b cont handler _env = \case [VList ks] -> do keys <- traverse (asString info b) ks @@ -271,7 +269,7 @@ envKeys info b cont handler _env = \case returnCEKValue cont handler (VString "Setting transaction keys") args -> argsError info b args -envSigs :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envSigs :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envSigs info b cont handler _env = \case [VList ks] -> case traverse keyCapObj ks of @@ -292,7 +290,7 @@ envSigs info b cont handler _env = \case _ -> Nothing args -> argsError info b args -envVerifiers :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envVerifiers :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envVerifiers info b cont handler _env = \case [VList ks] -> case traverse verifCapObj ks of @@ -314,7 +312,7 @@ envVerifiers info b cont handler _env = \case _ -> Nothing args -> argsError info b args -beginTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +beginTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo beginTx info b cont handler _env = \case [VString s] -> begin' info (Just s) >>= returnCEK cont handler . renderTx info "Begin Tx" [] -> begin' info Nothing >>= returnCEK cont handler . renderTx info "Begin Tx" @@ -325,7 +323,7 @@ renderTx _info start (Just (TxId tid, mt)) = EvalValue $ VString $ start <> " " <> T.pack (show tid) <> maybe mempty (" " <>) mt renderTx info start Nothing = VError [] (UserEnforceError ("tx-function failure " <> start)) info -begin' :: SpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) +begin' :: FileLocSpanInfo -> Maybe Text -> ReplM b (Maybe (TxId, Maybe Text)) begin' info mt = do pdb <- useReplState (replEvalEnv . eePactDb) mode <- viewEvalEnv eeMode @@ -345,7 +343,7 @@ emptyTxState = do put newEvalState -commitTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +commitTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo commitTx info b cont handler _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -359,7 +357,7 @@ commitTx info b cont handler _env = \case args -> argsError info b args -rollbackTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +rollbackTx :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo rollbackTx info b cont handler _env = \case [] -> do pdb <- useReplState (replEvalEnv . eePactDb) @@ -372,7 +370,7 @@ rollbackTx info b cont handler _env = \case Nothing -> returnCEK cont handler (renderTx info "Rollback Tx" Nothing) args -> argsError info b args -sigKeyset :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +sigKeyset :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo sigKeyset info b cont handler _env = \case [] -> do sigs <- S.fromList . M.keys <$> viewEvalEnv eeMsgSigs @@ -380,7 +378,7 @@ sigKeyset info b cont handler _env = \case args -> argsError info b args -testCapability :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +testCapability :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo testCapability info b cont handler env = \case [VCapToken origToken] -> do d <- getDefCap info (_ctName origToken) @@ -395,7 +393,7 @@ testCapability info b cont handler env = \case installCap info env origToken False *> evalCap info cont' handler env origToken PopCapInvoke TestCapEval cBody args -> argsError info b args -envExecConfig :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envExecConfig :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envExecConfig info b cont handler _env = \case [VList s] -> do s' <- traverse go (V.toList s) @@ -412,7 +410,7 @@ envExecConfig info b cont handler _env = \case args -> argsError info b args -envNamespacePolicy :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envNamespacePolicy :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envNamespacePolicy info b cont handler _env = \case [VBool allowRoot, VClosure (C clo)] -> do let qn = fqnToQualName (_cloFqName clo) @@ -425,7 +423,7 @@ envNamespacePolicy info b cont handler _env = \case _ -> returnCEKError info cont handler $ UserEnforceError "invalid namespace manager function type" args -> argsError info b args -envGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGas info b cont handler _env = \case [] -> do Gas gas <- milliGasToGas <$> getGas @@ -435,7 +433,7 @@ envGas info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set gas to " <> T.pack (show g) args -> argsError info b args -envMilliGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envMilliGas :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envMilliGas info b cont handler _env = \case [] -> do MilliGas gas <- getGas @@ -445,14 +443,14 @@ envMilliGas info b cont handler _env = \case returnCEKValue cont handler $ VString $ "Set milligas to" <> T.pack (show g) args -> argsError info b args -envGasLimit :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envGasLimit :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasLimit info b cont handler _env = \case [VInteger g] -> do (replEvalEnv . eeGasEnv . geGasModel . gmGasLimit) .== Just (MilliGasLimit (gasToMilliGas (Gas (fromInteger g)))) returnCEKValue cont handler $ VString $ "Set gas limit to " <> T.pack (show g) args -> argsError info b args -envGasLog :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envGasLog :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasLog info b cont handler _env = \case [] -> do (gasLogRef, logsJustEnabled) <- viewEvalEnv (eeGasEnv . geGasLog) >>= \case @@ -472,7 +470,7 @@ envGasLog info b cont handler _env = \case returnCEKValue cont handler (VList $ V.fromList (totalLine:logLines)) args -> argsError info b args -envEnableReplNatives :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envEnableReplNatives :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envEnableReplNatives info b cont handler _env = \case [VBool enabled] -> do let s = if enabled then "enabled" else "disabled" @@ -480,7 +478,7 @@ envEnableReplNatives info b cont handler _env = \case returnCEKValue cont handler $ VString $ "repl natives " <> s args -> argsError info b args -envGasModel :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envGasModel :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envGasModel info b cont handler _env = \case [] -> do gm <- viewEvalEnv (eeGasEnv . geGasModel) @@ -497,7 +495,7 @@ envGasModel info b cont handler _env = \case args -> argsError info b args -envModuleAdmin :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envModuleAdmin :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envModuleAdmin info b cont handler _env = \case [VModRef modRef] -> do let modName = _mrModule modRef @@ -517,7 +515,7 @@ coreVersion info b cont handler _env = \case in returnCEKValue cont handler (VString v) args -> argsError info b args -envSetDebug :: NativeFunction 'ReplRuntime ReplCoreBuiltin SpanInfo +envSetDebug :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo envSetDebug info b cont handler _env = \case [VString flag] -> do flags <- case T.strip flag of @@ -563,16 +561,27 @@ coreEnforceVersion info b cont handler _env = \case Left _msg -> throwExecutionError info (EnforcePactVersionParseFailure s) Right li -> pure (V.makeVersion li) +load :: NativeFunction 'ReplRuntime ReplCoreBuiltin FileLocSpanInfo +load info b cont handler _env = \case + [VString s] -> load' s False + [VString s, VBool reset] -> load' s reset + args -> argsError info b args + where + load' sourceFile reset = do + replPrintLn $ PString $ "Loading " <> sourceFile <> "..." + fload <- useReplState replLoad + fload (T.unpack sourceFile) reset + returnCEKValue cont handler VUnit replBuiltinEnv - :: BuiltinEnv 'ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo + :: BuiltinEnv 'ReplRuntime (ReplBuiltin CoreBuiltin) FileLocSpanInfo replBuiltinEnv i b env = mkBuiltinFn i b env (replCoreBuiltinRuntime b) replCoreBuiltinRuntime :: ReplBuiltin CoreBuiltin - -> NativeFunction 'ReplRuntime (ReplBuiltin CoreBuiltin) SpanInfo + -> NativeFunction 'ReplRuntime (ReplBuiltin CoreBuiltin) FileLocSpanInfo replCoreBuiltinRuntime = \case RBuiltinWrap cb -> coreBuiltinRuntime cb @@ -619,3 +628,5 @@ replCoreBuiltinRuntime = \case REnvModuleAdmin -> envModuleAdmin REnvVerifiers -> envVerifiers REnvSetDebugFlag -> envSetDebug + RLoad -> load + RLoadWithEnv -> load diff --git a/pact-repl/Pact/Core/Repl/UserDocs.hs b/pact-repl/Pact/Core/Repl/UserDocs.hs index df86c9e07..500eecb5c 100644 --- a/pact-repl/Pact/Core/Repl/UserDocs.hs +++ b/pact-repl/Pact/Core/Repl/UserDocs.hs @@ -10,7 +10,7 @@ import qualified Pact.Core.Syntax.ParseTree as Lisp import Data.Foldable (traverse_) functionDocs - :: Lisp.TopLevel SpanInfo + :: Lisp.TopLevel FileLocSpanInfo -- The original module syntax -> ReplM ReplCoreBuiltin () functionDocs = \case diff --git a/pact-repl/Pact/Core/Repl/Utils.hs b/pact-repl/Pact/Core/Repl/Utils.hs index c1d544925..c78a85fd2 100644 --- a/pact-repl/Pact/Core/Repl/Utils.hs +++ b/pact-repl/Pact/Core/Repl/Utils.hs @@ -19,7 +19,6 @@ module Pact.Core.Repl.Utils , runReplT , ReplState(..) , replFlags - , replEvalLog , replEvalEnv , replUserDocs , replTLDefPos @@ -203,18 +202,19 @@ replCompletion natives = dns = defNames ems in fmap ((renderModuleName mn <> ".") <>) dns -runReplT :: IORef (ReplState b) -> ReplM b a -> IO (Either (PactError SpanInfo) a) +runReplT :: IORef (ReplState b) -> ReplM b a -> IO (Either (PactError FileLocSpanInfo) a) runReplT env st = runEvalMResult (ReplEnv env) def st replError - :: SourceCode - -> PactErrorI + :: HasSpanInfo i + => SourceCode + -> PactError i -> Text replError (SourceCode srcFile src) pe = let file = T.pack srcFile srcLines = T.lines src - pei = view peInfo pe + pei = view (peInfo.spanInfo) pe -- Note: The startline is 0-indexed, but we want our -- repl to output errors which are 1-indexed. start = _liStartLine pei @@ -236,18 +236,21 @@ replError (SourceCode srcFile src) pe = -- Zip the line number with the source text, and apply the number padding correctly withLine st pad lns = zipWith (\i e -> padLeft (T.pack (show i)) pad <> "| " <> e) [st+1..] lns -gasLogEntrytoPactValue :: GasLogEntry (ReplBuiltin CoreBuiltin) SpanInfo -> PactValue +gasLogEntrytoPactValue :: Pretty i => GasLogEntry (ReplBuiltin CoreBuiltin) i -> PactValue gasLogEntrytoPactValue entry = PString $ renderCompactText' $ n <> ": " <> pretty (_gleThisUsed entry) where n = pretty (_gleArgs entry) <+> pretty (_gleInfo entry) -replPrintLn :: Pretty a => a -> EvalM 'ReplRuntime b SpanInfo () +replPrintLn :: Pretty a => a -> EvalM 'ReplRuntime b FileLocSpanInfo () replPrintLn p = replPrintLn' (renderCompactText p) -replPrintLn' :: Text -> EvalM 'ReplRuntime b SpanInfo () +replPrintLn' :: Text -> EvalM 'ReplRuntime b FileLocSpanInfo () replPrintLn' p = do r <- getReplState - _replOutputLine r p + case _replLogType r of + ReplStdOut -> _replOutputLine r p + ReplLogOut v -> + liftIO (modifyIORef' v (p:)) -- This orphan instance allows us to separate -- the repl declaration out, as ugly as it is diff --git a/pact-tests/Pact/Core/Test/DocsTests.hs b/pact-tests/Pact/Core/Test/DocsTests.hs index b84e6ddd5..466880336 100644 --- a/pact-tests/Pact/Core/Test/DocsTests.hs +++ b/pact-tests/Pact/Core/Test/DocsTests.hs @@ -33,4 +33,4 @@ docsExistsTest b = testCase "Builtins should have docs" $ do ,"env-gaslog", "env-gasmodel-fixed", "env-milligas", "env-module-admin" ,"env-set-milligas", "env-stackframe", "env-verifiers", "negate" ,"pact-state", "print", "reset-pact-state", "rollback-tx", "show" - ,"sig-keyset", "test-capability", "env-set-debug-flag"] + ,"sig-keyset", "test-capability", "env-set-debug-flag","load-with-env"] diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index ab469512a..229d88fb0 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/pact-tests/Pact/Core/Test/GasGolden.hs @@ -12,6 +12,7 @@ import Pact.Core.Builtin import Pact.Core.Environment import Pact.Core.Gas import Pact.Core.Persistence.MockPersistence +import Pact.Core.Repl import Pact.Core.Repl.Compile import Pact.Core.Repl.Utils import Pact.Core.Serialise @@ -107,23 +108,12 @@ fileNameToOp = M.fromList [(v,k) | (k, v) <- M.toList opToFileName] runGasTest :: FilePath -> InterpretPact -> IO (Maybe MilliGas) runGasTest file interpret = do src <- T.readFile file - pdb <- mockPactDb serialisePact_repl_spaninfo - gasLog <- newIORef Nothing + pdb <- mockPactDb serialisePact_repl_flspaninfo ee <- defaultEvalEnv pdb replBuiltinMap let ee' = ee & eeGasEnv . geGasModel .~ replTableGasModel (Just (maxBound :: MilliGasLimit)) gasRef = ee' ^. eeGasEnv . geGasRef let source = SourceCode file src - let rstate = ReplState - { _replFlags = mempty - , _replEvalLog = gasLog - , _replCurrSource = source - , _replEvalEnv = ee' - , _replUserDocs = mempty - , _replTLDefPos = mempty - , _replTx = Nothing - , _replNativesEnabled = False - , _replOutputLine = const (pure ()) - } + rstate <- set replEvalEnv ee' <$> defaultReplState (const (pure ())) stateRef <- newIORef rstate runReplT stateRef (interpret source) >>= \case Left _ -> pure Nothing diff --git a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs index 481d93f2a..cb25f17ad 100644 --- a/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs +++ b/pact-tests/Pact/Core/Test/LegacySerialiseTests.hs @@ -62,7 +62,7 @@ legacyTests = do pure (testGroup p modTests) where runTest r interpreter interpName = do - pdb <- mockPactDb serialisePact_repl_spaninfo + pdb <- mockPactDb serialisePact_repl_flspaninfo -- add default spaninfo let ms' = (fmap.fmap) (const def) ms diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index fd9a9694d..09176543c 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-tests/Pact/Core/Test/ReplTests.hs @@ -24,7 +24,7 @@ import Pact.Core.Repl.Utils import Pact.Core.Persistence (PactDb) import Pact.Core.Persistence.SQLite (withSqlitePactDb) -import Pact.Core.Info (SpanInfo) +import Pact.Core.Info import Pact.Core.Compile import Pact.Core.Repl.Compile import Pact.Core.PactValue @@ -58,7 +58,7 @@ replTestFiles = filter (\f -> isExtensionOf "repl" f || isExtensionOf "pact" f) runFileReplTest :: Interpreter -> TestName -> TestTree runFileReplTest interp file = testCase file $ do - pdb <- mockPactDb serialisePact_repl_spaninfo + pdb <- mockPactDb serialisePact_repl_flspaninfo src <- T.readFile (defaultReplTestDir file) runReplTest (ReplSourceDir defaultReplTestDir) pdb file src interp @@ -66,23 +66,41 @@ runFileReplTest interp file = testCase file $ do runFileReplTestSqlite :: Interpreter -> TestName -> TestTree runFileReplTestSqlite interp file = testCase file $ do ctnt <- T.readFile (defaultReplTestDir file) - withSqlitePactDb serialisePact_repl_spaninfo ":memory:" $ \pdb -> do + withSqlitePactDb serialisePact_repl_flspaninfo ":memory:" $ \pdb -> do runReplTest (ReplSourceDir defaultReplTestDir) pdb file ctnt interp +-- replTestState = do +-- pdb <- mockPactDb serialisePact_repl_flspaninfo +-- ee <- defaultEvalEnv pdb replBuiltinMap +-- let rstate = ReplState +-- {_replLogType=ReplStdOut +-- , _replUserDocs= mempty +-- , _replTx = Nothing +-- , _replTLDefPos = mempty +-- , _replOutputLine = const (pure ()) +-- , _replNativesEnabled = False +-- , _replLoadedFiles = mempty +-- , _replLoad = defaultLoadFile +-- , _replFlags = mempty +-- , _replEvalEnv = ee +-- , _replCurrSource = defaultSrc} +-- pure (ref, rstate) +-- where +-- defaultSrc = SourceCode "(interactive)" mempty + runReplTest :: ReplSourceDir - -> PactDb ReplCoreBuiltin SpanInfo + -> PactDb ReplCoreBuiltin FileLocSpanInfo -> FilePath -> T.Text -> Interpreter -> Assertion runReplTest (ReplSourceDir path) pdb file src interp = do - gasLog <- newIORef Nothing ee <- defaultEvalEnv pdb replBuiltinMap + outRef <- newIORef [] let source = SourceCode (path file) src let rstate = ReplState { _replFlags = mempty - , _replEvalLog = gasLog , _replCurrSource = source , _replEvalEnv = ee , _replUserDocs = mempty @@ -90,6 +108,9 @@ runReplTest (ReplSourceDir path) pdb file src interp = do , _replTx = Nothing , _replNativesEnabled = False , _replOutputLine = const (pure ()) + , _replLoad = defaultLoadFile + , _replLogType = ReplLogOut outRef + , _replLoadedFiles = mempty } stateRef <- newIORef rstate runReplT stateRef (interp source) >>= \case diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index d2833d246..84349036f 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -18,29 +18,28 @@ import Pact.Core.Errors import Pact.Core.Persistence.MockPersistence (mockPactDb) import Pact.Core.Repl.Compile import Pact.Core.Repl.Utils -import Pact.Core.Serialise (serialisePact_repl_spaninfo) +import Pact.Core.Serialise +import Pact.Core.Info -isParseError :: Prism' ParseError a -> PactErrorI -> Bool +isParseError :: Prism' ParseError a -> PactError FileLocSpanInfo -> Bool isParseError p s = has (_PEParseError . _1 . p) s -isDesugarError :: Prism' DesugarError a -> PactErrorI -> Bool +isDesugarError :: Prism' DesugarError a -> PactError FileLocSpanInfo -> Bool isDesugarError p s = has (_PEDesugarError . _1 . p) s -isExecutionError :: Prism' EvalError a -> PactErrorI -> Bool +isExecutionError :: Prism' EvalError a -> PactError FileLocSpanInfo -> Bool isExecutionError p s = has (_PEExecutionError . _1 . p) s -isUserRecoverableError :: Prism' UserRecoverableError a -> PactErrorI -> Bool +isUserRecoverableError :: Prism' UserRecoverableError a -> PactError FileLocSpanInfo -> Bool isUserRecoverableError p s = has (_PEUserRecoverableError . _1 . p) s -runStaticTest :: String -> Text -> ReplInterpreter -> (PactErrorI -> Bool) -> Assertion +runStaticTest :: String -> Text -> ReplInterpreter -> (PactError FileLocSpanInfo -> Bool) -> Assertion runStaticTest label src interp predicate = do - gasLog <- newIORef Nothing - pdb <- mockPactDb serialisePact_repl_spaninfo + pdb <- mockPactDb serialisePact_repl_flspaninfo ee <- defaultEvalEnv pdb replBuiltinMap let source = SourceCode label src rstate = ReplState { _replFlags = mempty - , _replEvalLog = gasLog , _replCurrSource = source , _replEvalEnv = ee , _replUserDocs = mempty @@ -48,6 +47,9 @@ runStaticTest label src interp predicate = do , _replTx = Nothing , _replNativesEnabled = True , _replOutputLine = const (pure ()) + , _replLoad = defaultLoadFile + , _replLogType = ReplStdOut + , _replLoadedFiles = mempty } stateRef <- newIORef rstate v <- runReplT stateRef (interpretReplProgram interp source) @@ -56,7 +58,7 @@ runStaticTest label src interp predicate = do assertBool ("Expected Error to match predicate, but got " <> show err <> " instead") (predicate err) Right _v -> assertFailure ("Error: Static failure test succeeded for test: " <> label) -parseTests :: [(String, PactErrorI -> Bool, Text)] +parseTests :: [(String, PactError FileLocSpanInfo -> Bool, Text)] parseTests = [ ("defpact_empty", isParseError _ParsingError, [text| (module m g (defcap g () true) @@ -73,7 +75,7 @@ parseTests = |]) ] -desugarTests :: [(String, PactErrorI -> Bool, Text)] +desugarTests :: [(String, PactError FileLocSpanInfo -> Bool, Text)] desugarTests = [ ("no_bind_body", isDesugarError _EmptyBindingBody, [text|(bind {"a":1} {"a":=a})|]) , ("defpact_last_step_rollback", isDesugarError _LastStepWithRollback, [text| @@ -605,7 +607,7 @@ desugarTests = |]) ] -executionTests :: [(String, PactErrorI -> Bool, Text)] +executionTests :: [(String, PactError FileLocSpanInfo -> Bool, Text)] executionTests = [ ("enforce_ns_install_module", isExecutionError _RootNamespaceInstallError, [text| (module m g (defcap g () true) @@ -1100,7 +1102,7 @@ executionTests = |]) ] -builtinTests :: [(String, PactErrorI -> Bool, Text)] +builtinTests :: [(String, PactError FileLocSpanInfo -> Bool, Text)] builtinTests = [ ("integer_pow_negative", isExecutionError _ArithmeticException, "(^ 0 -1)") , ("floating_pow_negative", isExecutionError _FloatingPointError, "(^ 0.0 -1.0)") diff --git a/pact-tests/gas-goldens/builtinGas.golden b/pact-tests/gas-goldens/builtinGas.golden index 3aeb539e6..4f0af2c08 100644 --- a/pact-tests/gas-goldens/builtinGas.golden +++ b/pact-tests/gas-goldens/builtinGas.golden @@ -11,7 +11,7 @@ >=: 264 ^: 868 abs: 100 -acquire-module-admin: 234194 +acquire-module-admin: 234198 add-time: 750 and?: 628 at: 706 diff --git a/pact/Pact/Core/Builtin.hs b/pact/Pact/Core/Builtin.hs index 9e3440e0b..c34c45f9e 100644 --- a/pact/Pact/Core/Builtin.hs +++ b/pact/Pact/Core/Builtin.hs @@ -779,6 +779,8 @@ data ReplOnlyBuiltin | REnvModuleAdmin | REnvVerifiers | REnvSetDebugFlag + | RLoad + | RLoadWithEnv deriving (Show, Enum, Bounded, Eq, Generic) @@ -828,9 +830,8 @@ instance IsBuiltin ReplOnlyBuiltin where REnvModuleAdmin -> 1 REnvVerifiers -> 1 REnvSetDebugFlag -> 1 - - -- RLoad -> 1 - -- RLoadWithEnv -> 2 + RLoad -> 1 + RLoadWithEnv -> 2 -- Note: commented out natives are -- to be implemented later data ReplBuiltin b @@ -914,6 +915,8 @@ replBuiltinsToText = \case REnvModuleAdmin -> "env-module-admin" REnvVerifiers -> "env-verifiers" REnvSetDebugFlag -> "env-set-debug-flag" + RLoad -> "load" + RLoadWithEnv -> "load-with-env" replBuiltinToText :: (t -> Text) -> ReplBuiltin t -> Text replBuiltinToText f = \case diff --git a/pact/Pact/Core/Environment/Types.hs b/pact/Pact/Core/Environment/Types.hs index b2cc1fa2a..ecff80c25 100644 --- a/pact/Pact/Core/Environment/Types.hs +++ b/pact/Pact/Core/Environment/Types.hs @@ -64,7 +64,6 @@ module Pact.Core.Environment.Types , EvalM(..) , RuntimeMode(..) , replFlags - , replEvalLog , replEvalEnv , replUserDocs , replTLDefPos @@ -72,7 +71,10 @@ module Pact.Core.Environment.Types , replCurrSource , replTx , replOutputLine + , replLoad + , replLoadedFiles , ReplM + , ReplOutput(..) , ReplDebugFlag(..) , SourceCode(..) , PactWarning(..) @@ -340,23 +342,29 @@ defaultEvalEnv pdb m = do , _eeWarnings = Just warningRef } +data ReplOutput where + ReplStdOut :: ReplOutput + ReplLogOut :: IORef [Text] -> ReplOutput + -- | Passed in repl environment data ReplState b = ReplState { _replFlags :: Set ReplDebugFlag - , _replEvalEnv :: EvalEnv b SpanInfo - , _replEvalLog :: IORef (Maybe [(Text, Gas)]) + , _replEvalEnv :: EvalEnv b FileLocSpanInfo + , _replLogType :: ReplOutput , _replCurrSource :: SourceCode , _replUserDocs :: Map QualifiedName Text -- ^ Used by Repl and LSP Server, reflects the user -- annotated @doc string. - , _replTLDefPos :: Map QualifiedName SpanInfo + , _replTLDefPos :: Map QualifiedName FileLocSpanInfo -- ^ Used by LSP Server, reflects the span information -- of the TL definitions for the qualified name. , _replTx :: Maybe (TxId, Maybe Text) , _replNativesEnabled :: Bool -- ^ - , _replOutputLine :: !(Text -> EvalM 'ReplRuntime b SpanInfo ()) + , _replOutputLine :: !(Text -> EvalM 'ReplRuntime b FileLocSpanInfo ()) + , _replLoad :: !(FilePath -> Bool -> EvalM 'ReplRuntime b FileLocSpanInfo ()) + , _replLoadedFiles :: Map FilePath SourceCode } data RuntimeMode @@ -366,7 +374,7 @@ data RuntimeMode data EvalMEnv e b i where ExecEnv :: EvalEnv b i -> EvalMEnv ExecRuntime b i - ReplEnv :: IORef (ReplState b) -> EvalMEnv ReplRuntime b SpanInfo + ReplEnv :: IORef (ReplState b) -> EvalMEnv ReplRuntime b FileLocSpanInfo -- Todo: are we going to inject state as the reader monad here? @@ -382,7 +390,7 @@ newtype EvalM e b i a = , MonadState (EvalState b i) , MonadError (PactError i)) -type ReplM b = EvalM ReplRuntime b SpanInfo +type ReplM b = EvalM ReplRuntime b FileLocSpanInfo runEvalM diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index 400c102a7..ad30ca65d 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -186,6 +186,8 @@ instance DesugarBuiltin (ReplBuiltin CoreBuiltin) where desugarAppArity i (RBuiltinWrap b) ne = desugarCoreBuiltinArity RBuiltinWrap i b ne -- (expect ) + desugarAppArity i (RBuiltinRepl RLoad) [e1, e2] = + App (Builtin (RBuiltinRepl RLoadWithEnv) i) [e1, e2] i desugarAppArity i (RBuiltinRepl RExpect) ([e1, e2, e3]) | isn't _Nullary e3 = App (Builtin (RBuiltinRepl RExpect) i) ([e1, suspendTerm e2, suspendTerm e3]) i -- (expect-failure ) diff --git a/pact/Pact/Core/Info.hs b/pact/Pact/Core/Info.hs index d1c56967a..23a697bbc 100644 --- a/pact/Pact/Core/Info.hs +++ b/pact/Pact/Core/Info.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE InstanceSigs #-} module Pact.Core.Info ( SpanInfo(..) @@ -12,6 +14,8 @@ module Pact.Core.Info , sliceFromSourceLines , LineInfo(..) , spanInfoToLineInfo + , FileLocSpanInfo(..) + , HasSpanInfo(..) ) where import Control.Lens @@ -71,6 +75,12 @@ instance Pretty SpanInfo where spanInfoToLineInfo :: SpanInfo -> LineInfo spanInfoToLineInfo = LineInfo . _liStartLine +data FileLocSpanInfo + = FileLocSpanInfo + { _flsiFile :: !String + , _flsiSpan :: !SpanInfo + } deriving (Eq, Show, Generic, NFData) + -- | Combine two Span infos -- and spit out how far down the expression spans. combineSpan :: SpanInfo -> SpanInfo -> SpanInfo @@ -96,3 +106,14 @@ data Located i a { _locLocation :: i , _locElem :: a } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) + +makeClassy ''SpanInfo + +instance HasSpanInfo FileLocSpanInfo where + spanInfo = lens _flsiSpan (\s i -> s { _flsiSpan = i }) + +instance Pretty FileLocSpanInfo where + pretty (FileLocSpanInfo f s) = pretty f <> " " <> pretty s + +instance Default FileLocSpanInfo where + def = FileLocSpanInfo "" def diff --git a/pact/Pact/Core/Serialise.hs b/pact/Pact/Core/Serialise.hs index 46a402bd6..ff38c37bc 100644 --- a/pact/Pact/Core/Serialise.hs +++ b/pact/Pact/Core/Serialise.hs @@ -18,6 +18,7 @@ module Pact.Core.Serialise , serialisePact_raw_spaninfo , serialisePact_lineinfo , serialisePact_repl_spaninfo + , serialisePact_repl_flspaninfo , decodeVersion , encodeVersion , liftReplBuiltin @@ -166,6 +167,18 @@ serialisePact_repl_spaninfo = serialisePact , _encodeRowData = gEncodeRowData } +serialisePact_repl_flspaninfo :: PactSerialise ReplCoreBuiltin FileLocSpanInfo +serialisePact_repl_flspaninfo = serialisePact + { _encodeModuleData = docEncode V1.encodeModuleData_repl_flspaninfo + , _decodeModuleData = + \bs -> + (LegacyDocument . fmap def . liftReplBuiltin <$> LegacyPact.decodeModuleData bs) + <|> docDecode bs (\case + V1_CBOR -> V1.decodeModuleData_repl_flspaninfo + ) + , _encodeRowData = gEncodeRowData + } + docEncode :: (a -> ByteString) -> a -> ByteString docEncode enc o = toStrictByteString (encodeVersion V1_CBOR <> S.encodeBytes (enc o)) {-# INLINE docEncode #-} diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index 93400eefc..ef715d97c 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -14,6 +14,7 @@ module Pact.Core.Serialise.CBOR_V1 ( encodeModuleData, decodeModuleData , encodeModuleData_repl_spaninfo, decodeModuleData_repl_spaninfo , encodeModuleData_raw_spaninfo, decodeModuleData_raw_spaninfo + , encodeModuleData_repl_flspaninfo, decodeModuleData_repl_flspaninfo , encodeModuleData_lineinfo, decodeModuleData_lineinfo , encodeKeySet, decodeKeySet , encodeDefPactExec, decodeDefPactExec @@ -68,6 +69,9 @@ encodeModuleData = toStrictByteString . encodeS encodeModuleData_repl_spaninfo :: ModuleData ReplCoreBuiltin SpanInfo -> ByteString encodeModuleData_repl_spaninfo = toStrictByteString . encodeS +encodeModuleData_repl_flspaninfo :: ModuleData ReplCoreBuiltin FileLocSpanInfo -> ByteString +encodeModuleData_repl_flspaninfo = toStrictByteString . encodeS + encodeModuleData_raw_spaninfo :: ModuleData CoreBuiltin SpanInfo -> ByteString encodeModuleData_raw_spaninfo = toStrictByteString . encodeS @@ -89,6 +93,9 @@ decodeModuleData_raw_spaninfo bs = either (const Nothing) (Just . _getSV1) (dese decodeModuleData_lineinfo :: ByteString -> Maybe (ModuleData CoreBuiltin LineInfo) decodeModuleData_lineinfo bs = either (const Nothing) (Just . _getSV1) (deserialiseOrFail (fromStrict bs)) +decodeModuleData_repl_flspaninfo :: ByteString -> Maybe (ModuleData ReplCoreBuiltin FileLocSpanInfo) +decodeModuleData_repl_flspaninfo bs = either (const Nothing) (Just . _getSV1) (deserialiseOrFail (fromStrict bs)) + encodeModuleName :: ModuleName -> ByteString encodeModuleName = toStrictByteString . encodeS @@ -848,6 +855,15 @@ instance Serialise (SerialiseV1 SpanInfo) where SerialiseV1 <$> (SpanInfo <$> decode <*> decode <*> decode <*> decode) {-# INLINE decode #-} +instance Serialise (SerialiseV1 FileLocSpanInfo) where + encode (SerialiseV1 (FileLocSpanInfo f s)) = + encodeListLen 2 <> encode f <> encodeS s + {-# INLINE encode #-} + decode = do + safeDecodeListLen 2 "FileLocSpanInfo" + SerialiseV1 <$> (FileLocSpanInfo <$> decode <*> decodeS) + {-# INLINE decode #-} + instance Serialise (SerialiseV1 LineInfo) where encode (SerialiseV1 (LineInfo li)) = encode li {-# INLINE encode #-} diff --git a/pact/Pact/Core/SizeOf.hs b/pact/Pact/Core/SizeOf.hs index 645f1aa88..4ebb03ff4 100644 --- a/pact/Pact/Core/SizeOf.hs +++ b/pact/Pact/Core/SizeOf.hs @@ -339,6 +339,11 @@ instance SizeOf (TableSchema name) where makeSizeOf ''SpanInfo +-- Note: this is a pass through instance, since this is repl-only +instance SizeOf FileLocSpanInfo where + estimateSize (FileLocSpanInfo _f s) = + estimateSize s + -- builtins instance SizeOf CoreBuiltin where estimateSize _ = countBytes (tagOverhead + 1) diff --git a/pact/Pact/Core/Syntax/ParseTree.hs b/pact/Pact/Core/Syntax/ParseTree.hs index 8417325b2..be040e19b 100644 --- a/pact/Pact/Core/Syntax/ParseTree.hs +++ b/pact/Pact/Core/Syntax/ParseTree.hs @@ -636,7 +636,7 @@ data ReplTopLevel i = RTLTopLevel (TopLevel i) | RTLDefun (Defun i) | RTLDefConst (DefConst i) - deriving (Show, Generic, NFData) + deriving (Show, Generic, NFData, Functor) pattern RTLModule :: Module i -> ReplTopLevel i pattern RTLModule m = RTLTopLevel (TLModule m)