-- 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.AsTypeError (..)
    , PLC.TypeError
    , AsTypeErrorExt (..)
    , AsError (..)
    , TypeErrorExt (..)
    , PLC.Normalized (..)
    ) where

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

import Control.Lens
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)
makeClassyPrisms ''TypeErrorExt

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)
makeClassyPrisms ''Error

instance PLC.AsTypeError (Error uni fun a) (PIR.Term PIR.TyName PIR.Name uni fun ()) uni fun a where
    _TypeError :: Prism'
  (Error uni fun a)
  (TypeError (Term TyName Name uni fun ()) uni fun a)
_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))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (TypeError (Term TyName Name uni fun ()) uni fun a)
Prism'
  (Error uni fun a)
  (TypeError (Term TyName Name uni fun ()) uni fun a)
_PLCTypeError

instance AsTypeErrorExt (Error uni fun a) uni a where
    _TypeErrorExt :: Prism' (Error uni fun a) (TypeErrorExt uni a)
_TypeErrorExt = p (TypeErrorExt uni a) (f (TypeErrorExt uni a))
-> p (Error uni fun a) (f (Error uni fun a))
forall r (uni :: * -> *) fun a.
AsError r uni fun a =>
Prism' r (TypeErrorExt uni a)
Prism' (Error uni fun a) (TypeErrorExt uni a)
_PIRTypeError

instance PLC.AsFreeVariableError (Error uni fun a) where
    _FreeVariableError :: Prism' (Error uni fun a) FreeVariableError
_FreeVariableError = 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)
Prism' (Error uni fun a) (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 FreeVariableError (f FreeVariableError)
    -> p (Error uni fun a) (f (Error uni fun a)))
-> p FreeVariableError (f FreeVariableError)
-> p (Error uni fun a) (f (Error uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p FreeVariableError (f FreeVariableError)
-> p (Error uni fun a) (f (Error uni fun a))
forall r. AsFreeVariableError r => Prism' r FreeVariableError
Prism' (Error uni fun a) FreeVariableError
PLC._FreeVariableError

instance PLC.AsUniqueError (Error uni fun a) a where
    _UniqueError :: Prism' (Error uni fun a) (UniqueError a)
_UniqueError = 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)
Prism' (Error uni fun a) (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 (UniqueError a) (f (UniqueError a))
    -> p (Error uni fun a) (f (Error uni fun a)))
-> p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (UniqueError a) (f (UniqueError a))
-> p (Error uni fun a) (f (Error uni fun a))
forall r ann. AsUniqueError r ann => Prism' r (UniqueError ann)
Prism' (Error uni fun a) (UniqueError a)
PLC._UniqueError

instance PLC.AsParserErrorBundle (Error uni fun a) where
    _ParserErrorBundle :: Prism' (Error uni fun a) ParserErrorBundle
_ParserErrorBundle = 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)
Prism' (Error uni fun a) (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 ParserErrorBundle (f ParserErrorBundle)
    -> p (Error uni fun a) (f (Error uni fun a)))
-> p ParserErrorBundle (f ParserErrorBundle)
-> p (Error uni fun a) (f (Error uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ParserErrorBundle (f ParserErrorBundle)
-> p (Error uni fun a) (f (Error uni fun a))
forall r (uni :: * -> *) fun ann.
AsError r uni fun ann =>
Prism' r ParserErrorBundle
Prism' (Error uni fun a) ParserErrorBundle
PLC._ParseErrorE

-- 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 ]