-- editorconfig-checker-disable-file
{-# 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

-- | An error with some (nested) context. The integer argument to 'WithContextC' represents
-- the priority of the context when displaying it. Lower numbers are more prioritised.
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