From fa228cb7037b408ba69bc5f1888defed6eb036d5 Mon Sep 17 00:00:00 2001 From: jmcardon Date: Thu, 29 Aug 2024 20:05:19 -0400 Subject: [PATCH] Add warnings to repl, improve repl printing api --- gasmodel/Pact/Core/GasModel/ContractBench.hs | 1 + pact-lsp/Pact/Core/LanguageServer.hs | 1 + pact-tests/Pact/Core/Test/GasGolden.hs | 5 +-- pact-tests/Pact/Core/Test/ReplTests.hs | 5 +-- pact-tests/Pact/Core/Test/StaticErrorTests.hs | 3 +- pact/Pact/Core/Environment/Types.hs | 25 +++++++++++++++ pact/Pact/Core/Evaluate.hs | 1 + pact/Pact/Core/IR/Eval/CEK.hs | 15 +++++---- pact/Pact/Core/IR/Eval/CoreBuiltin.hs | 6 +++- pact/Pact/Core/IR/Eval/Direct/Evaluator.hs | 18 +++++++---- pact/Pact/Core/IR/Eval/Runtime/Types.hs | 1 - pact/Pact/Core/IR/Eval/Runtime/Utils.hs | 9 ++++++ pact/Pact/Core/Info.hs | 14 ++++++++ pact/Pact/Core/Names.hs | 13 ++++---- pact/Pact/Core/Repl.hs | 12 ++++--- pact/Pact/Core/Repl/Compile.hs | 32 ++++++++++++------- pact/Pact/Core/Repl/Utils.hs | 13 ++++++++ profile-tx/ProfileTx.hs | 1 + 18 files changed, 132 insertions(+), 43 deletions(-) diff --git a/gasmodel/Pact/Core/GasModel/ContractBench.hs b/gasmodel/Pact/Core/GasModel/ContractBench.hs index d63a1877b..478cd257c 100644 --- a/gasmodel/Pact/Core/GasModel/ContractBench.hs +++ b/gasmodel/Pact/Core/GasModel/ContractBench.hs @@ -179,6 +179,7 @@ setupBenchEvalEnv pdb signers mBody = do , _eeNamespacePolicy = SimpleNamespacePolicy , _eeGasEnv = gasEnv , _eeSPVSupport = noSPVSupport + , _eeWarnings = Nothing } diff --git a/pact-lsp/Pact/Core/LanguageServer.hs b/pact-lsp/Pact/Core/LanguageServer.hs index ca0ec343a..fae3b750d 100644 --- a/pact-lsp/Pact/Core/LanguageServer.hs +++ b/pact-lsp/Pact/Core/LanguageServer.hs @@ -251,6 +251,7 @@ 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 + , _replOutputLine = const (pure ()) } stateRef <- newIORef rstate res <- runReplT stateRef (processFile Repl.interpretEvalBigStep nuri content) diff --git a/pact-tests/Pact/Core/Test/GasGolden.hs b/pact-tests/Pact/Core/Test/GasGolden.hs index 3993ba7a9..ab469512a 100644 --- a/pact-tests/Pact/Core/Test/GasGolden.hs +++ b/pact-tests/Pact/Core/Test/GasGolden.hs @@ -29,7 +29,7 @@ import qualified Data.Text.IO as T import Data.List (sort) import Control.Lens -type InterpretPact = SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] +type InterpretPact = SourceCode -> ReplM ReplCoreBuiltin [ReplCompileValue] tests :: IO TestTree tests = do @@ -122,8 +122,9 @@ runGasTest file interpret = do , _replTLDefPos = mempty , _replTx = Nothing , _replNativesEnabled = False + , _replOutputLine = const (pure ()) } stateRef <- newIORef rstate - runReplT stateRef (interpret source (const (pure ()))) >>= \case + runReplT stateRef (interpret source) >>= \case Left _ -> pure Nothing Right _ -> Just <$> readIORef gasRef diff --git a/pact-tests/Pact/Core/Test/ReplTests.hs b/pact-tests/Pact/Core/Test/ReplTests.hs index 6ac0492dd..fd9a9694d 100644 --- a/pact-tests/Pact/Core/Test/ReplTests.hs +++ b/pact-tests/Pact/Core/Test/ReplTests.hs @@ -34,7 +34,7 @@ import Pact.Core.Errors import Pact.Core.Serialise -type Interpreter = SourceCode -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] +type Interpreter = SourceCode -> ReplM ReplCoreBuiltin [ReplCompileValue] tests :: IO TestTree tests = do @@ -89,9 +89,10 @@ runReplTest (ReplSourceDir path) pdb file src interp = do , _replTLDefPos = mempty , _replTx = Nothing , _replNativesEnabled = False + , _replOutputLine = const (pure ()) } stateRef <- newIORef rstate - runReplT stateRef (interp source (const (pure ()))) >>= \case + runReplT stateRef (interp source) >>= \case Left e -> let rendered = replError (SourceCode file src) e in assertFailure (T.unpack rendered) diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 8388d55dd..8799dedfe 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -47,9 +47,10 @@ runStaticTest label src interp predicate = do , _replTLDefPos = mempty , _replTx = Nothing , _replNativesEnabled = True + , _replOutputLine = const (pure ()) } stateRef <- newIORef rstate - v <- runReplT stateRef (interpretReplProgram interp source (const (pure ()))) + v <- runReplT stateRef (interpretReplProgram interp source) case v of Left err -> assertBool ("Expected Error to match predicate, but got " <> show err <> " instead") (predicate err) diff --git a/pact/Pact/Core/Environment/Types.hs b/pact/Pact/Core/Environment/Types.hs index fa8de45d0..e1f8167cd 100644 --- a/pact/Pact/Core/Environment/Types.hs +++ b/pact/Pact/Core/Environment/Types.hs @@ -14,7 +14,9 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} module Pact.Core.Environment.Types ( EvalEnv(..) @@ -25,6 +27,7 @@ module Pact.Core.Environment.Types , eeNatives, eeGasEnv , eeNamespacePolicy , eeMsgVerifiers + , eeWarnings , TxCreationTime(..) , PublicData(..) , pdPublicMeta, pdBlockHeight @@ -68,9 +71,11 @@ module Pact.Core.Environment.Types , replNativesEnabled , replCurrSource , replTx + , replOutputLine , ReplM , ReplDebugFlag(..) , SourceCode(..) + , PactWarning(..) ) where @@ -107,6 +112,7 @@ import Pact.Core.Namespace import Pact.Core.StackFrame import Pact.Core.SPV import Pact.Core.Info +import Pact.Core.Pretty data SourceCode = SourceCode @@ -158,6 +164,21 @@ flagReps :: Map Text ExecutionFlag flagReps = M.fromList $ map go [minBound .. maxBound] where go f = (flagRep f,f) +data PactWarning + = DeprecatedNative NativeName Text + -- ^ Deprecated natives + | ModuleGuardEnforceDetected + deriving (Show, Eq, Ord) + +instance Pretty PactWarning where + pretty = ("Warning: " <>) . \case + DeprecatedNative ndef msg -> + "Using deprecated native" <+> pretty ndef <> ":" <+> pretty msg + ModuleGuardEnforceDetected -> + "Module guard enforce detected. Module guards are known to be unsafe, and will be removed in a future version of pact" + +type LocatedPactWarning i = Located i PactWarning + -- From pact -- | All of the types included in our evaluation environment. data EvalEnv b i @@ -188,6 +209,7 @@ data EvalEnv b i -- ^ The gas environment , _eeSPVSupport :: SPVSupport -- ^ The SPV backend + , _eeWarnings :: !(Maybe (IORef (Set (LocatedPactWarning i)))) } deriving (Generic) instance (NFData b, NFData i) => NFData (EvalEnv b i) @@ -258,6 +280,7 @@ defaultEvalEnv -> IO (EvalEnv b i) defaultEvalEnv pdb m = do gasRef <- newIORef mempty + warningRef <- newIORef mempty pure $ EvalEnv { _eeMsgSigs = mempty , _eeMsgVerifiers = mempty @@ -276,6 +299,7 @@ defaultEvalEnv pdb m = do , _geGasLog = Nothing , _geGasModel = freeGasModel } + , _eeWarnings = Just warningRef } -- | Passed in repl environment @@ -294,6 +318,7 @@ data ReplState b , _replTx :: Maybe (TxId, Maybe Text) , _replNativesEnabled :: Bool -- ^ + , _replOutputLine :: !(forall a. Pretty a => a -> EvalM 'ReplRuntime b SpanInfo ()) } data RuntimeMode diff --git a/pact/Pact/Core/Evaluate.hs b/pact/Pact/Core/Evaluate.hs index cc72d49cc..143913b18 100644 --- a/pact/Pact/Core/Evaluate.hs +++ b/pact/Pact/Core/Evaluate.hs @@ -173,6 +173,7 @@ setupEvalEnv pdb mode msgData gasModel' np spv pd efs = do , _eeNamespacePolicy = np , _eeGasEnv = gasEnv , _eeSPVSupport = spv + , _eeWarnings = Nothing } where mkMsgSigs ss = M.fromList $ map toPair ss diff --git a/pact/Pact/Core/IR/Eval/CEK.hs b/pact/Pact/Core/IR/Eval/CEK.hs index 58446ea48..a762c4223 100644 --- a/pact/Pact/Core/IR/Eval/CEK.hs +++ b/pact/Pact/Core/IR/Eval/CEK.hs @@ -1537,13 +1537,14 @@ enforceGuard info cont handler env g = case g of isKeysetNameInSigs info cont handler env ksn GUserGuard ug -> runUserGuard info cont handler env ug GCapabilityGuard cg -> enforceCapGuard info cont handler cg - GModuleGuard (ModuleGuard mn _) -> calledByModule mn >>= \case - True -> returnCEKValue cont handler (VBool True) - False -> do - md <- getModule info mn - let cont' = IgnoreValueC (PBool True) cont - acquireModuleAdmin info cont' handler env md - -- returnCEKValue cont handler (VBool True)guard + GModuleGuard (ModuleGuard mn _) -> do + emitPactWarning info ModuleGuardEnforceDetected + calledByModule mn >>= \case + True -> returnCEKValue cont handler (VBool True) + False -> do + md <- getModule info mn + let cont' = IgnoreValueC (PBool True) cont + acquireModuleAdmin info cont' handler env md GDefPactGuard (DefPactGuard dpid _) -> do curDpid <- getDefPactId info if curDpid == dpid diff --git a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs index 62c699e82..25bad3bc7 100644 --- a/pact/Pact/Core/IR/Eval/CoreBuiltin.hs +++ b/pact/Pact/Core/IR/Eval/CoreBuiltin.hs @@ -1207,7 +1207,9 @@ createCapabilityPactGuard info b cont handler _env = \case createModuleGuard :: (IsBuiltin b) => NativeFunction e b i createModuleGuard info b cont handler _env = \case - [VString n] -> + [VString n] -> do + emitPactWarning info $ DeprecatedNative (builtinName b) + "Module guards have been deprecate and will be removed in a future release, please switch to capability guards" findCallingModule >>= \case Just mn -> do let cg = GModuleGuard (ModuleGuard mn n) @@ -1219,6 +1221,8 @@ createModuleGuard info b cont handler _env = \case createDefPactGuard :: (IsBuiltin b) => NativeFunction e b i createDefPactGuard info b cont handler _env = \case [VString name] -> do + emitPactWarning info $ DeprecatedNative (builtinName b) + "Pact guards have been deprecated and will be removed in a future release, please switch to capability guards" dpid <- getDefPactId info returnCEKValue cont handler $ VGuard $ GDefPactGuard $ DefPactGuard dpid name args -> argsError info b args diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index 4f4ecc932..57d5d2fb1 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -864,11 +864,13 @@ enforceGuard info env g = case g of isKeysetNameInSigs info env ksn GUserGuard ug -> runUserGuard info env ug GCapabilityGuard cg -> enforceCapGuard info cg - GModuleGuard (ModuleGuard mn _) -> calledByModule mn >>= \case - True -> return True - False -> do - acquireModuleAdminCapability info env mn - return True + GModuleGuard (ModuleGuard mn _) -> do + emitPactWarning info ModuleGuardEnforceDetected + calledByModule mn >>= \case + True -> return True + False -> do + acquireModuleAdminCapability info env mn + return True GDefPactGuard (DefPactGuard dpid _) -> do curDpid <- getDefPactId info if curDpid == dpid @@ -2472,7 +2474,9 @@ createCapabilityPactGuard info b _env = \case createModuleGuard :: (IsBuiltin b) => NativeFunction e b i createModuleGuard info b _env = \case - [VString n] -> + [VString n] -> do + emitPactWarning info $ DeprecatedNative (builtinName b) + "Module guards have been deprecated and will be removed in a future release, please switch to capability guards" findCallingModule >>= \case Just mn -> do let cg = GModuleGuard (ModuleGuard mn n) @@ -2484,6 +2488,8 @@ createModuleGuard info b _env = \case createDefPactGuard :: (IsBuiltin b) => NativeFunction e b i createDefPactGuard info b _env = \case [VString name] -> do + emitPactWarning info $ DeprecatedNative (builtinName b) + "Pact guards have been deprecated and will be removed in a future release, please switch to capability guards" dpid <- getDefPactId info return $ VGuard $ GDefPactGuard $ DefPactGuard dpid name args -> argsError info b args diff --git a/pact/Pact/Core/IR/Eval/Runtime/Types.hs b/pact/Pact/Core/IR/Eval/Runtime/Types.hs index d0ab3155e..fdd9fbc35 100644 --- a/pact/Pact/Core/IR/Eval/Runtime/Types.hs +++ b/pact/Pact/Core/IR/Eval/Runtime/Types.hs @@ -18,7 +18,6 @@ module Pact.Core.IR.Eval.Runtime.Types , EvalCapType(..)) where - import Data.List.NonEmpty(NonEmpty) import GHC.Generics import Control.DeepSeq diff --git a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs index 49e12b472..21082c121 100644 --- a/pact/Pact/Core/IR/Eval/Runtime/Utils.hs +++ b/pact/Pact/Core/IR/Eval/Runtime/Utils.hs @@ -54,6 +54,7 @@ module Pact.Core.IR.Eval.Runtime.Utils , createEnumerateList , guardForModuleCall , guardTable + , emitPactWarning ) where import Control.Lens hiding (from, to) @@ -84,6 +85,7 @@ import Pact.Core.Persistence import Pact.Core.Environment import Pact.Core.DefPacts.Types import Pact.Core.Gas +import Pact.Core.Info import Pact.Core.Guards import Pact.Core.Capabilities @@ -532,3 +534,10 @@ createEnumerateList info from to inc listSize <- sizeOf info SizeOfV0 (max (abs from) (abs to)) chargeGasArgs info (GMakeList len listSize) pure $ V.enumFromStepN from inc (fromIntegral len) + +emitPactWarning :: i -> PactWarning -> EvalM e b i () +emitPactWarning i pw = + viewEvalEnv eeWarnings >>= \case + Nothing -> pure () + Just warnRef -> + liftIO $ modifyIORef' warnRef (S.insert (Located i pw)) diff --git a/pact/Pact/Core/Info.hs b/pact/Pact/Core/Info.hs index 80c07390e..766499b92 100644 --- a/pact/Pact/Core/Info.hs +++ b/pact/Pact/Core/Info.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} module Pact.Core.Info ( SpanInfo(..) , combineSpan , NoInfo(..) + , Located(..) ) where import Data.Default @@ -42,3 +44,15 @@ instance Pretty SpanInfo where combineSpan :: SpanInfo -> SpanInfo -> SpanInfo combineSpan (SpanInfo l1 c1 _ _) (SpanInfo _ _ l2 c2) = SpanInfo l1 c1 l2 c2 + +data Located i a + = Located + { _locLocation :: i + , _locElem :: a } + deriving (Show, Functor, Foldable, Traversable) + +instance (Eq a) => Eq (Located i a) where + (Located _ a) == (Located _ a') = a == a' + +instance (Ord a) => Ord (Located i a) where + compare (Located _ a) (Located _ a') = compare a a' diff --git a/pact/Pact/Core/Names.hs b/pact/Pact/Core/Names.hs index 17ae8bb7c..7e185766c 100644 --- a/pact/Pact/Core/Names.hs +++ b/pact/Pact/Core/Names.hs @@ -90,9 +90,8 @@ import Data.String (IsString) -- | Newtype wrapper over bare namespaces newtype NamespaceName = NamespaceName { _namespaceName :: Text } - deriving (Eq, Ord, Show, Generic) - -instance NFData NamespaceName + deriving (Generic) + deriving newtype (Eq, Ord, Show, NFData) instance Pretty NamespaceName where pretty (NamespaceName n) = pretty n @@ -113,7 +112,7 @@ instance Pretty ModuleName where newtype BareName = BareName { _bnName :: Text } - deriving (Show, Eq, Ord, NFData) + deriving newtype (Show, Eq, Ord, NFData) instance Pretty BareName where pretty (BareName b) = pretty b @@ -318,7 +317,7 @@ data TypeName newtype NativeName = NativeName { _natName :: Text } - deriving (Show, Eq, NFData) + deriving newtype (Show, Eq, Ord, NFData) makeLenses ''TypeVar makeLenses ''TypeName @@ -376,7 +375,7 @@ renderFullyQualName (FullyQualifiedName mn n mh) = -- | Newtype over text user keys newtype RowKey = RowKey { _rowKey :: Text } - deriving (Eq, Ord, Show, NFData) + deriving newtype (Eq, Ord, Show, NFData) makeLenses ''RowKey @@ -413,7 +412,7 @@ makeLenses ''QualifiedName -- parent + the nested continuation newtype DefPactId = DefPactId { _defPactId :: Text } - deriving (Eq,Ord,Show, NFData) + deriving newtype (Eq,Ord,Show, NFData) instance Pretty DefPactId where pretty (DefPactId p) = pretty p diff --git a/pact/Pact/Core/Repl.hs b/pact/Pact/Core/Repl.hs index ae5d7da87..455fb9aa8 100644 --- a/pact/Pact/Core/Repl.hs +++ b/pact/Pact/Core/Repl.hs @@ -40,10 +40,11 @@ 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) - runReplT ref $ loadFile f interpretEvalDirect logger + ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False logger) + runReplT ref $ loadFile f interpretEvalDirect where defaultSrc = SourceCode "(interactive)" mempty + logger :: Pretty a => a -> EvalM e b i () logger | dolog = liftIO . print . pretty | otherwise = const (pure ()) @@ -53,7 +54,8 @@ runRepl = do pdb <- mockPactDb serialisePact_repl_spaninfo evalLog <- newIORef Nothing ee <- defaultEvalEnv pdb replBuiltinMap - ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False) + let display' rcv = runInputT replSettings (displayOutput rcv) + ref <- newIORef (ReplState mempty ee evalLog defaultSrc mempty mempty Nothing False display') runReplT ref (runInputT replSettings loop) >>= \case Left err -> do putStrLn "Exited repl session with error:" @@ -62,6 +64,7 @@ runRepl = do where replSettings = Settings (replCompletion replCoreBuiltinNames) (Just ".pc-history") True + displayOutput :: (Pretty a, MonadIO m) => a -> InputT m () displayOutput = outputStrLn . show . pretty catch' ma = catchAny ma (\e -> outputStrLn (show e) *> loop) defaultSrc = SourceCode "(interactive)" mempty @@ -88,9 +91,8 @@ runRepl = do outputStrLn $ unwords ["Remove all debug flags"] loop RAExecuteExpr src -> catch' $ do - let display' rcv = runInputT replSettings (displayOutput rcv) lift (replCurrSource .== defaultSrc{_scPayload=src}) - eout <- lift (tryError (interpretReplProgramDirect (SourceCode "(interactive)" src) display')) + eout <- lift (tryError (interpretReplProgramDirect (SourceCode "(interactive)" src))) case eout of Right _ -> pure () Left err -> do diff --git a/pact/Pact/Core/Repl/Compile.hs b/pact/Pact/Core/Repl/Compile.hs index 923c51576..1c79e33eb 100644 --- a/pact/Pact/Core/Repl/Compile.hs +++ b/pact/Pact/Core/Repl/Compile.hs @@ -26,12 +26,14 @@ import Control.Monad.Except import Control.Monad.State.Strict import Data.Text(Text) import Data.Default +import Data.Foldable 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 qualified Data.Set as S import Pact.Core.Persistence import Pact.Core.Persistence.MockPersistence (mockPactDb) @@ -63,6 +65,7 @@ import qualified Pact.Core.Syntax.Parser as Lisp import qualified Pact.Core.IR.Eval.CEK as CEK import qualified Pact.Core.IR.Eval.Direct.Evaluator as Direct import qualified Pact.Core.IR.Eval.Direct.ReplBuiltin as Direct +import Data.IORef (writeIORef, readIORef) type ReplInterpreter = Interpreter ReplRuntime ReplCoreBuiltin SpanInfo @@ -93,24 +96,21 @@ instance Pretty ReplCompileValue where loadFile :: FilePath -> ReplInterpreter - -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -loadFile loc rEnv display = do +loadFile loc rEnv = do source <- SourceCode loc <$> liftIO (T.readFile loc) replCurrSource .== source - interpretReplProgram rEnv source display + interpretReplProgram rEnv source interpretReplProgramBigStep :: SourceCode - -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] interpretReplProgramBigStep = interpretReplProgram interpretEvalBigStep interpretReplProgramDirect :: SourceCode - -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] interpretReplProgramDirect = interpretReplProgram interpretEvalDirect @@ -166,9 +166,8 @@ isPactFile f = takeExtension f == ".pact" interpretReplProgram :: ReplInterpreter -> SourceCode - -> (ReplCompileValue -> ReplM ReplCoreBuiltin ()) -> ReplM ReplCoreBuiltin [ReplCompileValue] -interpretReplProgram interpreter (SourceCode sourceFp source) display = do +interpretReplProgram interpreter (SourceCode sourceFp source) = do lexx <- liftEither (Lisp.lexer source) debugIfFlagSet ReplDebugLexer lexx parsed <- parseSource lexx @@ -184,7 +183,8 @@ interpretReplProgram interpreter (SourceCode sourceFp source) display = do replEvalEnv . eeNatives .== replCoreBuiltinOnlyMap | otherwise = replEvalEnv . eeNatives .== replBuiltinMap - displayValue p = p <$ display p + displayValue p = + p <$ replPrintLn p pipe = \case Lisp.RTL rtl -> pure <$> pipe' rtl @@ -192,7 +192,7 @@ interpretReplProgram interpreter (SourceCode sourceFp source) display = do -- Load is a bit special Lisp.ReplLoad txt reset i -> do let loading = RCompileValue (InterpretValue (PString ("Loading " <> txt <> "...")) i) - display loading + replPrintLn loading oldSrc <- useReplState replCurrSource pactdb <- liftIO (mockPactDb serialisePact_repl_spaninfo) oldEE <- useReplState replEvalEnv @@ -202,7 +202,7 @@ interpretReplProgram interpreter (SourceCode sourceFp source) display = do replEvalEnv .== ee fp <- mangleFilePath (T.unpack txt) when (isPactFile fp) $ esLoaded . loToplevel .= mempty - out <- loadFile fp interpreter display + out <- loadFile fp interpreter replCurrSource .== oldSrc unless reset $ do replEvalEnv .== oldEE @@ -234,10 +234,19 @@ interpretReplProgram interpreter (SourceCode sourceFp source) display = do throwExecutionError varI $ EvalError "repl invariant violated: resolved to a top level free variable without a binder" _ -> do v <- evalTopLevel interpreter ds deps - displayValue (RCompileValue v) + emitWarnings + replPrintLn v + pure (RCompileValue v) _ -> do ds <- runDesugarReplTopLevel tl interpret ds + emitWarnings = + viewEvalEnv eeWarnings >>= \case + Nothing -> pure () + Just ref -> do + warnings <- liftIO (readIORef ref <* writeIORef ref mempty) + -- Todo: print located line + traverse_ (replPrintLn . _locElem) (S.toList warnings) interpret (DesugarOutput tl _deps) = do case tl of RTLDefun df -> do @@ -247,6 +256,7 @@ interpretReplProgram interpreter (SourceCode sourceFp source) display = do RTLDefConst dc -> case _dcTerm dc of TermConst term -> do pv <- eval interpreter PSysOnly term + emitWarnings maybeTCType (_dcInfo dc) (_argType $ _dcSpec dc) pv let dc' = set dcTerm (EvaledConst pv) dc let fqn = FullyQualifiedName replModuleName (_argName $ _dcSpec dc) replModuleHash diff --git a/pact/Pact/Core/Repl/Utils.hs b/pact/Pact/Core/Repl/Utils.hs index cc8562ff6..bc8a13b69 100644 --- a/pact/Pact/Core/Repl/Utils.hs +++ b/pact/Pact/Core/Repl/Utils.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} module Pact.Core.Repl.Utils @@ -38,6 +39,7 @@ module Pact.Core.Repl.Utils , (.==) , (%==) , gasLogEntrytoPactValue + , replPrintLn ) where import Control.Lens @@ -146,6 +148,12 @@ replFlagSet replFlagSet flag = usesReplState replFlags (Set.member flag) +getReplState :: ReplM b (ReplState b) +getReplState = do + r <- ask + let (ReplEnv ref) = r + liftIO $ readIORef ref + useReplState :: Lens' (ReplState b) s -> ReplM b s useReplState l = do r <- ask @@ -250,3 +258,8 @@ gasLogEntrytoPactValue :: GasLogEntry (ReplBuiltin CoreBuiltin) SpanInfo -> Pact 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 p = do + r <- getReplState + _replOutputLine r p diff --git a/profile-tx/ProfileTx.hs b/profile-tx/ProfileTx.hs index 53a79adf2..183e4237a 100644 --- a/profile-tx/ProfileTx.hs +++ b/profile-tx/ProfileTx.hs @@ -176,6 +176,7 @@ setupBenchEvalEnv pdb signers mBody = do , _eeNamespacePolicy = SimpleNamespacePolicy , _eeGasEnv = gasEnv , _eeSPVSupport = noSPVSupport + , _eeWarnings = Nothing }