Core: ADT-ize all errors

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/StaticErrorTests.hs

@@ -32,6 +32,9 @@ isDesugarError p s = isJust $ preview (_PEDesugarError . _1 . p) s
 isExecutionError :: Prism' EvalError a -> PactErrorI -> Bool
 isExecutionError p s = isJust $ preview (_PEExecutionError . _1 . p) s
 
+isUserRecoverableError :: Prism' UserRecoverableError a -> PactErrorI -> Bool
+isUserRecoverableError p s = isJust $ preview (_PEUserRecoverableError . _1 . p) s
+
 runStaticTest :: String -> Text -> (PactErrorI -> Bool) -> Assertion
 runStaticTest label src predicate = do
   gasLog <- newIORef Nothing
@@ -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)

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/Capabilities.hs

@@ -163,6 +163,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) =
+    parens (pretty qn <> if null args then mempty else hsep (pretty <$> 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
@@ -79,3 +80,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) =
+    parens (pretty n <+> if null v then mempty else space <> hsep (pretty <$> v))

pact/Pact/Core/Environment/Utils.hs

@@ -20,14 +20,15 @@ module Pact.Core.Environment.Utils
  , lookupModule
  , lookupModuleData
  , throwExecutionError
- , throwExecutionError'
- , throwRecoverableError
  , toFqDep
  , mangleNamespace
  , getAllStackCaps
  , checkSigCaps
  , allModuleExports
  , liftDbFunction
+ , throwUserRecoverableError
+ , throwUserRecoverableError'
+ , throwNativeExecutionError
  ) where
 
 import Control.Lens
@@ -36,7 +37,6 @@ import Control.Monad.Except
 import Control.Exception
 import Control.Monad.IO.Class(MonadIO(..))
 import Data.Text(Text)
-import Data.Default
 import Data.Maybe(mapMaybe)
 import qualified Data.Map.Strict as M
 import qualified Data.Set as S
@@ -51,6 +51,7 @@ import Pact.Core.Namespace
 import Pact.Core.Guards
 import Pact.Core.Capabilities
 import Pact.Core.PactValue
+import Pact.Core.Builtin
 
 viewEvalEnv :: (MonadEvalEnv b i m) => Lens' (EvalEnv b i) s -> m s
 viewEvalEnv l = view l <$> readEnv
@@ -100,16 +101,22 @@ liftDbFunction info action = do
     Left dbopErr -> throwExecutionError info (DbOpFailure dbopErr)
     Right e -> pure e
 
+throwUserRecoverableError :: (MonadError (PactError info) m, MonadEvalState b info m) => info -> UserRecoverableError -> m a
+throwUserRecoverableError i err = do
+  st <- useEvalState esStack
+  throwError (PEUserRecoverableError err st i)
+
+throwUserRecoverableError' :: MonadError (PactError info) m => info -> [StackFrame info] -> UserRecoverableError -> m a
+throwUserRecoverableError' info stack err = throwError (PEUserRecoverableError err stack info)
+
 throwExecutionError :: (MonadEvalState b i m, MonadError (PactError i) m) => i -> EvalError -> m a
 throwExecutionError i e = do
   st <- useEvalState esStack
   throwError (PEExecutionError e st i)
 
-throwRecoverableError :: MonadEval b i m => i -> Text -> m a
-throwRecoverableError i e = throwError (PERecoverableError (RecoverableError e) i)
-
-throwExecutionError' :: (MonadEvalState b i m, MonadError (PactError i) m, Default i) => EvalError -> m a
-throwExecutionError' = throwExecutionError def
+throwNativeExecutionError :: (MonadEvalState b i m, MonadError (PactError i) m, IsBuiltin b) => i -> b -> Text -> m a
+throwNativeExecutionError info b msg =
+  throwExecutionError info (NativeExecutionError (builtinName b) msg)
 
 -- | lookupModuleData for only modules
 lookupModule :: (MonadEval b i m) => i -> PactDb b i -> ModuleName -> m (Maybe (EvalModule b i))
@@ -170,7 +177,7 @@ getModuleMember info pdb (QualifiedName qn mn) = do
     Just d -> pure d
     Nothing -> do
       let fqn = FullyQualifiedName mn qn (_mHash md)
-      throwExecutionError info (NameNotInScope fqn)
+      throwExecutionError info (ModuleMemberDoesNotExist fqn)
 
 getModuleMemberWithHash :: (MonadEval b i m) => i -> PactDb b i -> QualifiedName -> m (EvalDef b i, ModuleHash)
 getModuleMemberWithHash info pdb (QualifiedName qn mn) = do
@@ -179,7 +186,7 @@ getModuleMemberWithHash info pdb (QualifiedName qn mn) = do
     Just d -> pure (d, _mHash md)
     Nothing -> do
       let fqn = FullyQualifiedName mn qn (_mHash md)
-      throwExecutionError info (NameNotInScope fqn)
+      throwExecutionError info (ModuleMemberDoesNotExist fqn)
 
 
 mangleNamespace :: (MonadEvalState b i m) => ModuleName -> m ModuleName