-- 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 (..)) where

import PlutusCore qualified as PLC
import PlutusCore.Pretty qualified as PLC

import Control.Exception

import Data.Text qualified as T
import Data.Typeable
import Prettyprinter ((<+>))
import Prettyprinter qualified as PP

data Error uni fun a
  = -- | A generic compilation error.
    CompilationError !a !T.Text
  | -- | An error relating specifically to an unsupported feature.
    UnsupportedError !a !T.Text
  | {-| An error from running some PLC function, lifted into
    this error type for convenience. -}
    PLCError !(PLC.Error uni fun a)

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)