{-# 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 a) (PLC.Term PLC.TyName PLC.Name uni fun ()) uni fun a where
    _TypeError :: p (TypeError (Term TyName Name uni fun ()) uni fun a)
  (f (TypeError (Term TyName Name uni fun ()) uni fun a))
-> p (Error uni fun a) (f (Error uni fun a))
_TypeError = 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)
_PLCError (p (Error uni fun a) (f (Error uni fun a))
 -> p (Error uni fun a) (f (Error uni fun a)))
-> (p (TypeError (Term TyName Name uni fun ()) uni fun a)
      (f (TypeError (Term TyName Name uni fun ()) uni fun a))
    -> p (Error uni fun a) (f (Error uni fun a)))
-> p (TypeError (Term TyName Name uni fun ()) uni fun a)
     (f (TypeError (Term TyName Name uni fun ()) uni fun a))
-> p (Error uni fun a) (f (Error uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (TypeError (Term TyName Name uni fun ()) uni fun a)
  (f (TypeError (Term TyName Name uni fun ()) uni fun a))
-> p (Error uni fun a) (f (Error uni fun a))
forall r term (uni :: * -> *) fun ann.
AsTypeError r term uni fun ann =>
Prism' r (TypeError term uni fun ann)
PLC._TypeError

instance (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst, PP.Pretty fun, PP.Pretty a) =>
         Show (Error uni fun a) where
    show :: Error uni fun a -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (Error uni fun a -> Doc Any) -> Error uni fun a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error uni fun a -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
PLC.prettyPlcClassicDebug

instance (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst, PP.Pretty fun, PP.Pretty a) =>
            PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) where
    prettyBy :: PrettyConfigPlc -> Error uni fun a -> Doc ann
prettyBy PrettyConfigPlc
config = \case
        CompilationError a
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 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
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
        UnsupportedError a
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 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
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty a
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
        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 config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config Error uni fun a
e ]

deriving anyclass instance
    ( PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst, PP.Pretty a, PP.Pretty fun
    , Typeable uni, Typeable fun, Typeable a
    ) => Exception (Error uni fun a)