-- editorconfig-checker-disable-file
{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DeriveAnyClass         #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
module PlutusIR.Error
    ( Error (..)
    , PLC.TypeError
    , TypeErrorExt (..)
    , PLC.Normalized (..)
    ) where

import PlutusCore qualified as PLC
import PlutusCore.Pretty qualified as PLC
import PlutusIR qualified as PIR
import PlutusPrelude

import Data.Text qualified as T
import Prettyprinter as PP

data TypeErrorExt uni ann =
      MalformedDataConstrResType
         !ann
         -- the expected constructor's type
         !(PLC.Type PLC.TyName uni ann)
    deriving stock (Int -> TypeErrorExt uni ann -> ShowS
[TypeErrorExt uni ann] -> ShowS
TypeErrorExt uni ann -> String
(Int -> TypeErrorExt uni ann -> ShowS)
-> (TypeErrorExt uni ann -> String)
-> ([TypeErrorExt uni ann] -> ShowS)
-> Show (TypeErrorExt uni ann)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
Int -> TypeErrorExt uni ann -> ShowS
forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
[TypeErrorExt uni ann] -> ShowS
forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
TypeErrorExt uni ann -> String
$cshowsPrec :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
Int -> TypeErrorExt uni ann -> ShowS
showsPrec :: Int -> TypeErrorExt uni ann -> ShowS
$cshow :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
TypeErrorExt uni ann -> String
show :: TypeErrorExt uni ann -> String
$cshowList :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
[TypeErrorExt uni ann] -> ShowS
showList :: [TypeErrorExt uni ann] -> ShowS
Show, TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
(TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool)
-> (TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool)
-> Eq (TypeErrorExt uni ann)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (uni :: * -> *) ann.
(Eq ann, GEq uni) =>
TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
$c== :: forall (uni :: * -> *) ann.
(Eq ann, GEq uni) =>
TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
== :: TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
$c/= :: forall (uni :: * -> *) ann.
(Eq ann, GEq uni) =>
TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
/= :: TypeErrorExt uni ann -> TypeErrorExt uni ann -> Bool
Eq, (forall x. TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x)
-> (forall x. Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann)
-> Generic (TypeErrorExt uni ann)
forall x. Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann
forall x. TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (uni :: * -> *) ann x.
Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann
forall (uni :: * -> *) ann x.
TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x
$cfrom :: forall (uni :: * -> *) ann x.
TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x
from :: forall x. TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x
$cto :: forall (uni :: * -> *) ann x.
Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann
to :: forall x. Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann
Generic, (forall a b. (a -> b) -> TypeErrorExt uni a -> TypeErrorExt uni b)
-> (forall a b. a -> TypeErrorExt uni b -> TypeErrorExt uni a)
-> Functor (TypeErrorExt uni)
forall a b. a -> TypeErrorExt uni b -> TypeErrorExt uni a
forall a b. (a -> b) -> TypeErrorExt uni a -> TypeErrorExt uni b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (uni :: * -> *) a b.
a -> TypeErrorExt uni b -> TypeErrorExt uni a
forall (uni :: * -> *) a b.
(a -> b) -> TypeErrorExt uni a -> TypeErrorExt uni b
$cfmap :: forall (uni :: * -> *) a b.
(a -> b) -> TypeErrorExt uni a -> TypeErrorExt uni b
fmap :: forall a b. (a -> b) -> TypeErrorExt uni a -> TypeErrorExt uni b
$c<$ :: forall (uni :: * -> *) a b.
a -> TypeErrorExt uni b -> TypeErrorExt uni a
<$ :: forall a b. a -> TypeErrorExt uni b -> TypeErrorExt uni a
Functor)
    deriving anyclass (TypeErrorExt uni ann -> ()
(TypeErrorExt uni ann -> ()) -> NFData (TypeErrorExt uni ann)
forall a. (a -> ()) -> NFData a
forall (uni :: * -> *) ann.
(NFData ann, Closed uni) =>
TypeErrorExt uni ann -> ()
$crnf :: forall (uni :: * -> *) ann.
(NFData ann, Closed uni) =>
TypeErrorExt uni ann -> ()
rnf :: TypeErrorExt uni ann -> ()
NFData)

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.
                     | OptionsError !T.Text -- ^ An error relating to compilation options.
                     | PLCError !(PLC.Error uni fun a) -- ^ An error from running some PLC function, lifted into this error type for convenience.
                     | PLCTypeError !(PLC.TypeError (PIR.Term PIR.TyName PIR.Name uni fun ()) uni fun a)
                     | PIRTypeError !(TypeErrorExt uni a)
                     deriving stock ((forall a b. (a -> b) -> Error uni fun a -> Error uni fun b)
-> (forall a b. a -> Error uni fun b -> Error uni fun a)
-> Functor (Error uni fun)
forall a b. a -> Error uni fun b -> Error uni fun a
forall a b. (a -> b) -> Error uni fun a -> Error uni fun b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (uni :: * -> *) fun a b.
a -> Error uni fun b -> Error uni fun a
forall (uni :: * -> *) fun a b.
(a -> b) -> Error uni fun a -> Error uni fun b
$cfmap :: forall (uni :: * -> *) fun a b.
(a -> b) -> Error uni fun a -> Error uni fun b
fmap :: forall a b. (a -> b) -> Error uni fun a -> Error uni fun b
$c<$ :: forall (uni :: * -> *) fun a b.
a -> Error uni fun b -> Error uni fun a
<$ :: forall a b. a -> Error uni fun b -> Error uni fun a
Functor)

-- Pretty-printing
------------------

instance (PLC.PrettyUni uni, Pretty ann) =>
        PrettyBy PLC.PrettyConfigPlc (TypeErrorExt uni ann) where
    prettyBy :: forall ann. PrettyConfigPlc -> TypeErrorExt uni ann -> Doc ann
prettyBy PrettyConfigPlc
config (MalformedDataConstrResType ann
ann Type TyName uni ann
expType) =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
"The result-type of a dataconstructor is malformed at location" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ann -> Doc ann
forall ann. ann -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty ann
ann
             , Doc ann
"The expected result-type is:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PrettyConfigPlc -> Type TyName uni ann -> Doc ann
forall ann. PrettyConfigPlc -> Type TyName uni ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy PrettyConfigPlc
config Type TyName uni ann
expType]

-- show via pretty, for printing as SomeExceptions
instance (PLC.PrettyUni uni, Pretty fun, 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. Pretty a => a -> Doc ann
forall ann. Error uni fun ann -> Doc ann
PP.pretty

-- FIXME: we get rid of this when our TestLib stops using rethrow
deriving anyclass instance
    (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann)

instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => Pretty (Error uni fun ann) where
    pretty :: forall ann. Error uni fun ann -> Doc ann
pretty = Error uni fun ann -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PLC.prettyPlcClassic


instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) =>
        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
")"
        OptionsError Text
e       -> Doc ann
"Compiler options error:" 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
        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 ]
        PLCTypeError TypeError (Term TyName Name uni fun ()) uni fun ann
e       -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [Doc ann
"Error during PIR typechecking:" , PrettyConfigPlc
-> TypeError (Term TyName Name uni fun ()) uni fun ann -> Doc ann
forall ann.
PrettyConfigPlc
-> TypeError (Term TyName Name uni fun ()) uni fun ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config TypeError (Term TyName Name uni fun ()) uni fun ann
e ]
        PIRTypeError TypeErrorExt uni ann
e       -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep [Doc ann
"Error during PIR typechecking:" , PrettyConfigPlc -> TypeErrorExt uni ann -> Doc ann
forall ann. PrettyConfigPlc -> TypeErrorExt uni ann -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config TypeErrorExt uni ann
e ]