-- 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 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

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

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
  (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