{-# 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.Pretty qualified as PLC
import PlutusPrelude

import PlutusIR qualified as PIR

import Control.Lens

import Data.Text qualified as T
import ErrorCode
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
showList :: [TypeErrorExt uni ann] -> ShowS
$cshowList :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
[TypeErrorExt uni ann] -> ShowS
show :: TypeErrorExt uni ann -> String
$cshow :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
TypeErrorExt uni ann -> String
showsPrec :: Int -> TypeErrorExt uni ann -> ShowS
$cshowsPrec :: forall (uni :: * -> *) ann.
(Show ann, GShow uni) =>
Int -> 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
/= :: 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
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
$cto :: forall (uni :: * -> *) ann x.
Rep (TypeErrorExt uni ann) x -> TypeErrorExt uni ann
$cfrom :: forall (uni :: * -> *) ann x.
TypeErrorExt uni ann -> Rep (TypeErrorExt uni ann) x
Generic)
    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 -> ()
rnf :: TypeErrorExt uni ann -> ()
$crnf :: forall (uni :: * -> *) ann.
(NFData ann, Closed uni) =>
TypeErrorExt uni ann -> ()
NFData)
makeClassyPrisms ''TypeErrorExt

instance HasErrorCode (TypeErrorExt _a _b) where
  errorCode :: TypeErrorExt _a _b -> ErrorCode
errorCode MalformedDataConstrResType {} = Natural -> ErrorCode
ErrorCode Natural
1

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.
                     | PLCTypeError (PLC.TypeError (PIR.Term PIR.TyName PIR.Name uni fun ()) uni fun a)
                     | PIRTypeError (TypeErrorExt uni a)
makeClassyPrisms ''Error

instance HasErrorCode (Error _a _b _c) where
   errorCode :: Error _a _b _c -> ErrorCode
errorCode UnsupportedError {} = Natural -> ErrorCode
ErrorCode Natural
3
   errorCode CompilationError {} = Natural -> ErrorCode
ErrorCode Natural
2
   errorCode (PIRTypeError TypeErrorExt _a _c
e)    = TypeErrorExt _a _c -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode TypeErrorExt _a _c
e
   errorCode (PLCTypeError TypeError (Term TyName Name _a _b ()) _a _b _c
e)    = TypeError (Term TyName Name _a _b ()) _a _b _c -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode TypeError (Term TyName Name _a _b ()) _a _b _c
e
   errorCode (PLCError Error _a _b _c
e)        = Error _a _b _c -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode Error _a _b _c
e


instance PLC.AsTypeError (Error uni fun a) (PIR.Term PIR.TyName PIR.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 (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)
_PLCTypeError

instance AsTypeErrorExt (Error uni fun a) uni a where
    _TypeErrorExt :: p (TypeErrorExt uni a) (f (TypeErrorExt uni a))
-> p (Error uni fun a) (f (Error uni fun 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)
_PIRTypeError

instance PLC.AsFreeVariableError (Error uni fun a) where
    _FreeVariableError :: p FreeVariableError (f FreeVariableError)
-> p (Error uni fun a) (f (Error uni fun a))
_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)
_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
PLC._FreeVariableError

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

type PrettyUni uni ann =
    (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst, PP.Pretty ann)

instance (PrettyUni uni ann) => PrettyBy PLC.PrettyConfigPlc (TypeErrorExt uni ann) where
    prettyBy :: 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 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 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 (PrettyUni uni ann, Pretty fun) => 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
PP.pretty

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

instance
        (Pretty ann, Pretty fun,
        PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst
        ) => Pretty (Error uni fun ann) where
    pretty :: Error uni fun ann -> Doc ann
pretty = Error uni fun ann -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PLC.prettyPlcClassicDef


instance (PLC.GShow uni, PLC.Closed uni, uni `PLC.Everywhere` PLC.PrettyConst, Pretty fun, Pretty ann) =>
            PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) where
     prettyBy :: PrettyConfigPlc -> Error uni fun ann -> Doc ann
prettyBy PrettyConfigPlc
config Error uni fun ann
er = ErrorCode -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Error uni fun ann -> ErrorCode
forall a. HasErrorCode a => a -> ErrorCode
errorCode Error uni fun ann
er) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> case Error uni fun ann
er of
        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 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 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 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 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 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 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 config a ann. PrettyBy config a => config -> a -> Doc ann
PLC.prettyBy PrettyConfigPlc
config TypeErrorExt uni ann
e ]