Remvoe use of prisms for error handling on typechecking/compilation pipeline (#7111)

Author: SeungheonOh

plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs

@@ -22,7 +22,6 @@ import PlutusCore.Evaluation.Machine.BuiltinCostModel hiding (BuiltinCostModel)
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage)
 import PlutusCore.Evaluation.Machine.MachineParameters
-import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 import PlutusPrelude
 import UntypedPlutusCore.Evaluation.Machine.Cek
@@ -137,7 +136,7 @@ infixr >:
 n >: k =
     case n of
       SomeConstant (Some (ValueOf DefaultUniInteger _)) -> k
-      _                                                 -> evaluationFailure
+      _                                                 -> builtinResultFailure
 {-# INLINE (>:) #-}
 
 {- | The meanings of the builtins.  Each one takes a number of arguments and

plutus-core/docs/BuiltinsOverview.md

@@ -402,7 +402,7 @@ Here's an example instance (where `Term` is the type of TPLC terms):
 ```haskell
 instance HasConstant (Term TyName Name uni fun ()) where
     asConstant (Constant _ val) = pure val
-    asConstant _                = throwNotAConstant
+    asConstant _                = throwError notAConstant
 ```
 
 Unlifting of constants then is just a matter of unwrapping a value as a constant and checking that the constant is of the right type, which is what the default implementation of `readKnown` does:
@@ -452,5 +452,5 @@ instance
         ( TypeError ('Text "‘BuiltinResult’ cannot appear in the type of an argument")
         , uni ~ UniOf val
         ) => ReadKnownIn uni val (BuiltinResult a) where
-    readKnown _ = throwUnderTypeError
+    readKnown _ = throwError underTypeError
 ```

plutus-core/executables/plutus/AnyProgram/Compile.hs

@@ -32,8 +32,7 @@ import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Check.Uniques qualified as UPLC
 
 import Control.Lens hiding ((%~))
-import Control.Monad.Error.Lens
-import Control.Monad.Except (MonadError)
+import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Singletons.Decide
 import Data.Text
@@ -61,14 +60,14 @@ compileProgram = curry $ \case
         -- TODO: optimise
         >=> pirToOutName n1 n2
         >=> toOutAnn a1 a2
-    (SPlc n1 a1, SPlc n2 a2) ->
-        through (modifyError (fmap PIR.Original . PIR.PLCError) . plcTypecheck n1 a1)
-        >=> plcToOutName n1 n2
+    (SPlc n1 a1, SPlc n2 a2) -> -- TODO: modifyError ... is repeated multiple times
+        through (modifyError (fmap PIR.Original) . plcTypecheck n1 a1)
+        >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . plcToOutName n1 n2
         >=> toOutAnn a1 a2
     (SUplc n1 a1, SUplc n2 a2) ->
-        through (modifyError (fmap PIR.Original) . uplcTypecheck n1 a1)
-        >=> uplcOptimise n1
-        >=> uplcToOutName n1 n2
+        through (modifyError (fmap PIR.Original . PIR.PLCError) . uplcTypecheck n1 a1)
+        >=> modifyError (fmap PIR.Original) . uplcOptimise n1
+        >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . uplcToOutName n1 n2
         >=> toOutAnn a1 a2
     -- nothing to be done; seems silly, but can be used for later changing format of Data
     (SData, SData) -> pure
@@ -82,13 +81,13 @@ compileProgram = curry $ \case
       withA @Ord a1 $ withA @Pretty a1 $ withA @AnnInline a1 $
         -- Note: PIR.compileProgram subsumes pir typechecking
         (PLC.runQuoteT . flip runReaderT compCtx . PIR.compileProgram)
-        >=> plcToOutName n1 n2
+        >=> modifyError (fmap PIR.Original . PIR.PLCError . PLC.FreeVariableErrorE) . plcToOutName n1 n2
         -- completely drop annotations for now
         >=> pure . void
         where
           compCtx = PIR.toDefaultCompilationCtx $
                     unsafeFromRight @(PIR.Error DefaultUni DefaultFun ()) $
-                    PLC.getDefTypeCheckConfig ()
+                    modifyError (PIR.PLCError . TypeErrorE) $ PLC.getDefTypeCheckConfig ()
 
     -- note to self: this restriction is because of PIR.Provenance appearing in the output
     (SPir _n1@SName _, SPlc _ _) -> throwingPIR "only support unit-ann output for now"
@@ -139,7 +138,7 @@ compileProgram = curry $ \case
 embedProgram :: PLC.Program tyname name uni fun ann -> PIR.Program tyname name uni fun ann
 embedProgram (PLC.Program a v t) = PIR.Program a v $ embedTerm t
 
-toOutAnn :: (Functor f, PIR.AsError e uni fun a, MonadError e m)
+toOutAnn :: (Functor f, MonadError (PIR.Error uni fun a) m)
          => SAnn s1
          -> SAnn s2
          -> f (FromAnn s1)
@@ -152,76 +151,67 @@ toOutAnn _ _                             = throwingPIR "cannot convert annotatio
 -- or by some singletons type-level programming
 
 pirTypecheck
-    :: ( PIR.AsTypeErrorExt e DefaultUni (FromAnn a)
-      , PIR.AsTypeError e (PIR.Term UPLC.TyName UPLC.Name DefaultUni DefaultFun ())
-          DefaultUni DefaultFun (FromAnn a), MonadError e m
-      )
+    :: (MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m)
     => SAnn a
     -> PIR.Program PLC.TyName PLC.Name DefaultUni DefaultFun (FromAnn a)
     -> m ()
 pirTypecheck sngA p = PLC.runQuoteT $ do
-    tcConfig <- withA @Monoid sngA $ PIR.getDefTypeCheckConfig mempty
+    tcConfig <- withA @Monoid sngA $ modifyError (PIR.PLCError . PLC.TypeErrorE) $ PIR.getDefTypeCheckConfig mempty
     void $ PIR.inferTypeOfProgram tcConfig p
 
-plcToUplcViaName :: (PLC.MonadQuote m, PLC.AsFreeVariableError e, MonadError e m)
+plcToUplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m)
             => SNaming n
             -> (PLC.Program PLC.TyName PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a))
             -> PLC.Program (FromNameTy n) (FromName n) uni fun a
             -> m (UPLC.Program (FromName n) uni fun a)
 plcToUplcViaName sngN act = case sngN of
     SName -> act
-    SNamedDeBruijn -> plcToName sngN act
-                     >=> UPLC.progTerm UPLC.deBruijnTerm
-    SDeBruijn -> plcToName sngN act
-                >=> UPLC.progTerm UPLC.deBruijnTerm
+    SNamedDeBruijn ->
+      plcToName sngN act >=>
+      UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm)
+    SDeBruijn ->
+      plcToName sngN act
+                >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm)
                 >=> pure . UPLC.programMapNames PLC.unNameDeBruijn
 
-plcToName :: (PLC.MonadQuote m, PLC.AsFreeVariableError e, MonadError e m)
+plcToName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m)
           => SNaming n
           -> (PLC.Program PLC.TyName PLC.Name uni fun a -> m x)
           -> (PLC.Program (FromNameTy n) (FromName n) uni fun a -> m x)
 plcToName sngN act = case sngN of
     SName -> act
-    SNamedDeBruijn -> PLC.progTerm PLC.unDeBruijnTerm
+    SNamedDeBruijn -> PLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . PLC.unDeBruijnTerm)
                       >=> act
     SDeBruijn -> pure . PLC.programMapNames PLC.fakeTyNameDeBruijn PLC.fakeNameDeBruijn
                 >=> plcToName SNamedDeBruijn act
 
-uplcViaName :: (PLC.MonadQuote m, PLC.AsFreeVariableError e, MonadError e m)
+uplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m)
             => (UPLC.Program PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a))
             -> SNaming n
             -> UPLC.Program (FromName n) uni fun a
             -> m (UPLC.Program (FromName n) uni fun a)
 uplcViaName act sngN = case sngN of
     SName -> act
-    SNamedDeBruijn -> UPLC.progTerm UPLC.unDeBruijnTerm
+    SNamedDeBruijn -> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.unDeBruijnTerm)
                     >=> act
-                    >=> UPLC.progTerm UPLC.deBruijnTerm
+                    >=> UPLC.progTerm (modifyError (PIR.PLCError . PLC.FreeVariableErrorE) . UPLC.deBruijnTerm)
     SDeBruijn -> pure . UPLC.programMapNames UPLC.fakeNameDeBruijn
                 >=> uplcViaName act SNamedDeBruijn
                 >=> pure . UPLC.programMapNames UPLC.unNameDeBruijn
 
-plcTypecheck :: (PLC.AsTypeError
-                          e
-                          -- errors remain with names
-                          (PLC.Term PLC.TyName PLC.Name DefaultUni DefaultFun ())
-                          DefaultUni
-                          DefaultFun
-                          (FromAnn a)
-               , PLC.AsFreeVariableError e
-               , MonadError e m
-               )
+plcTypecheck :: (MonadError (PIR.Error DefaultUni DefaultFun (FromAnn a)) m)
              => SNaming n
              -> SAnn a
              -> PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a)
              -> m ()
-plcTypecheck sngN sngA p = PLC.runQuoteT $ do
-    tcConfig <- withA @Monoid sngA $ PLC.getDefTypeCheckConfig mempty
-    void $ plcToName sngN (PLC.inferTypeOfProgram tcConfig) p
+plcTypecheck sngN sngA p = PLC.runQuoteT $  do
+    tcConfig <-
+      withA @Monoid sngA $
+        modifyError (PIR.PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig mempty
+    void $ plcToName sngN (modifyError (PIR.PLCError . PLC.TypeErrorE) . PLC.inferTypeOfProgram tcConfig) p
 
 uplcOptimise :: (?opts :: Opts
-                , PLC.AsFreeVariableError e
-                , MonadError e m
+                , MonadError (PIR.Error DefaultUni DefaultFun a) m
                 )
              => SNaming n1
              -> UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a
@@ -238,31 +228,32 @@ uplcOptimise =
                    . _Wrapped
                    . uplcViaName (UPLC.simplifyProgram sOpts def)
 
-
 -- | We do not have a typechecker for uplc, but we could pretend that scopecheck is a "typechecker"
-uplcTypecheck :: forall sN sA uni fun e m
-              . (PLC.AsFreeVariableError e, PLC.AsUniqueError e (FromAnn sA), MonadError e m)
+uplcTypecheck :: forall sN sA uni fun m
+              . (MonadError (PLC.Error uni fun (FromAnn sA)) m)
               => SNaming sN
               -> SAnn sA
               -> UPLC.UnrestrictedProgram (FromName sN) uni fun (FromAnn sA)
               -> m ()
 uplcTypecheck sngN sngA ast = case sngN of
-    SName          -> withA @Ord sngA $ UPLC.checkProgram (const True) (ast ^. _Wrapped)
+    SName          ->
+      modifyError PLC.UniqueCoherencyErrorE $
+        withA @Ord sngA $ UPLC.checkProgram (const True) (ast ^. _Wrapped)
     -- TODO: deduplicate
-    SDeBruijn      -> UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm)
-    SNamedDeBruijn -> UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm)
+    SDeBruijn      -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm)
+    SNamedDeBruijn -> modifyError PLC.FreeVariableErrorE $ UPLC.checkScope (ast ^. _Wrapped. UPLC.progTerm)
 
 
 -- | Placed here just for uniformity, not really needed
-pirToOutName :: (PIR.AsError e uni fun a, MonadError e m)
+pirToOutName :: (MonadError (PIR.Error uni fun a) m)
              => SNaming s1
              -> SNaming s2
              -> PIR.Program (FromNameTy s1) (FromName s1) uni fun ann
              -> m (PIR.Program (FromNameTy s2) (FromName s2) uni fun ann)
 pirToOutName sng1 ((sng1 %~) -> Proved Refl) = pure
 pirToOutName _ _ = throwingPIR "we do not support name conversion for PIR atm"
 
-plcToOutName :: (PLC.AsFreeVariableError e, MonadError e m)
+plcToOutName :: (MonadError FreeVariableError m)
              => SNaming s1
              -> SNaming s2
              -> PLC.Program (FromNameTy s1) (FromName s1) uni fun ann
@@ -280,14 +271,14 @@ plcToOutName SDeBruijn SName = plcToOutName SDeBruijn SNamedDeBruijn
                            >=> plcToOutName SNamedDeBruijn SName
 plcToOutName _ _ = error "this is complete, but i don't want to use -fno-warn-incomplete-patterns"
 
-uplcToOutName :: (PLC.AsFreeVariableError e, MonadError e m)
+uplcToOutName :: (MonadError FreeVariableError m)
               => SNaming s1
               -> SNaming s2
               -> UPLC.UnrestrictedProgram (FromName s1) uni fun ann
               -> m (UPLC.UnrestrictedProgram (FromName s2) uni fun ann)
 uplcToOutName = fmap _Wrapped . uplcToOutName'
 
-uplcToOutName' :: (PLC.AsFreeVariableError e, MonadError e m)
+uplcToOutName' :: (MonadError FreeVariableError m)
                => SNaming s1
                -> SNaming s2
                -> UPLC.Program (FromName s1) uni fun ann
@@ -304,18 +295,18 @@ uplcToOutName' SDeBruijn SName = uplcToOutName' SDeBruijn SNamedDeBruijn
 uplcToOutName' _ _ = error "this is complete, but i don't want to use -fno-warn-incomplete-patterns"
 
 -- TODO: use better, more detailed erroring
-throwingPIR :: (PIR.AsError e uni fun a, MonadError e m)
+throwingPIR :: (MonadError (PIR.Error uni fun a) m)
             => Text -> b -> m c
-throwingPIR = const . throwing PIR._Error . PIR.OptionsError
+throwingPIR = const . throwError . PIR.OptionsError
 
 checkProgram :: (e ~ PIR.Provenance (FromAnn (US_ann s)),
                   MonadError (PIR.Error DefaultUni DefaultFun e) m)
              => SLang s
              -> FromLang s
              -> m ()
 checkProgram sng p = modifyError (fmap PIR.Original) $ case sng of
-        SPlc n a     -> modifyError PIR.PLCError $ plcTypecheck n a p
-        SUplc n a    -> uplcTypecheck n a p
+        SPlc n a     -> plcTypecheck n a p
+        SUplc n a    -> modifyError PIR.PLCError $ uplcTypecheck n a p
         SPir SName a -> pirTypecheck a p
         SData        -> pure () -- data is type correct by construction
         SPir{}       -> throwingPIR "PIR: Cannot typecheck non-names" ()

plutus-core/executables/plutus/AnyProgram/IO.hs

@@ -12,7 +12,6 @@ import AnyProgram.With
 import Common
 import GetOpt
 import PlutusCore.Default
-import PlutusCore.Error
 import PlutusCore.Pretty qualified as PP
 import PlutusPrelude hiding ((%~))
 import Types
@@ -43,7 +42,7 @@ readProgram sngS fileS =
         _ -> case fileS^.fType.fFormat of
                 Text -> do
                     bs <- readFileName (fromJust $ fileS^.fName)
-                    case parseProgram @ParserErrorBundle sngS $ T.decodeUtf8Lenient bs of
+                    case parseProgram sngS $ T.decodeUtf8Lenient bs of
                         Left err  -> failE $ show err
                         Right res -> pure res
                 Flat_ -> withLang @Flat sngS $ do

plutus-core/executables/plutus/AnyProgram/Parse.hs

@@ -22,8 +22,7 @@ import PlutusCore.Data
 --
 -- This could alternatively be achieved by
 -- using a "Parsable" typeclass + withL @Parsable hasomorphism
-parseProgram :: (AsParserErrorBundle e
-               , MonadError e m)
+parseProgram :: (MonadError ParserErrorBundle m)
              => SLang n -> T.Text -> m (FromLang n)
 parseProgram s txt = PLC.runQuoteT $
     case s of

plutus-core/executables/plutus/Debugger/TUI/Main.hs

@@ -43,7 +43,7 @@ import Brick.Main qualified as B
 import Brick.Util qualified as B
 import Brick.Widgets.Edit qualified as BE
 import Control.Concurrent
-import Control.Monad.Except (runExcept)
+import Control.Monad.Except (runExcept, tryError)
 import Control.Monad.Primitive (unsafeIOToPrim)
 import Control.Monad.ST (RealWorld)
 import Data.Maybe

plutus-core/executables/src/PlutusCore/Executable/Common.hs

@@ -43,7 +43,7 @@ import PlutusCore qualified as PLC
 import PlutusCore.Builtin qualified as PLC
 import PlutusCore.Check.Uniques as PLC (checkProgram)
 import PlutusCore.Compiler.Erase qualified as PLC
-import PlutusCore.Error (AsUniqueError, ParserErrorBundle (..))
+import PlutusCore.Error (ParserErrorBundle (..))
 import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..), ExRestrictingBudget (..))
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
 import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..))
@@ -99,8 +99,7 @@ class ProgramLike p where
     -- Throws a @UniqueError@ when not all names are unique.
     checkUniques ::
         ( Ord ann
-        , AsUniqueError e ann
-        , MonadError e m
+        , MonadError (PLC.UniqueError ann) m
         ) =>
         p ann ->
         m ()
@@ -401,8 +400,8 @@ toTypedTermExample term = TypedTermExample ty term
   where
     program = PLC.Program () PLC.latestVersion term
     errOrTy = PLC.runQuote . runExceptT $ do
-        tcConfig <- PLC.getDefTypeCheckConfig ()
-        PLC.inferTypeOfProgram tcConfig program
+        tcConfig <- modifyError PLC.TypeErrorE $ PLC.getDefTypeCheckConfig ()
+        modifyError PLC.TypeErrorE $ PLC.inferTypeOfProgram tcConfig program
     ty = case errOrTy of
         Left (err :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) ->
             error $ PP.displayPlc err

plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs

@@ -24,14 +24,14 @@ import PlutusCore.Data
 import PlutusCore.Evaluation.Machine.BuiltinCostModel
 import PlutusCore.Evaluation.Machine.ExBudget
 import PlutusCore.Evaluation.Machine.ExBudgetStream
-import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 
 import PlutusCore.StdLib.Data.ScottList qualified as Plc
 
 import Control.Concurrent.MVar
 import Control.Exception
 import Control.Monad
+import Control.Monad.Except
 import Data.Default.Class
 import Data.Either
 import Data.Kind qualified as GHC (Type)
@@ -199,7 +199,7 @@ instance tyname ~ TyName => KnownTypeAst tyname DefaultUni Void where
 instance UniOf term ~ DefaultUni => MakeKnownIn DefaultUni term Void where
     makeKnown = absurd
 instance UniOf term ~ DefaultUni => ReadKnownIn DefaultUni term Void where
-    readKnown _ = throwing _StructuralUnliftingError "Can't unlift to 'Void'"
+    readKnown _ = throwError $ structuralUnliftingError "Can't unlift to 'Void'"
 
 data BuiltinErrorCall = BuiltinErrorCall
     deriving stock (Show, Eq)
@@ -286,7 +286,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idAssumeCheckBoolPlc val =
             case asConstant val of
                 Right (Some (ValueOf DefaultUniBool b)) -> pure b
-                _                                       -> evaluationFailure
+                _                                       -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdSomeConstantBool =
         makeBuiltinMeaning
@@ -296,7 +296,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idSomeConstantBoolPlc :: SomeConstant uni Bool -> BuiltinResult Bool
         idSomeConstantBoolPlc = \case
             SomeConstant (Some (ValueOf DefaultUniBool b)) -> pure b
-            _                                              -> evaluationFailure
+            _                                              -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdIntegerAsBool =
         makeBuiltinMeaning
@@ -306,7 +306,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
         idIntegerAsBool :: SomeConstant uni Integer -> BuiltinResult (SomeConstant uni Integer)
         idIntegerAsBool = \case
             con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> pure con
-            _                                                    -> evaluationFailure
+            _                                                    -> builtinResultFailure
 
     toBuiltinMeaning _semvar IdFInteger =
         makeBuiltinMeaning
@@ -397,7 +397,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
 
     toBuiltinMeaning _semvar ErrorPrime =
         makeBuiltinMeaning
-            (evaluationFailure :: forall a. BuiltinResult a)
+            (builtinResultFailure :: forall a. BuiltinResult a)
             whatever
 
     toBuiltinMeaning _semvar Comma =