Added some tx and tx-plugin errors

plutus-core/src/Language/PlutusCore/Evaluation/Machine/Exception.hs

@@ -251,7 +251,7 @@ instance ErrorCode (Language.PlutusCore.Evaluation.Machine.Exception.ConstAppErr
         = 28
       errorCode (UnliftingConstAppError e) = errorCode e
 
-instance ErrorCode err => ErrorCode (Language.PlutusCore.Evaluation.Machine.Exception.MachineError err _a1_acYT) where
+instance ErrorCode (Language.PlutusCore.Evaluation.Machine.Exception.MachineError err _a1_acYT) where
       errorCode
         Language.PlutusCore.Evaluation.Machine.Exception.EmptyBuiltinArityMachineError {}
         = 34
@@ -277,10 +277,11 @@ instance ErrorCode err => ErrorCode (Language.PlutusCore.Evaluation.Machine.Exce
         (Language.PlutusCore.Evaluation.Machine.Exception.ConstAppMachineError e)
         = errorCode e
       errorCode
-        (Language.PlutusCore.Evaluation.Machine.Exception.OtherMachineError e)
-        = errorCode e
+        (Language.PlutusCore.Evaluation.Machine.Exception.OtherMachineError _)
+        -- clone of: https://github.com/input-output-hk/plutus/blob/7dda61b854d44b3d23407446b4b3acedef4a4c1b/plutus-core/src/Language/PlutusCore/Error.hs#L243-L244
+        = 17 -- FIXME: use `errorCode e` once we transition to error-groups instead of open error-datatypes
 
-instance (ErrorCode other, ErrorCode user) => ErrorCode (EvaluationError other user t_) where
+instance (ErrorCode user) => ErrorCode (EvaluationError other user t_) where
   errorCode (InternalEvaluationError e) = errorCode e
   errorCode (UserEvaluationError e) = errorCode e
 

plutus-errors/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Codes
+
+main =  putStrLn $ "An error code that is not currently used is:"
+                 ++ show (maximum codes + 1)

plutus-errors/src/Errors.hs

@@ -27,60 +27,65 @@ data DeprecatedErrors =
     -- append here your deprecated errors
 
 instance ErrorCode DeprecatedErrors where
-    errorCode ReservedErrorCode = 0
+    errorCode ReservedErrorCode {} = 0
 
 errors :: [Name]
 errors =
    [ 'PIR.MalformedDataConstrResType
-   -- , 'PIR.CompilationError
-   -- , 'PIR.UnsupportedError
-   -- , 'PIR.UnexpectedKeyword
-   --  , 'PIR.InternalError
-   --  , 'PLC.LexErr
-   --  , 'PLC.Unexpected
-   --  , 'PLC.UnknownBuiltinType
-   --  , 'PLC.UnknownBuiltinFunction
-   --  , 'PLC.InvalidBuiltinConstant
-   --  , 'PLC.MultiplyDefined
-   --  , 'PLC.IncoherentUsage
-   --  , 'PLC.BadType
-   --  , 'PLC.BadTerm
+   , 'PIR.CompilationError
+   , 'PIR.UnsupportedError
+   , 'PIR.UnexpectedKeyword
+    , 'PIR.InternalError
+    , 'PLC.LexErr
+    , 'PLC.Unexpected
+    , 'PLC.UnknownBuiltinType
+    , 'PLC.UnknownBuiltinFunction
+    , 'PLC.InvalidBuiltinConstant
+    , 'PLC.MultiplyDefined
+    , 'PLC.IncoherentUsage
+    , 'PLC.BadType
+    , 'PLC.BadTerm
     , 'PLC.KindMismatch
     , 'PLC.TypeMismatch
-    -- , 'PLC.UnknownDynamicBuiltinNameErrorE
-    -- , 'PLC.OpenTypeOfBuiltin
-    -- , 'PLC.FreeTypeVariableE
-    -- , 'PLC.FreeVariableE
-    -- , 'PLC.FreeVariable
-    -- , 'PLC.FreeUnique
-    -- , 'PLC.FreeIndex
-    -- , 'PLC.NonPolymorphicInstantiationMachineError
-    -- , 'PLC.NonWrapUnwrappedMachineError
-    -- , 'PLC.NonFunctionalApplicationMachineError
-    -- , 'PLC.OpenTermEvaluatedMachineError
-    -- , 'PLC.TooFewArgumentsConstAppError
-    -- , 'PLC.TooManyArgumentsConstAppError
-    -- , 'PLC.UnliftingErrorE
-    -- , 'PLC.ConstAppMachineError
-    -- , 'PLC.BuiltinTermArgumentExpectedMachineError
-    -- , 'PLC.UnexpectedBuiltinTermArgumentMachineError
-    -- , 'PLC.EmptyBuiltinArityMachineError
-    -- , 'PLC.OtherMachineError
-    -- , 'PLC.CekOutOfExError
-    -- , 'PLC.CekEvaluationFailure
-    -- , 'PLCU.CekOutOfExError
-    -- , 'PLCU.CekEvaluationFailure
-    -- , 'PTX.ImpossibleDeserialisationFailure
+    , 'PLC.UnknownDynamicBuiltinNameErrorE
+    , 'PLC.OpenTypeOfBuiltin
+    , 'PLC.FreeTypeVariableE
+    , 'PLC.FreeVariableE
+    , 'PLC.FreeVariable
+    , 'PLC.FreeUnique
+    , 'PLC.FreeIndex
+    , 'PLC.NonPolymorphicInstantiationMachineError
+    , 'PLC.NonWrapUnwrappedMachineError
+    , 'PLC.NonFunctionalApplicationMachineError
+    , 'PLC.OpenTermEvaluatedMachineError
+    , 'PLC.TooFewArgumentsConstAppError
+    , 'PLC.TooManyArgumentsConstAppError
+    , 'PLC.UnliftingErrorE
+    , 'PLC.BuiltinTermArgumentExpectedMachineError
+    , 'PLC.UnexpectedBuiltinTermArgumentMachineError
+    , 'PLC.EmptyBuiltinArityMachineError
+    , 'PLC.CekOutOfExError
+    , 'PLC.CekEvaluationFailure
+    , 'PLCU.CekOutOfExError
+    , 'PLCU.CekEvaluationFailure
+    , 'PTX.ImpossibleDeserialisationFailure
     -- -- Language.PlutusTx.Lift.Class,Prelude.error $ "Unknown local variable: " ++ show name
     -- -- Language.PlutusTx.Lift.Class,Prelude.error $ "Constructors not created for " ++ show tyName
     -- -- Language.PlutusTx.Lift.Class,dieTH "Newtypes must have a single constructor with a single argument"
     -- -- Language.PlutusTx.Lift.Class,dieTH "Newtypes must have a single constructor with a single argument"
     -- -- Language.PlutusTx.Lift.Class,dieTH $ "Unsupported kind: " ++ show k
     -- -- Language.PlutusTx.Lift.Class,dieTH $ "Unsupported type: " ++ show t
     -- -- Language.PlutusTx.Utils,mustbeReplaced,GHC.Exception.ErrorCall -- for "plutustx" user-error-builtin run by ghc
-    -- , 'PTX.CompilationError
-    -- , 'PTX.UnsupportedError
-    -- , 'PTX.FreeVariableError
+    , 'PTX.CompilationError
+    , 'PTX.UnsupportedError
+    , 'PTX.FreeVariableError
+    , 'PTX.UnsupportedLiftType
+    , 'PTX.UnsupportedLiftKind
+    , 'PTX.UserLiftError
+    , 'PTX.LiftMissingDataCons
+    , 'PTX.LiftMissingVar
     -- -- Language.PlutusTx.Plugin,failCompilation $ "Unable to get Core name needed for the plugin to function: " ++ show name
-    -- , 'ReservedErrorCode
+    , 'ReservedErrorCode
+    --, 'PLC.OtherMachineError -- we don't need this one, it is a wrapper
+    -- , 'PLC.ConstAppMachineError -- we don't need this one, it is a wrapper
     ]

plutus-tx/src/Language/PlutusTx/Lift/Class.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DefaultSignatures     #-}
 {-# LANGUAGE FlexibleContexts      #-}
@@ -10,7 +12,15 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE ViewPatterns          #-}
-module Language.PlutusTx.Lift.Class (Typeable (..),  Lift (..), RTCompile, makeTypeable, makeLift, withTyVars)where
+module Language.PlutusTx.Lift.Class
+    ( Typeable (..)
+    , Lift (..)
+    , RTCompile
+    , makeTypeable
+    , makeLift
+    , withTyVars
+    , LiftError (..)
+    ) where
 
 import           Language.PlutusTx.Lift.THUtils
 
@@ -25,6 +35,7 @@ import qualified Language.PlutusCore.Universe           as PLC
 
 import           Control.Monad.Reader                   hiding (lift)
 import           Control.Monad.State                    hiding (lift)
+import Control.Monad.Except hiding (lift)
 import qualified Control.Monad.Trans                    as Trans
 
 import qualified Language.Haskell.TH                    as TH
@@ -40,6 +51,10 @@ import           Data.Maybe
 import           Data.Proxy
 import qualified Data.Text                              as T
 import           Data.Traversable
+import qualified Data.Text.Prettyprint.Doc              as PP
+import PlutusError
+import qualified Control.Exception as Prelude (throw, Exception)
+import qualified Data.Typeable as Prelude
 
 -- Apparently this is how you're supposed to fail at TH time.
 dieTH :: MonadFail m => String -> m a
@@ -74,7 +89,33 @@ inline all the definitions so that the overall expression can have the right con
 
 type RTCompile uni = DefT TH.Name uni () Quote
 type RTCompileScope uni = ReaderT (LocalVars uni) (RTCompile uni)
-type THCompile = StateT Deps (ReaderT THLocalVars TH.Q)
+type THCompile = StateT Deps (ReaderT THLocalVars (ExceptT LiftError TH.Q))
+
+data LiftError = UnsupportedLiftKind TH.Kind
+               | UnsupportedLiftType TH.Type
+               | UserLiftError T.Text
+               | LiftMissingDataCons TH.Name
+               | LiftMissingVar TH.Name
+               deriving stock Prelude.Typeable -- for Control.Exception
+
+instance Prelude.Exception LiftError
+
+instance PP.Pretty LiftError where
+    pretty (UnsupportedLiftType t) = "Unsupported lift type: " PP.<+> PP.viaShow t
+    pretty (UnsupportedLiftKind t) = "Unsupported lift kind: " PP.<+> PP.viaShow t
+    pretty (UserLiftError t) = PP.pretty t
+    pretty (LiftMissingDataCons n) = "Constructors not created for type: " PP.<+> PP.viaShow n
+    pretty (LiftMissingVar n) = "Unknown local variable: " PP.<+> PP.viaShow n
+
+instance Show LiftError where
+    show = show . PP.pretty -- for Control.Exception
+
+instance ErrorCode LiftError where
+    errorCode UnsupportedLiftType {} = 44
+    errorCode UnsupportedLiftKind {} = 45
+    errorCode UserLiftError {} = 46
+    errorCode LiftMissingDataCons {} = 47
+    errorCode LiftMissingVar {} = 48
 
 {- Note [Type variables]
 We handle types in almost exactly the same way when we are constructing Typeable
@@ -177,7 +218,7 @@ isClosedConstraint = null . TH.freeVariables
 
 -- | Convenience wrapper around 'normalizeType' and 'TH.resolveTypeSynonyms'.
 normalizeAndResolve :: TH.Type -> THCompile TH.Type
-normalizeAndResolve ty = normalizeType <$> (Trans.lift $ Trans.lift $ TH.resolveTypeSynonyms ty)
+normalizeAndResolve ty = normalizeType <$> (Trans.lift $ Trans.lift $ Trans.lift $ TH.resolveTypeSynonyms ty)
 
 -- See Note [Ordering of constructors]
 sortedCons :: TH.DatatypeInfo -> [TH.ConstructorInfo]
@@ -203,7 +244,7 @@ compileKind :: TH.Kind -> THCompile (Kind ())
 compileKind = \case
     TH.StarT -> pure $ Type ()
     TH.AppT (TH.AppT TH.ArrowT k1) k2 -> KindArrow () <$> compileKind k1 <*> compileKind k2
-    k -> dieTH $ "Unsupported kind: " ++ show k
+    k -> throwError $ UnsupportedLiftKind k
 
 compileType :: TH.Type -> THCompile (TH.TExpQ (RTCompileScope PLC.DefaultUni (Type TyName PLC.DefaultUni ())))
 compileType = \case
@@ -221,11 +262,10 @@ compileType = \case
                   vars <- ask
                   case Map.lookup name vars of
                       Just ty -> pure ty
-                      -- TODO: better runtime failures
-                      Nothing -> Prelude.error $ "Unknown local variable: " ++ show name
+                      Nothing -> Prelude.throw $ LiftMissingVar name
              ||]
         else compileTypeableType t name
-    t -> dieTH $ "Unsupported type: " ++ show t
+    t -> throwError $ UnsupportedLiftType t
 
 -- | Compile a type with the given name using 'typeRep' and incurring a corresponding 'Typeable' dependency.
 compileTypeableType :: TH.Type -> TH.Name -> THCompile (TH.TExpQ (RTCompileScope PLC.DefaultUni (Type TyName PLC.DefaultUni ())))
@@ -281,7 +321,7 @@ compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName=tyName, TH.datatypeVars=tvs} =
         -- Extract the unique field of the unique constructor
         argTy <- case cons of
             [ TH.ConstructorInfo {TH.constructorFields=[argTy]} ] -> (compileType <=< normalizeAndResolve) argTy
-            _ -> dieTH "Newtypes must have a single constructor with a single argument"
+            _ -> throwError $ UserLiftError "Newtypes must have a single constructor with a single argument"
         deps <- gets getTyConDeps
         pure [||
             let
@@ -300,7 +340,7 @@ compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName=tyName, TH.datatypeVars=tvs} =
                             defineType tyName (PLC.Def dtvd alias) deps
                             recordAlias' tyName
                             pure alias
-            in flip runReaderT mempty act
+            in runReaderT act mempty
          ||]
     else do
         constrExprs <- traverse compileConstructorDecl cons
@@ -337,7 +377,7 @@ compileTypeRep dt@TH.DatatypeInfo{TH.datatypeName=tyName, TH.datatypeVars=tvs} =
 
                             defineDatatype tyName (PLC.Def dtvd datatype) deps
                         pure $ mkTyVar () dtvd
-          in flip runReaderT mempty act
+          in runReaderT act mempty
           ||]
 
 compileConstructorDecl
@@ -362,7 +402,7 @@ makeTypeable uni name = do
     requireExtension TH.ScopedTypeVariables
 
     info <- TH.reifyDatatype name
-    (rhs, deps) <- flip runReaderT mempty $ flip runStateT mempty $ (compileTypeRep info)
+    (rhs, deps) <- runTHCompile $ compileTypeRep info
 
     -- See Note [Closed constraints]
     let constraints = filter (not . isClosedConstraint) $ toConstraint uni <$> Set.toList deps
@@ -408,6 +448,7 @@ compileConstructorClause dt@TH.DatatypeInfo{TH.datatypeName=tyName, TH.datatypeV
         rhsExpr <- if isNewtype dt
             then case liftExprs of
                     [argExpr] -> pure argExpr
+                    -- TODO: switch to throwError $ Userlifterror
                     _         -> dieTH "Newtypes must have a single constructor with a single argument"
             else
                 pure [||
@@ -431,8 +472,7 @@ compileConstructorClause dt@TH.DatatypeInfo{TH.datatypeName=tyName, TH.datatypeV
                         -- get the right constructor
                         maybeConstructors <- lookupConstructors () tyName
                         constrs <- case maybeConstructors of
-                            -- TODO: better runtime failures
-                            Nothing -> Prelude.error $ "Constructors not created for " ++ show tyName
+                            Nothing -> Prelude.throw $ LiftMissingDataCons tyName
                             Just cs -> pure cs
                         let constr = constrs !! index
 
@@ -455,10 +495,7 @@ makeLift name = do
 
     let datatypeType = TH.datatypeType info
 
-    (clauses, deps) <-
-        flip runReaderT mempty $
-        flip runStateT mempty $
-        (compileLift info)
+    (clauses, deps) <- runTHCompile $ compileLift info
 
     {-
     Here we *do* need to add some constraints, because we're going to generate things like
@@ -479,3 +516,14 @@ makeLift name = do
     decl <- TH.funD 'lift clauses
     let liftDecs = [TH.InstanceD Nothing constraints (liftPir uni datatypeType) [decl]]
     pure $ typeableDecs ++ liftDecs
+
+
+-- | In case of exception, it will call `fail` in TemplateHaskell
+runTHCompile :: THCompile a -> TH.Q (a, Deps)
+runTHCompile m = do
+    res <- runExceptT $
+          flip runReaderT mempty $
+          runStateT m mempty
+    case res of
+        Left a -> fail $ "Generating Lift instances: " ++ show (PP.pretty a)
+        Right b -> pure b