{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusTx.Compiler.Error (
CompileError
, Error (..)
, WithContext (..)
, withContext
, withContextM
, throwPlain
, pruneContext) where
import PlutusIR.Compiler qualified as PIR
import Language.Haskell.TH qualified as TH
import PlutusCore qualified as PLC
import PlutusCore.Pretty qualified as PLC
import PlutusIR qualified as PIR
import Control.Lens
import Control.Monad.Except
import Data.Text qualified as T
import Prettyprinter qualified as PP
data WithContext c e = NoContext e | WithContextC Int c (WithContext c e)
deriving stock (forall a b. (a -> b) -> WithContext c a -> WithContext c b)
-> (forall a b. a -> WithContext c b -> WithContext c a)
-> Functor (WithContext c)
forall a b. a -> WithContext c b -> WithContext c a
forall a b. (a -> b) -> WithContext c a -> WithContext c b
forall c a b. a -> WithContext c b -> WithContext c a
forall c a b. (a -> b) -> WithContext c a -> WithContext c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall c a b. (a -> b) -> WithContext c a -> WithContext c b
fmap :: forall a b. (a -> b) -> WithContext c a -> WithContext c b
$c<$ :: forall c a b. a -> WithContext c b -> WithContext c a
<$ :: forall a b. a -> WithContext c b -> WithContext c a
Functor
makeClassyPrisms ''WithContext
type CompileError uni fun ann = WithContext T.Text (Error uni fun ann)
withContext :: (MonadError (WithContext c e) m) => Int -> c -> m a -> m a
withContext :: forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
Int -> c -> m a -> m a
withContext Int
p c
c m a
act = m a -> (WithContext c e -> m a) -> m a
forall a. m a -> (WithContext c e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
act ((WithContext c e -> m a) -> m a)
-> (WithContext c e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \WithContext c e
err -> WithContext c e -> m a
forall a. WithContext c e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> c -> WithContext c e -> WithContext c e
forall c e. Int -> c -> WithContext c e -> WithContext c e
WithContextC Int
p c
c WithContext c e
err)
withContextM :: (MonadError (WithContext c e) m) => Int -> m c -> m a -> m a
withContextM :: forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
Int -> m c -> m a -> m a
withContextM Int
p m c
mc m a
act = do
c
c <- m c
mc
m a -> (WithContext c e -> m a) -> m a
forall a. m a -> (WithContext c e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m a
act ((WithContext c e -> m a) -> m a)
-> (WithContext c e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \WithContext c e
err -> WithContext c e -> m a
forall a. WithContext c e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Int -> c -> WithContext c e -> WithContext c e
forall c e. Int -> c -> WithContext c e -> WithContext c e
WithContextC Int
p c
c WithContext c e
err)
throwPlain :: MonadError (WithContext c e) m => e -> m a
throwPlain :: forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain = WithContext c e -> m a
forall a. WithContext c e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (WithContext c e -> m a) -> (e -> WithContext c e) -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> WithContext c e
forall c e. e -> WithContext c e
NoContext
pruneContext :: Int -> WithContext c e -> WithContext c e
pruneContext :: forall c e. Int -> WithContext c e -> WithContext c e
pruneContext Int
prio = \case
NoContext e
e -> e -> WithContext c e
forall c e. e -> WithContext c e
NoContext e
e
WithContextC Int
p c
c WithContext c e
e ->
let inner :: WithContext c e
inner = Int -> WithContext c e -> WithContext c e
forall c e. Int -> WithContext c e -> WithContext c e
pruneContext Int
prio WithContext c e
e in if Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
prio then WithContext c e
inner else Int -> c -> WithContext c e -> WithContext c e
forall c e. Int -> c -> WithContext c e -> WithContext c e
WithContextC Int
p c
c WithContext c e
inner
instance (PP.Pretty c, PP.Pretty e) => PP.Pretty (WithContext c e) where
pretty :: forall ann. WithContext c e -> Doc ann
pretty = \case
NoContext e
e -> Doc ann
"Error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ e -> Doc ann
forall ann. e -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty e
e)
WithContextC Int
_ c
c WithContext c e
e -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [
WithContext c e -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. WithContext c e -> Doc ann
PP.pretty WithContext c e
e,
Doc ann
"Context:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ c -> Doc ann
forall ann. c -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty c
c)
]
data Error uni fun a
= PLCError !(PLC.Error uni fun a)
| PIRError !(PIR.Error uni fun (PIR.Provenance a))
| CompilationError !T.Text
| UnsupportedError !T.Text
| FreeVariableError !T.Text
| InvalidMarkerError !String
| CoreNameLookupError !TH.Name
makeClassyPrisms ''Error
instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => PP.Pretty (Error uni fun a) where
pretty :: forall ann. Error uni fun a -> Doc ann
pretty = Error uni fun a -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PLC.prettyPlcClassicSimple
instance
(uni1 ~ uni2, b ~ PIR.Provenance a) =>
PLC.AsTypeError (CompileError uni1 fun a) (PIR.Term PIR.TyName PIR.Name uni2 fun ()) uni2 fun b
where
_TypeError :: Prism'
(CompileError uni1 fun a)
(TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
_TypeError = p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall r c e. AsWithContext r c e => Prism' r e
Prism' (CompileError uni1 fun a) (Error uni2 fun a)
_NoContext (p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a)))
-> (p (TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
(f (TypeError (Term TyName Name uni2 fun ()) uni2 fun b))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> p (TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
(f (TypeError (Term TyName Name uni2 fun ()) uni2 fun b))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun (Provenance a))
Prism' (Error uni2 fun a) (Error uni2 fun (Provenance a))
_PIRError (p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> (p (TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
(f (TypeError (Term TyName Name uni2 fun ()) uni2 fun b))
-> p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a))))
-> p (TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
(f (TypeError (Term TyName Name uni2 fun ()) uni2 fun b))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
(f (TypeError (Term TyName Name uni2 fun ()) uni2 fun b))
-> p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
forall r term (uni :: * -> *) fun ann.
AsTypeError r term uni fun ann =>
Prism' r (TypeError term uni fun ann)
Prism'
(Error uni2 fun (Provenance a))
(TypeError (Term TyName Name uni2 fun ()) uni2 fun b)
PIR._TypeError
instance
(uni1 ~ uni2, b ~ PIR.Provenance a) =>
PIR.AsTypeErrorExt (CompileError uni1 fun a) uni2 b
where
_TypeErrorExt :: Prism' (CompileError uni1 fun a) (TypeErrorExt uni2 b)
_TypeErrorExt = p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall r c e. AsWithContext r c e => Prism' r e
Prism' (CompileError uni1 fun a) (Error uni2 fun a)
_NoContext (p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a)))
-> (p (TypeErrorExt uni2 b) (f (TypeErrorExt uni2 b))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> p (TypeErrorExt uni2 b) (f (TypeErrorExt uni2 b))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun (Provenance a))
Prism' (Error uni2 fun a) (Error uni2 fun (Provenance a))
_PIRError (p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> (p (TypeErrorExt uni2 b) (f (TypeErrorExt uni2 b))
-> p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a))))
-> p (TypeErrorExt uni2 b) (f (TypeErrorExt uni2 b))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (TypeErrorExt uni2 b) (f (TypeErrorExt uni2 b))
-> p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
forall r (uni :: * -> *) ann.
AsTypeErrorExt r uni ann =>
Prism' r (TypeErrorExt uni ann)
Prism' (Error uni2 fun (Provenance a)) (TypeErrorExt uni2 b)
PIR._TypeErrorExt
instance uni1 ~ uni2 => PLC.AsNormCheckError (CompileError uni1 fun a) PLC.TyName PLC.Name uni2 fun a where
_NormCheckError :: Prism'
(CompileError uni1 fun a) (NormCheckError TyName Name uni2 fun a)
_NormCheckError = p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall r c e. AsWithContext r c e => Prism' r e
Prism' (CompileError uni1 fun a) (Error uni2 fun a)
_NoContext (p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a)))
-> (p (NormCheckError TyName Name uni2 fun a)
(f (NormCheckError TyName Name uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> p (NormCheckError TyName Name uni2 fun a)
(f (NormCheckError TyName Name uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun a)
Prism' (Error uni2 fun a) (Error uni2 fun a)
_PLCError (p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> (p (NormCheckError TyName Name uni2 fun a)
(f (NormCheckError TyName Name uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> p (NormCheckError TyName Name uni2 fun a)
(f (NormCheckError TyName Name uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (NormCheckError TyName Name uni2 fun a)
(f (NormCheckError TyName Name uni2 fun a))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall r tyname name (uni :: * -> *) fun ann.
AsNormCheckError r tyname name uni fun ann =>
Prism' r (NormCheckError tyname name uni fun ann)
Prism' (Error uni2 fun a) (NormCheckError TyName Name uni2 fun a)
PLC._NormCheckError
instance PLC.AsUniqueError (CompileError uni fun a) a where
_UniqueError :: Prism' (CompileError uni fun a) (UniqueError a)
_UniqueError = p (Error uni fun a) (f (Error uni fun a))
-> p (CompileError uni fun a) (f (CompileError uni fun a))
forall r c e. AsWithContext r c e => Prism' r e
Prism' (CompileError uni fun a) (Error uni fun a)
_NoContext (p (Error uni fun a) (f (Error uni fun a))
-> p (CompileError uni fun a) (f (CompileError uni fun a)))
-> (p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a)))
-> p (UniqueError a) (f (UniqueError a))
-> p (CompileError uni fun a) (f (CompileError uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Error uni fun a) (f (Error uni fun a))
-> p (Error uni fun a) (f (Error uni fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun a)
Prism' (Error uni fun a) (Error uni fun a)
_PLCError (p (Error uni fun a) (f (Error uni fun a))
-> p (Error uni fun a) (f (Error uni fun a)))
-> (p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a)))
-> p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a))
forall r ann. AsUniqueError r ann => Prism' r (UniqueError ann)
Prism' (Error uni fun a) (UniqueError a)
PLC._UniqueError
instance
(uni1 ~ uni2, b ~ PIR.Provenance a) =>
PIR.AsError (CompileError uni1 fun a) uni2 fun b
where
_Error :: Prism' (CompileError uni1 fun a) (Error uni2 fun b)
_Error = p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall r c e. AsWithContext r c e => Prism' r e
Prism' (CompileError uni1 fun a) (Error uni2 fun a)
_NoContext (p (Error uni2 fun a) (f (Error uni2 fun a))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a)))
-> (p (Error uni2 fun b) (f (Error uni2 fun b))
-> p (Error uni2 fun a) (f (Error uni2 fun a)))
-> p (Error uni2 fun b) (f (Error uni2 fun b))
-> p (CompileError uni1 fun a) (f (CompileError uni1 fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (Error uni2 fun b) (f (Error uni2 fun b))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
p (Error uni2 fun (Provenance a))
(f (Error uni2 fun (Provenance a)))
-> p (Error uni2 fun a) (f (Error uni2 fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun (Provenance a))
Prism' (Error uni2 fun a) (Error uni2 fun (Provenance a))
_PIRError
instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) =>
PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) where
prettyBy :: forall ann. PrettyConfigPlc -> Error uni fun a -> Doc ann
prettyBy PrettyConfigPlc
config = \case
PLCError Error uni fun a
e -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [ Doc ann
"Error from the PLC compiler:", PrettyConfigPlc -> Error uni fun a -> Doc ann
forall ann. PrettyConfigPlc -> Error uni fun a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config Error uni fun a
e ]
PIRError Error uni fun (Provenance a)
e -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [ Doc ann
"Error from the PIR compiler:", PrettyConfigPlc -> Error uni fun (Provenance a) -> Doc ann
forall ann.
PrettyConfigPlc -> Error uni fun (Provenance a) -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config Error uni fun (Provenance a)
e ]
CompilationError Text
e -> Doc ann
"Unexpected error during compilation, please report this to the Plutus team:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
e
UnsupportedError Text
e -> Doc ann
"Unsupported feature:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
e
FreeVariableError Text
e -> Doc ann
"Reference to a name which is not a local, a builtin, or an external INLINABLE function:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
e
InvalidMarkerError String
e -> Doc ann
"Found invalid marker, not applied correctly in expression" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty String
e
CoreNameLookupError Name
n -> Doc ann
"Unable to get Core name needed for the plugin to function: " Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Name -> Doc ann
forall a ann. Show a => a -> Doc ann
PP.viaShow Name
n