{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusIR.Compiler.Error (Error (..), AsError (..)) where
import PlutusCore qualified as PLC
import PlutusCore.Pretty qualified as PLC
import Control.Exception
import Control.Lens
import Data.Text qualified as T
import Data.Typeable
import Prettyprinter ((<+>))
import Prettyprinter qualified as PP
data Error uni fun a
= CompilationError !a !T.Text
| UnsupportedError !a !T.Text
| PLCError !(PLC.Error uni fun a)
makeClassyPrisms ''Error
instance PLC.AsTypeError (Error uni fun ann) (PLC.Term PLC.TyName PLC.Name uni fun ()) uni fun ann where
_TypeError :: Prism'
(Error uni fun ann)
(TypeError (Term TyName Name uni fun ()) uni fun ann)
_TypeError = p (Error uni fun ann) (f (Error uni fun ann))
-> p (Error uni fun ann) (f (Error uni fun ann))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (Error uni fun a)
Prism' (Error uni fun ann) (Error uni fun ann)
_PLCError (p (Error uni fun ann) (f (Error uni fun ann))
-> p (Error uni fun ann) (f (Error uni fun ann)))
-> (p (TypeError (Term TyName Name uni fun ()) uni fun ann)
(f (TypeError (Term TyName Name uni fun ()) uni fun ann))
-> p (Error uni fun ann) (f (Error uni fun ann)))
-> p (TypeError (Term TyName Name uni fun ()) uni fun ann)
(f (TypeError (Term TyName Name uni fun ()) uni fun ann))
-> p (Error uni fun ann) (f (Error uni fun ann))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (TypeError (Term TyName Name uni fun ()) uni fun ann)
(f (TypeError (Term TyName Name uni fun ()) uni fun ann))
-> p (Error uni fun ann) (f (Error uni fun ann))
forall r term (uni :: * -> *) fun ann.
AsTypeError r term uni fun ann =>
Prism' r (TypeError term uni fun ann)
Prism'
(Error uni fun ann)
(TypeError (Term TyName Name uni fun ()) uni fun ann)
PLC._TypeError
instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => Show (Error uni fun ann) where
show :: Error uni fun ann -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (Error uni fun ann -> Doc Any) -> Error uni fun ann -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error uni fun ann -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
PLC.prettyPlcClassicSimple
instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) =>
PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) where
prettyBy :: forall ann. PrettyConfigPlc -> Error uni fun ann -> Doc ann
prettyBy PrettyConfigPlc
config = \case
CompilationError ann
x Text
e -> Doc ann
"Error during compilation:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
e Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ann -> Doc ann
forall ann. ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty ann
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
UnsupportedError ann
x Text
e -> Doc ann
"Unsupported construct:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ann -> Doc ann
forall ann. ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty ann
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
PLCError Error uni fun ann
e -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [ Doc ann
"Error from the PLC compiler:", PrettyConfigPlc -> Error uni fun ann -> Doc ann
forall ann. PrettyConfigPlc -> Error uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config Error uni fun ann
e ]
deriving anyclass instance
(PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann)