Core: ADT-ize all errors

crypto/Pact/Core/Crypto/Pairing.hs

@@ -402,7 +402,6 @@ data CurvePoint a
   | CurveInf
   deriving (Eq, Show)
 
--- todo: sort of scuffed, num instance?
 double :: (Field a, Num a, Eq a) => CurvePoint a -> CurvePoint a
 double CurveInf = CurveInf
 double (Point x y)

gasmodel/Pact/Core/GasModel/InterpreterGas.hs

@@ -370,7 +370,7 @@ gasMtWithHandlerError pdb =
     let es = defaultGasEvalState
         ps = _eeDefPactStep ee
         frame = Mt
-        value = VError "foo" ()
+        value = VError [] (UserEnforceError "foo") ()
         env = CEKEnv { _cePactDb=pdb
                     , _ceLocal=mempty
                     , _ceInCap=False

pact-lsp/Pact/Core/LanguageServer.hs

@@ -254,7 +254,7 @@ sendDiagnostics nuri mv content = liftIO runPact >>= \case
       PEParseError{} -> "Parse"
       PEDesugarError{} -> "Desugar"
       PEExecutionError{} -> "Execution"
-      PERecoverableError{} -> "Execution"
+      PEUserRecoverableError{} -> "Execution"
 
 spanInfoToRange :: SpanInfo -> Range
 spanInfoToRange (SpanInfo sl sc el ec) = mkRange

pact-tests/Pact/Core/Test/GasGolden.hs

@@ -38,7 +38,7 @@ tests = do
   cases <- gasTestFiles
   pure $ testGroup "Gas Goldens"
     [ testCase "Capture all builtins" $ captureBuiltins (fst <$> cases)
-    , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir </> "builtinGas.golden") (gasGoldenTests cases interpretReplProgram)
+    , goldenVsStringDiff "Gas Goldens: CEK" runDiff (gasTestDir </> "builtinGas.golden") (gasGoldenTests cases interpretReplProgramBigStep)
     , goldenVsStringDiff "Gas Goldens: CEK smallstep" runDiff (gasTestDir </> "builtinGas.golden") (gasGoldenTests cases interpretReplProgramSmallStep)
     , goldenVsStringDiff "Gas Goldens: Direct" runDiff (gasTestDir </> "builtinGas.golden") (gasGoldenTests cases interpretReplProgramDirect)
     ]

pact-tests/Pact/Core/Test/LegacySerialiseTests.hs

@@ -62,7 +62,7 @@ legacyTests = do
       Nothing -> error "Reading existing modules failed"
       Just ms -> do
         modTests <- fmap concat $ forM repl $ \r -> do
-          sequence [runTest r interpretReplProgram "CEK", runTest r interpretReplProgramDirect "Direct"]
+          sequence [runTest r interpretReplProgramBigStep "CEK", runTest r interpretReplProgramDirect "Direct"]
         pure (testGroup p modTests)
         where
         runTest r interpreter interpName = do

pact-tests/Pact/Core/Test/PersistenceTests.hs

@@ -234,7 +234,7 @@ sqliteRegression =
         evalLog <- newIORef Nothing
         ee <- defaultEvalEnv pdb replCoreBuiltinMap
         ref <- newIORef (ReplState mempty pdb def ee evalLog (SourceCode "" "") mempty mempty Nothing False)
-        Right _ <- runReplT ref (interpretReplProgram (SourceCode "test" src) (const (pure ())))
+        Right _ <- runReplT ref (interpretReplProgramBigStep (SourceCode "test" src) (const (pure ())))
         Just md <- readModule pdb (ModuleName "test" Nothing)
         pure md
 

pact-tests/Pact/Core/Test/ReplTests.hs

@@ -41,8 +41,8 @@ tests :: IO TestTree
 tests = do
   files <- replTestFiles
   pure $ testGroup "ReplTests"
-    [ testGroup "in-memory db:bigstep" (runFileReplTest interpretReplProgram <$> files)
-    , testGroup "sqlite db:bigstep" (runFileReplTestSqlite interpretReplProgram <$> files)
+    [ testGroup "in-memory db:bigstep" (runFileReplTest interpretReplProgramBigStep <$> files)
+    , testGroup "sqlite db:bigstep" (runFileReplTestSqlite interpretReplProgramBigStep <$> files)
     , testGroup "in-memory db:smallstep" (runFileReplTest interpretReplProgramSmallStep <$> files)
     , testGroup "sqlite db:smallstep" (runFileReplTestSqlite interpretReplProgramSmallStep <$> files)
     , testGroup "in-memory db:direct" (runFileReplTest interpretReplProgramDirect <$> files)

pact-tests/Pact/Core/Test/StaticErrorTests.hs

@@ -24,16 +24,19 @@ import Pact.Core.Serialise (serialisePact_repl_spaninfo)
 import Pact.Core.Test.TestPrisms
 
 isParseError :: Prism' ParseError a -> PactErrorI -> Bool
-isParseError p s = isJust $ preview (_PEParseError . _1 . p) s
+isParseError p s = has (_PEParseError . _1 . p) s
 
 isDesugarError :: Prism' DesugarError a -> PactErrorI -> Bool
-isDesugarError p s = isJust $ preview (_PEDesugarError . _1 . p) s
+isDesugarError p s = has (_PEDesugarError . _1 . p) s
 
 isExecutionError :: Prism' EvalError a -> PactErrorI -> Bool
-isExecutionError p s = isJust $ preview (_PEExecutionError . _1 . p) s
+isExecutionError p s = has (_PEExecutionError . _1 . p) s
 
-runStaticTest :: String -> Text -> (PactErrorI -> Bool) -> Assertion
-runStaticTest label src predicate = do
+isUserRecoverableError :: Prism' UserRecoverableError a -> PactErrorI -> Bool
+isUserRecoverableError p s = has (_PEUserRecoverableError . _1 . p) s
+
+runStaticTest :: String -> Text -> ReplInterpreter -> (PactErrorI -> Bool) -> Assertion
+runStaticTest label src interp predicate = do
   gasLog <- newIORef Nothing
   pdb <- mockPactDb serialisePact_repl_spaninfo
   ee <- defaultEvalEnv pdb replCoreBuiltinMap
@@ -51,7 +54,7 @@ runStaticTest label src predicate = do
             , _replNativesEnabled = True
             }
   stateRef <- newIORef rstate
-  v <- runReplT stateRef (interpretReplProgram source (const (pure ())))
+  v <- runReplT stateRef (interpretReplProgram interp source (const (pure ())))
   case v of
     Left err ->
       assertBool ("Expected Error to match predicate, but got " <> show err <> " instead") (predicate err)
@@ -573,7 +576,7 @@ executionTests =
         (defun foo:string ())
         )
     |])
-  , ("enforce_ns_define_namespace", isExecutionError _DefineNamespaceError, [text|
+  , ("enforce_ns_define_namespace", isExecutionError _NativeExecutionError, [text|
       (module m g (defcap g () true)
         (defun manage (ns guard) false)
         )
@@ -627,7 +630,7 @@ executionTests =
   , ("get_module_unknown", isExecutionError _ModuleDoesNotExist, [text|
       (describe-module 'nonexistent)
       |])
-  , ("reexposed_module_missing_name", isExecutionError _NameNotInScope, [text|
+  , ("reexposed_module_missing_name", isExecutionError _ModuleMemberDoesNotExist, [text|
       (module m g
         (defcap g () true)
 
@@ -650,15 +653,15 @@ executionTests =
   , ("module_gov_keyset_nonexistent", isExecutionError _NoSuchKeySet, [text|
       (module m 'nonexistent (defun f () true))
       |])
-  , ("module_gov_keyset_different", isExecutionError _EvalError, [text|
+  , ("module_gov_keyset_different", isUserRecoverableError _KeysetPredicateFailure, [text|
       (env-data {"ks":["jose"]})
       (define-keyset 'somekeyset (read-keyset 'ks))
       (module m 'somekeyset (defun f () 1))
       |])
-  , ("module_gov_keyset_empty", isExecutionError _ModuleGovernanceFailure, [text|
+  , ("module_gov_keyset_empty", isExecutionError _InvalidKeysetNameFormat, [text|
       (module m "" (defun f () true))
       |])
-  , ("module_gov_keyset_not_in_sigs", isExecutionError _EvalError, [text|
+  , ("module_gov_keyset_not_in_sigs", isUserRecoverableError _KeysetPredicateFailure, [text|
       (env-data { "kall": ["a" "b" "c"], "kadmin": ["admin"] })
       (define-keyset 'kall)
       (define-keyset 'kadmin)
@@ -678,7 +681,7 @@ executionTests =
       |])
 
   -- CEK errors
-  , ("modref_no_ns", isExecutionError _ModRefNotRefined, [text|
+  , ("modref_no_ns", isExecutionError _ModRefImplementsNoInterfaces, [text|
       (module m g (defcap g () true))
       m
       |])
@@ -1080,8 +1083,8 @@ builtinTests =
   , ("at_oob_bound", isExecutionError _ArrayOutOfBoundsException, "(at 3 [1 2 3])")
   , ("at_oob_smaller", isExecutionError _ArrayOutOfBoundsException, "(at -1 [1 2 3])")
   , ("at_oob_empty", isExecutionError _ArrayOutOfBoundsException, "(at 0 [])")
-  , ("at_key_missing", isExecutionError _EvalError, "(at 'bar { 'foo: 1 })")
-  , ("yield_outside", isExecutionError _YieldOutsiteDefPact, "(yield {})")
+  , ("at_key_missing", isExecutionError _ObjectIsMissingField, "(at 'bar { 'foo: 1 })")
+  , ("yield_outside", isExecutionError _YieldOutsideDefPact, "(yield {})")
   , ("resume_no_defpact", isExecutionError _NoActiveDefPactExec, "(resume { 'field := binder } binder)")
   , ("resume_no_yield", isExecutionError _NoYieldInDefPactStep, [text|
       (module m g (defcap g () true)
@@ -1203,6 +1206,10 @@ builtinTests =
 
 tests :: TestTree
 tests =
-  testGroup "CoreStaticTests" (go <$> parseTests <> desugarTests <> executionTests <> builtinTests)
+  testGroup "CoreStaticTests"
+    [ testGroup "CoreStaticTests:CEK" (go interpretEvalBigStep <$> allTests)
+    , testGroup "CoreStaticTests:Direct" (go interpretEvalDirect <$> allTests)
+    ]
   where
-  go (label, p, srcText) = testCase label $ runStaticTest label srcText p
+  allTests = parseTests <> desugarTests <> executionTests <> builtinTests
+  go interp (label, p, srcText) = testCase label $ runStaticTest label srcText interp p

pact-tests/Pact/Core/Test/TestPrisms.hs

@@ -10,4 +10,5 @@ makePrisms ''LexerError
 makePrisms ''ParseError
 makePrisms ''DesugarError
 makePrisms ''EvalError
+makePrisms ''UserRecoverableError
 makePrisms ''PactError

pact-tests/legacy-serial-tests/coin-v5/coin-v5.repl

@@ -421,7 +421,7 @@
   (transfer 'emily 'doug 1.0))
 
 (expect-failure "No account for will"
-  "no such read object"
+  "No value found in table coin:coin-table for key: will"
   (get-balance 'will))
 
 (test-capability (TRANSFER 'doug 'will 1.0))
@@ -485,7 +485,7 @@
 (env-data { "miner2": ["miner2"] })
 
 (expect-failure "no account for miner2"
-  "no such read object"
+  "No value found in table coin:coin-table for key: miner2"
   (get-balance 'miner2))
 
 (test-capability (COINBASE))

pact-tests/pact-tests/caps.repl

@@ -814,7 +814,7 @@
 
 (expect-failure
  "cap guard fails on wrong cap"
- "Capability guard enforce failure cap not in scope"
+ "Capability not acquired"
  (test-cap-guard "A" "B"))
 
 (env-hash (hash 1))
@@ -831,7 +831,7 @@
 (cg-pact 'k2 'k2 "D" "E")
 (expect-failure
  "cap pact guard fails on wrong cap"
- "Capability guard enforce failure cap not in scope"
+ "Capability not acquired"
  (continue-pact 1))
 
 (pact-state true)
@@ -914,7 +914,7 @@
 
 (expect-failure
   "out-of-band call fails"
-  "Capability guard enforce failure cap not in scope"
+  "Capability not acquired"
   (call-op1 "hello" 2))
 (expect
    "normal case succeeds for both callees post-fork"

pact-tests/pact-tests/coin-v1.repl

@@ -422,7 +422,7 @@
   (transfer 'emily 'doug 1.0))
 
 (expect-failure "No account for will"
-  "no such read object"
+  "No value found in table coin:coin-table for key: will"
   (get-balance 'will))
 
 (test-capability (TRANSFER 'doug 'will 1.0))
@@ -484,7 +484,7 @@
 (env-data { "miner2": ["miner2"] })
 
 (expect-failure "no account for miner2"
-  "no such read object"
+  "No value found in table coin:coin-table for key: miner2"
   (get-balance 'miner2))
 
 (coinbase 'miner2 (read-keyset 'miner2) 1.0)

pact-tests/pact-tests/coin-v5.repl

@@ -435,7 +435,7 @@
   (transfer 'emily 'doug 1.0))
 
 (expect-failure "No account for will"
-  "no such read object"
+  "No value found in table coin:coin-table for key: will"
   (get-balance 'will))
 
 (test-capability (TRANSFER 'doug 'will 1.0))
@@ -499,7 +499,7 @@
 (env-data { "miner2": ["miner2"] })
 
 (expect-failure "no account for miner2"
-  "no such read object"
+  "No value found in table coin:coin-table for key: miner2"
   (get-balance 'miner2))
 
 (test-capability (COINBASE))

pact/Pact/Core/Builtin.hs

@@ -19,7 +19,7 @@ module Pact.Core.Builtin
  , IsBuiltin(..)
  , ReplCoreBuiltin
  , BuiltinForm(..)
- , ReplBuiltins(..)
+ , ReplOnlyBuiltin(..)
  )where
 
 import Data.Text(Text)
@@ -697,9 +697,8 @@ coreBuiltinMap = M.fromList
   | b <- [minBound .. maxBound]
   , b `notElem` coreBuiltinOverloads]
 
--- Todo: rename
 -- | Our repl builtins.
-data ReplBuiltins
+data ReplOnlyBuiltin
   = RExpect
   | RExpectFailure
   | RExpectFailureMatch
@@ -747,7 +746,7 @@ data ReplBuiltins
   deriving (Show, Enum, Bounded, Eq, Generic)
 
 
-instance IsBuiltin ReplBuiltins where
+instance IsBuiltin ReplOnlyBuiltin where
   builtinName = NativeName . replBuiltinsToText
   builtinArity = \case
     RExpect -> 3
@@ -798,7 +797,7 @@ instance IsBuiltin ReplBuiltins where
 -- to be implemented later
 data ReplBuiltin b
   = RBuiltinWrap b
-  | RBuiltinRepl ReplBuiltins
+  | RBuiltinRepl ReplOnlyBuiltin
   deriving (Eq, Show, Generic)
 
 -- NOTE: Maybe `ReplBuiltin` is not a great abstraction, given
@@ -830,7 +829,7 @@ instance (Enum b, Bounded b) => Enum (ReplBuiltin b) where
       RBuiltinRepl rb -> maxContained + fromEnum rb
   {-# SPECIALIZE fromEnum :: ReplBuiltin CoreBuiltin -> Int #-}
 
-replBuiltinsToText :: ReplBuiltins -> Text
+replBuiltinsToText :: ReplOnlyBuiltin -> Text
 replBuiltinsToText = \case
   RExpect -> "expect"
   RExpectFailure -> "expect-failure"
@@ -904,8 +903,10 @@ replCoreBuiltinMap =
     , let !txtRepr = replCoreBuiltinToText b]
 
 
--- Todo: is not a great abstraction.
--- In particular: the arity could be gathered from the type.
+-- | A typeclass for general information about pact builtins, mostly
+--   useful for runtime native information and for error messages. Note that
+--   builtinArity only has 1 value per builtin, meaning overload resolution must
+--   happen before using `builtinArity` to check for app saturation.
 class Show b => IsBuiltin b where
   builtinArity :: b -> Int
   builtinName :: b -> NativeName

pact/Pact/Core/Capabilities.hs

@@ -107,8 +107,10 @@ data CapState name v
 instance (Ord name, Ord v) => Default (CapState name v) where
   def = CapState mempty mempty mempty mempty mempty
 
--- Todo: Is there a reason why module + name is
--- an unqualified
+-- | Our pact event type.
+--   Note: the name + module are isomorphic to a
+--   QualifiedName, but it is kept in this format currently for
+--   ease of legacy integration
 data PactEvent v
   = PactEvent
   { _peName :: Text
@@ -163,6 +165,9 @@ data Signer name v = Signer
  -- ^ clist for designating signature to specific caps
  } deriving (Eq, Ord, Show, Generic)
 
+instance (Pretty name, Pretty v) => Pretty (CapToken name v) where
+  pretty (CapToken qn args) =
+    pretty $ PrettyLispApp qn args
 
 instance (NFData name, NFData v) => NFData (Signer name v)
 instance (NFData name, NFData e) => NFData (CapForm name e)

pact/Pact/Core/Compile.hs

@@ -89,7 +89,6 @@ enforceNamespaceInstall info interpreter =
   useEvalState (esLoaded . loNamespace) >>= \case
     Just ns ->
       void $ interpretGuard interpreter info (_nsUser ns)
-      -- Eval.interpretGuard info bEnv (_nsUser ns)
     Nothing ->
       enforceRootNamespacePolicy
     where

pact/Pact/Core/DefPacts/Types.hs

@@ -23,6 +23,7 @@ import Pact.Core.PactValue
 import Pact.Core.Names
 import Pact.Core.Hash
 import Pact.Core.ChainData
+import Pact.Core.Pretty
 
 data DefPactContinuation name v
   = DefPactContinuation
@@ -42,6 +43,10 @@ data Provenance = Provenance
     -- ^ a hash of current containing module
   } deriving (Eq, Show, Generic)
 
+instance Pretty Provenance where
+  pretty (Provenance (ChainId cid) mh) =
+    parens $
+      "Provenance" <+> pretty cid <+> pretty mh
 
 -- | `Yield` representing an object
 data Yield
@@ -79,3 +84,7 @@ instance NFData Yield
 instance NFData DefPactStep
 instance (NFData name, NFData v) => NFData (DefPactContinuation name v)
 instance NFData DefPactExec
+
+instance (Pretty name, Pretty v) => Pretty (DefPactContinuation name v) where
+  pretty (DefPactContinuation n v) =
+    pretty $ PrettyLispApp n v