Add warnings to repl, improve repl printing api

gasmodel/Pact/Core/GasModel/ContractBench.hs

@@ -179,6 +179,7 @@ setupBenchEvalEnv pdb signers mBody = do
     , _eeNamespacePolicy = SimpleNamespacePolicy
     , _eeGasEnv = gasEnv
     , _eeSPVSupport = noSPVSupport
+    , _eeWarnings = Nothing
     }
 
 

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)

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

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)

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)

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

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

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

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

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

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

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))

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'

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