-- editorconfig-checker-disable-file
{-# 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     -- ^ A generic compilation error.
    | UnsupportedError !a !T.Text     -- ^ An error relating specifically to an unsupported feature.
    | PLCError !(PLC.Error uni fun a) -- ^ An error from running some PLC function, lifted into
                                      -- this error type for convenience.
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)