module Morley.Michelson.TypeCheck.Error
( TypeContext (..)
, TopLevelType (..)
, TcTypeError (..)
, TcError
, TcError' (..)
, ExtError (..)
, StackSize (..)
, TCOpSeq (..)
, pairWithNodeIndex
, pairWithElems
) where
import Prelude hiding (empty, (<$>))
import Fmt (Buildable(..), Doc, isEmpty, nameF, pretty, (+|), (<$>), (<+>), (<//>), (</>), (|+))
import Fmt.Utils qualified as PP
import Prettyprinter (flatAlt, hardline)
import Prettyprinter qualified as PP
import Prettyprinter.Util (reflow)
import Morley.Michelson.ErrorPos (ErrorSrcPos(..))
import Morley.Michelson.Printer.Util
import Morley.Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp)
import Morley.Michelson.TypeCheck.Types (SomeHST(..))
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address
import Morley.Tezos.Crypto (CryptoParseError)
import Morley.Tezos.Crypto.BLS12381 qualified as BLS
import Morley.Util.MismatchError
data TypeContext
= LambdaArgument
| LambdaCodeCtx
| DipCode
| ConsArgument
| ComparisonArguments
| ContractParameter
| ContractStorage
| ArithmeticOperation
| Iteration
| Cast
| UnpairArgument
| CarArgument
| CdrArgument
| If
| ConcatArgument
| ContainerKeyType
| ContainerValueType
| FailwithArgument
| TicketsJoin
| ViewBlock
| EmitArgument
deriving stock (Int -> TypeContext -> ShowS
[TypeContext] -> ShowS
TypeContext -> String
(Int -> TypeContext -> ShowS)
-> (TypeContext -> String)
-> ([TypeContext] -> ShowS)
-> Show TypeContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeContext] -> ShowS
$cshowList :: [TypeContext] -> ShowS
show :: TypeContext -> String
$cshow :: TypeContext -> String
showsPrec :: Int -> TypeContext -> ShowS
$cshowsPrec :: Int -> TypeContext -> ShowS
Show, TypeContext -> TypeContext -> Bool
(TypeContext -> TypeContext -> Bool)
-> (TypeContext -> TypeContext -> Bool) -> Eq TypeContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeContext -> TypeContext -> Bool
$c/= :: TypeContext -> TypeContext -> Bool
== :: TypeContext -> TypeContext -> Bool
$c== :: TypeContext -> TypeContext -> Bool
Eq, (forall x. TypeContext -> Rep TypeContext x)
-> (forall x. Rep TypeContext x -> TypeContext)
-> Generic TypeContext
forall x. Rep TypeContext x -> TypeContext
forall x. TypeContext -> Rep TypeContext x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeContext x -> TypeContext
$cfrom :: forall x. TypeContext -> Rep TypeContext x
Generic)
deriving anyclass (TypeContext -> ()
(TypeContext -> ()) -> NFData TypeContext
forall a. (a -> ()) -> NFData a
rnf :: TypeContext -> ()
$crnf :: TypeContext -> ()
NFData)
instance Buildable TypeContext where
build :: TypeContext -> Doc
build = \case
TypeContext
LambdaArgument -> Doc
"argument to some lambda"
TypeContext
LambdaCodeCtx -> Doc
"code in LAMBDA"
TypeContext
DipCode -> Doc
"code in DIP"
TypeContext
ConsArgument -> Doc
"argument to CONS"
TypeContext
ComparisonArguments -> Doc
"arguments to comparison function"
TypeContext
ContractParameter -> Doc
"contract parameter"
TypeContext
ContractStorage -> Doc
"contract storage"
TypeContext
ArithmeticOperation -> Doc
"arguments to arithmetic operation"
TypeContext
Iteration -> Doc
"iteration (ITER / MAP / etc) code"
TypeContext
Cast -> Doc
"argument to CAST"
TypeContext
UnpairArgument -> Doc
"argument to UNPAIR"
TypeContext
CarArgument -> Doc
"argument to CAR"
TypeContext
CdrArgument -> Doc
"argument to CDR"
TypeContext
If -> Doc
"conditional expression"
TypeContext
ConcatArgument -> Doc
"argument to CONCAT"
TypeContext
ContainerKeyType -> Doc
"container key type"
TypeContext
ContainerValueType -> Doc
"container value type"
TypeContext
FailwithArgument -> Doc
"argument to FAILWITH"
TypeContext
TicketsJoin -> Doc
"join of two tickets"
TypeContext
ViewBlock -> Doc
"top-level view block"
TypeContext
EmitArgument -> Doc
"argument to EMIT"
data TopLevelType
= TltParameterType
| TltStorageType
deriving stock (Int -> TopLevelType -> ShowS
[TopLevelType] -> ShowS
TopLevelType -> String
(Int -> TopLevelType -> ShowS)
-> (TopLevelType -> String)
-> ([TopLevelType] -> ShowS)
-> Show TopLevelType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TopLevelType] -> ShowS
$cshowList :: [TopLevelType] -> ShowS
show :: TopLevelType -> String
$cshow :: TopLevelType -> String
showsPrec :: Int -> TopLevelType -> ShowS
$cshowsPrec :: Int -> TopLevelType -> ShowS
Show, TopLevelType -> TopLevelType -> Bool
(TopLevelType -> TopLevelType -> Bool)
-> (TopLevelType -> TopLevelType -> Bool) -> Eq TopLevelType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TopLevelType -> TopLevelType -> Bool
$c/= :: TopLevelType -> TopLevelType -> Bool
== :: TopLevelType -> TopLevelType -> Bool
$c== :: TopLevelType -> TopLevelType -> Bool
Eq, (forall x. TopLevelType -> Rep TopLevelType x)
-> (forall x. Rep TopLevelType x -> TopLevelType)
-> Generic TopLevelType
forall x. Rep TopLevelType x -> TopLevelType
forall x. TopLevelType -> Rep TopLevelType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TopLevelType x -> TopLevelType
$cfrom :: forall x. TopLevelType -> Rep TopLevelType x
Generic)
deriving anyclass (TopLevelType -> ()
(TopLevelType -> ()) -> NFData TopLevelType
forall a. (a -> ()) -> NFData a
rnf :: TopLevelType -> ()
$crnf :: TopLevelType -> ()
NFData)
instance Buildable TopLevelType where
build :: TopLevelType -> Doc
build = \case
TopLevelType
TltParameterType -> Doc
"parameter"
TopLevelType
TltStorageType -> Doc
"storage"
data TcTypeError
= TypeEqError (MismatchError T.T)
| StackEqError (MismatchError [T.T])
| UnsupportedTypeForScope T.T T.BadTypeForScope
| NotNumericTypes T.T T.T
| UnexpectedType (NonEmpty (NonEmpty Text))
| UnexpectedTopLevelType TopLevelType (MismatchError T.T)
| InvalidInstruction (U.InstrAbstract [] ()) Text
| InvalidValueType T.T
| NotEnoughItemsOnStack
| IllegalEntrypoint T.EpNameFromRefAnnError
| UnknownContract ContractAddress
| EntrypointNotFound T.EpName
| IllegalParamDecl T.ParamEpError
| NegativeNat
| MutezOverflow
| InvalidAddress T.ParseEpAddressError
| InvalidKeyHash CryptoParseError
| InvalidBls12381Object BLS.DeserializationError
| InvalidTimestamp
| CodeAlwaysFails
| EmptyCode
| AnyError
| InvalidBigMapId Integer
| UnexpectedBigMapType
Integer
(MismatchError T.T)
deriving stock (Int -> TcTypeError -> ShowS
[TcTypeError] -> ShowS
TcTypeError -> String
(Int -> TcTypeError -> ShowS)
-> (TcTypeError -> String)
-> ([TcTypeError] -> ShowS)
-> Show TcTypeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TcTypeError] -> ShowS
$cshowList :: [TcTypeError] -> ShowS
show :: TcTypeError -> String
$cshow :: TcTypeError -> String
showsPrec :: Int -> TcTypeError -> ShowS
$cshowsPrec :: Int -> TcTypeError -> ShowS
Show, TcTypeError -> TcTypeError -> Bool
(TcTypeError -> TcTypeError -> Bool)
-> (TcTypeError -> TcTypeError -> Bool) -> Eq TcTypeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TcTypeError -> TcTypeError -> Bool
$c/= :: TcTypeError -> TcTypeError -> Bool
== :: TcTypeError -> TcTypeError -> Bool
$c== :: TcTypeError -> TcTypeError -> Bool
Eq, (forall x. TcTypeError -> Rep TcTypeError x)
-> (forall x. Rep TcTypeError x -> TcTypeError)
-> Generic TcTypeError
forall x. Rep TcTypeError x -> TcTypeError
forall x. TcTypeError -> Rep TcTypeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TcTypeError x -> TcTypeError
$cfrom :: forall x. TcTypeError -> Rep TcTypeError x
Generic)
deriving anyclass (TcTypeError -> ()
(TcTypeError -> ()) -> NFData TcTypeError
forall a. (a -> ()) -> NFData a
rnf :: TcTypeError -> ()
$crnf :: TcTypeError -> ()
NFData)
instance Buildable TcTypeError where
build :: TcTypeError -> Doc
build = \case
TypeEqError MismatchError T
merr -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Types not equal" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ MismatchError T -> Doc
forall a. Buildable a => a -> Doc
build MismatchError T
merr
StackEqError MismatchError [T]
merr -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Stacks not equal" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ MismatchError [T] -> Doc
forall a. Buildable a => a -> Doc
build MismatchError [T]
merr
UnsupportedTypeForScope T
typ BadTypeForScope
reason -> Doc -> Doc
forall ann. Doc ann -> Doc ann
PP.group
(Doc
"Type" Doc -> Doc -> Doc
<$>
let res :: Doc
res = T -> Doc
forall a. Buildable a => a -> Doc
build T
typ in Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt (Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.indent Int
2 Doc
res) (Doc -> Doc
forall ann. Doc ann -> Doc ann
PP.squotes Doc
res) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
forall ann. Doc ann
PP.line)
Doc -> Doc -> Doc
<//> Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"is unsupported here because it" Doc -> Doc -> Doc
</> BadTypeForScope -> Doc
forall a. Buildable a => a -> Doc
build BadTypeForScope
reason
NotNumericTypes T
t1 T
t2 ->
Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF (Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"Some of the types in an arithmetic operation are not numeric") (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.sep
[ T -> Doc
forall a. Buildable a => a -> Doc
build T
t1 Doc -> Doc -> Doc
<+> Doc
"and"
, T -> Doc
forall a. Buildable a => a -> Doc
build T
t2
]
UnexpectedType NonEmpty (NonEmpty Text)
stacks -> Doc
"Wrong stack type for instruction."
Doc -> Doc -> Doc
</> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Expected stack type to begin with"
([Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
PP.punctuate Doc
" or" ((NonEmpty Text -> Doc) -> [NonEmpty Text] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Text -> Doc
forall a. Buildable a => a -> Doc
build ([NonEmpty Text] -> [Doc]) -> [NonEmpty Text] -> [Doc]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty Text) -> [Element (NonEmpty (NonEmpty Text))]
forall t. Container t => t -> [Element t]
toList NonEmpty (NonEmpty Text)
stacks))
UnexpectedTopLevelType TopLevelType
tyDesc MismatchError T
mmerr -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF
(Doc
"Unexpected" Doc -> Doc -> Doc
<+> TopLevelType -> Doc
forall a. Buildable a => a -> Doc
build TopLevelType
tyDesc Doc -> Doc -> Doc
<+> Doc
"type")
(MismatchError T -> Doc
forall a. Buildable a => a -> Doc
build MismatchError T
mmerr)
InvalidInstruction InstrAbstract [] ()
instr Text
reason -> [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Invalid instruction" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ InstrAbstract [] Text -> Doc
forall a. Buildable a => a -> Doc
build (InstrAbstract [] ()
instr InstrAbstract [] () -> Text -> InstrAbstract [] Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Text
"..." :: Text))
, Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Reason" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
forall a. Buildable a => a -> Doc
build Text
reason
]
InvalidValueType T
t -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Value type is never a valid" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ T -> Doc
forall a. Buildable a => a -> Doc
build T
t
TcTypeError
NotEnoughItemsOnStack -> Doc
"Not enough items on stack"
UnknownContract ContractAddress
addr -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Contract is not registered" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ContractAddress -> Doc
forall a. Buildable a => a -> Doc
build ContractAddress
addr
IllegalEntrypoint EpNameFromRefAnnError
err -> EpNameFromRefAnnError -> Doc
forall a. Buildable a => a -> Doc
build EpNameFromRefAnnError
err
EntrypointNotFound EpName
ep -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"No such entrypoint" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ EpName -> Doc
forall a. Buildable a => a -> Doc
build EpName
ep
IllegalParamDecl ParamEpError
err -> ParamEpError -> Doc
forall a. Buildable a => a -> Doc
build ParamEpError
err
TcTypeError
NegativeNat -> Doc
"Natural number cannot be negative"
TcTypeError
MutezOverflow -> Doc
"Exceeds maximal value for mutez"
InvalidAddress ParseEpAddressError
e -> ParseEpAddressError -> Doc
forall a. Buildable a => a -> Doc
build ParseEpAddressError
e
InvalidKeyHash CryptoParseError
e -> CryptoParseError -> Doc
forall a. Buildable a => a -> Doc
build CryptoParseError
e
InvalidBls12381Object DeserializationError
e -> DeserializationError -> Doc
forall a. Buildable a => a -> Doc
build DeserializationError
e
TcTypeError
InvalidTimestamp -> Doc
"Is not a valid RFC3339 timestamp"
TcTypeError
CodeAlwaysFails -> Doc
"Cannot use a terminate instruction (like FAILWITH) in this block"
TcTypeError
EmptyCode -> Doc
"Code block is empty"
TcTypeError
AnyError -> Doc
"Some of the arguments have invalid types"
InvalidBigMapId Integer
bigMapId -> Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"No big_map with ID"
Doc -> Doc -> Doc
</> Integer -> Doc
forall a. Buildable a => a -> Doc
build Integer
bigMapId
Doc -> Doc -> Doc
</> Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"was found."
UnexpectedBigMapType Integer
bigMapId MismatchError T
mismatchError -> Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"A big_map with the ID"
Doc -> Doc -> Doc
</> Integer -> Doc
forall a. Buildable a => a -> Doc
build Integer
bigMapId
Doc -> Doc -> Doc
</> Text -> Doc
forall ann. Text -> Doc ann
reflow Text
"was found, but it does not have the expected type."
, MismatchError T -> Doc
forall a. Buildable a => a -> Doc
build MismatchError T
mismatchError
]
instance Exception TcTypeError where
displayException :: TcTypeError -> String
displayException = TcTypeError -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty
data TcError' op
= TcFailedOnInstr (U.InstrAbstract [] op) SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TcTypeError)
| TcFailedOnValue (U.Value' [] op) T.T Text ErrorSrcPos (Maybe TcTypeError)
| TcContractError Text (Maybe TcTypeError)
| TcViewError Text U.ViewName (Maybe TcTypeError)
| TcUnreachableCode ErrorSrcPos (NonEmpty op)
| TcExtError SomeHST ErrorSrcPos ExtError
| TcIncompletelyTyped (TcError' op) (U.Contract' (TCOpSeq op))
| TcIncompletelyTypedView (TcError' op) (U.View' (TCOpSeq op))
| TcDeprecatedType Text T.T
deriving stock (Int -> TcError' op -> ShowS
[TcError' op] -> ShowS
TcError' op -> String
(Int -> TcError' op -> ShowS)
-> (TcError' op -> String)
-> ([TcError' op] -> ShowS)
-> Show (TcError' op)
forall op. Show op => Int -> TcError' op -> ShowS
forall op. Show op => [TcError' op] -> ShowS
forall op. Show op => TcError' op -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TcError' op] -> ShowS
$cshowList :: forall op. Show op => [TcError' op] -> ShowS
show :: TcError' op -> String
$cshow :: forall op. Show op => TcError' op -> String
showsPrec :: Int -> TcError' op -> ShowS
$cshowsPrec :: forall op. Show op => Int -> TcError' op -> ShowS
Show, TcError' op -> TcError' op -> Bool
(TcError' op -> TcError' op -> Bool)
-> (TcError' op -> TcError' op -> Bool) -> Eq (TcError' op)
forall op. Eq op => TcError' op -> TcError' op -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TcError' op -> TcError' op -> Bool
$c/= :: forall op. Eq op => TcError' op -> TcError' op -> Bool
== :: TcError' op -> TcError' op -> Bool
$c== :: forall op. Eq op => TcError' op -> TcError' op -> Bool
Eq, (forall x. TcError' op -> Rep (TcError' op) x)
-> (forall x. Rep (TcError' op) x -> TcError' op)
-> Generic (TcError' op)
forall x. Rep (TcError' op) x -> TcError' op
forall x. TcError' op -> Rep (TcError' op) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall op x. Rep (TcError' op) x -> TcError' op
forall op x. TcError' op -> Rep (TcError' op) x
$cto :: forall op x. Rep (TcError' op) x -> TcError' op
$cfrom :: forall op x. TcError' op -> Rep (TcError' op) x
Generic)
newtype TCOpSeq op = TCOpSeq [TypeCheckedOp op]
deriving newtype (Int -> TCOpSeq op -> ShowS
[TCOpSeq op] -> ShowS
TCOpSeq op -> String
(Int -> TCOpSeq op -> ShowS)
-> (TCOpSeq op -> String)
-> ([TCOpSeq op] -> ShowS)
-> Show (TCOpSeq op)
forall op. Show op => Int -> TCOpSeq op -> ShowS
forall op. Show op => [TCOpSeq op] -> ShowS
forall op. Show op => TCOpSeq op -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TCOpSeq op] -> ShowS
$cshowList :: forall op. Show op => [TCOpSeq op] -> ShowS
show :: TCOpSeq op -> String
$cshow :: forall op. Show op => TCOpSeq op -> String
showsPrec :: Int -> TCOpSeq op -> ShowS
$cshowsPrec :: forall op. Show op => Int -> TCOpSeq op -> ShowS
Show, TCOpSeq op -> TCOpSeq op -> Bool
(TCOpSeq op -> TCOpSeq op -> Bool)
-> (TCOpSeq op -> TCOpSeq op -> Bool) -> Eq (TCOpSeq op)
forall op. Eq op => TCOpSeq op -> TCOpSeq op -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TCOpSeq op -> TCOpSeq op -> Bool
$c/= :: forall op. Eq op => TCOpSeq op -> TCOpSeq op -> Bool
== :: TCOpSeq op -> TCOpSeq op -> Bool
$c== :: forall op. Eq op => TCOpSeq op -> TCOpSeq op -> Bool
Eq)
deriving stock ((forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b)
-> (forall a b. a -> TCOpSeq b -> TCOpSeq a) -> Functor TCOpSeq
forall a b. a -> TCOpSeq b -> TCOpSeq a
forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TCOpSeq b -> TCOpSeq a
$c<$ :: forall a b. a -> TCOpSeq b -> TCOpSeq a
fmap :: forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b
$cfmap :: forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b
Functor, (forall x. TCOpSeq op -> Rep (TCOpSeq op) x)
-> (forall x. Rep (TCOpSeq op) x -> TCOpSeq op)
-> Generic (TCOpSeq op)
forall x. Rep (TCOpSeq op) x -> TCOpSeq op
forall x. TCOpSeq op -> Rep (TCOpSeq op) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall op x. Rep (TCOpSeq op) x -> TCOpSeq op
forall op x. TCOpSeq op -> Rep (TCOpSeq op) x
$cto :: forall op x. Rep (TCOpSeq op) x -> TCOpSeq op
$cfrom :: forall op x. TCOpSeq op -> Rep (TCOpSeq op) x
Generic)
deriving anyclass TCOpSeq op -> ()
(TCOpSeq op -> ()) -> NFData (TCOpSeq op)
forall op. NFData op => TCOpSeq op -> ()
forall a. (a -> ()) -> NFData a
rnf :: TCOpSeq op -> ()
$crnf :: forall op. NFData op => TCOpSeq op -> ()
NFData
instance RenderDoc op => RenderDoc (TCOpSeq op) where
renderDoc :: RenderContext -> TCOpSeq op -> Doc
renderDoc RenderContext
_ (TCOpSeq [TypeCheckedOp op]
ops) = Bool -> [TypeCheckedOp op] -> Doc
forall op (f :: * -> *).
(RenderDoc op, Foldable f) =>
Bool -> f op -> Doc
renderOpsListNoBraces Bool
False [TypeCheckedOp op]
ops
type TcError = TcError' U.ExpandedOp
instance (NFData op, NFData (TypeCheckedOp op)) => NFData (TcError' op)
instance (RenderDoc op, Buildable op) => Buildable (TcError' op) where
build :: TcError' op -> Doc
build = \case
TcFailedOnInstr InstrAbstract [] op
instr (SomeHST HST ts
t) ErrorSrcPos
ics Maybe TypeContext
mbTCTypeContext Maybe TcTypeError
mbTcTypeError -> [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"Error checking expression:"
Doc -> Doc -> Doc
<$> Doc -> Doc
surroundWithNewLines (InstrAbstract [] op -> Doc
forall a. Buildable a => a -> Doc
build InstrAbstract [] op
instr)
, Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"against input stack type:"
Doc -> Doc -> Doc
<$> Doc -> Doc
surroundWithNewLines (HST ts -> Doc
forall a. Buildable a => a -> Doc
build HST ts
t)
, Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF
(Doc -> (TypeContext -> Doc) -> Maybe TypeContext -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty ((Doc
"Error in" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (TypeContext -> Doc) -> TypeContext -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeContext -> Doc
forall a. Buildable a => a -> Doc
build) Maybe TypeContext
mbTCTypeContext)
(Maybe TcTypeError -> Doc
forall a. Buildable a => a -> Doc
build Maybe TcTypeError
mbTcTypeError)
, ErrorSrcPos -> Doc
forall a. Buildable a => a -> Doc
build ErrorSrcPos
ics
]
TcFailedOnValue Value' [] op
v T
t Text
custom ErrorSrcPos
ics Maybe TcTypeError
mbTcTypeError -> Int -> Doc -> Doc
forall ann. Int -> Doc ann -> Doc ann
PP.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Bool) -> [Doc] -> [Doc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Doc -> Bool) -> Doc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Bool
isEmpty)
[ Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Error checking value" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Value' [] op -> Doc
forall a. Buildable a => a -> Doc
build Value' [] op
v
, Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Against type" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ T -> Doc
forall a. Buildable a => a -> Doc
build T
t
, Text -> Doc
forall a. Buildable a => a -> Doc
build Text
custom
, Maybe TcTypeError -> Doc
forall a. Buildable a => a -> Doc
build Maybe TcTypeError
mbTcTypeError
, ErrorSrcPos -> Doc
forall a. Buildable a => a -> Doc
build ErrorSrcPos
ics
]
TcContractError Text
msg Maybe TcTypeError
typeError -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Error occurred during contract typecheck" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
Text -> Doc
forall a. Buildable a => a -> Doc
build Text
msg Doc -> Doc -> Doc
<$> Maybe TcTypeError -> Doc
forall a. Buildable a => a -> Doc
build Maybe TcTypeError
typeError
TcViewError Text
msg ViewName
viewName Maybe TcTypeError
typeError -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF
(Doc
"Error occurred during typecheck of view " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ViewName -> Doc
forall a. Buildable a => a -> Doc
build ViewName
viewName) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
Text -> Doc
forall a. Buildable a => a -> Doc
build Text
msg Doc -> Doc -> Doc
<$> Maybe TcTypeError -> Doc
forall a. Buildable a => a -> Doc
build Maybe TcTypeError
typeError
TcUnreachableCode ErrorSrcPos
ics NonEmpty op
instrs -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Unreachable code" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
Int -> [op] -> Doc
forall {a}. RenderDoc a => Int -> [a] -> Doc
buildTruncated Int
3 (NonEmpty op -> [Element (NonEmpty op)]
forall t. Container t => t -> [Element t]
toList NonEmpty op
instrs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
forall ann. Doc ann
hardline Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ErrorSrcPos -> Doc
forall a. Buildable a => a -> Doc
build ErrorSrcPos
ics
TcExtError (SomeHST HST ts
t) ErrorSrcPos
ics ExtError
e -> Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF
Doc
"Error occurred during Morley extension typecheck" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
PP.vsep
[ ExtError -> Doc
forall a. Buildable a => a -> Doc
build ExtError
e
, Doc
"on stack"
, HST ts -> Doc
forall a. Buildable a => a -> Doc
build HST ts
t
, ErrorSrcPos -> Doc
forall a. Buildable a => a -> Doc
build ErrorSrcPos
ics
]
TcIncompletelyTyped TcError' op
err Contract' (TCOpSeq op)
contract ->
RenderContext -> Contract' (TCOpSeq op) -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens Contract' (TCOpSeq op)
contract Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
PP.linebreak
Doc -> Doc -> Doc
<$> TcError' op -> Doc
forall a. Buildable a => a -> Doc
build TcError' op
err
TcIncompletelyTypedView TcError' op
err View' (TCOpSeq op)
_view -> TcError' op -> Doc
forall a. Buildable a => a -> Doc
build TcError' op
err
TcDeprecatedType Text
err T
ty ->
Doc -> Doc -> Doc
forall a. Buildable a => Doc -> a -> Doc
nameF Doc
"Found deprecated type" (RenderContext -> T -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens T
ty)
Doc -> Doc -> Doc
<$> RenderContext -> Text -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens Text
err
where
buildTruncated :: Int -> [a] -> Doc
buildTruncated Int
k =
Doc -> Doc
forall ann. Doc ann -> Doc ann
PP.align (Doc -> Doc) -> ([a] -> Doc) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [Doc] -> Doc
forall op (f :: * -> *).
(RenderDoc op, Foldable f) =>
Bool -> f op -> Doc
renderOpsListNoBraces Bool
False ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> [Doc]
trunc ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RenderContext -> a -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens)
where
trunc :: [Doc] -> [Doc]
trunc (Int -> [Doc] -> ([Doc], [Doc])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
k -> ([Doc]
h, [Doc]
t))
| [Doc] -> Bool
forall t. Container t => t -> Bool
null [Doc]
t = [Doc]
h
| Bool
otherwise = [Doc]
h [Doc] -> [Doc] -> [Doc]
forall a. Semigroup a => a -> a -> a
<> [Doc
"..."]
surroundWithNewLines :: Doc -> Doc
surroundWithNewLines :: Doc -> Doc
surroundWithNewLines = Doc -> Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
PP.enclose Doc
PP.linebreak Doc
PP.linebreak
instance Exception TcError where
displayException :: TcError -> String
displayException = TcError -> String
forall a b. (Buildable a, FromDoc b) => a -> b
pretty
newtype StackSize = StackSize Natural
deriving stock (Int -> StackSize -> ShowS
[StackSize] -> ShowS
StackSize -> String
(Int -> StackSize -> ShowS)
-> (StackSize -> String)
-> ([StackSize] -> ShowS)
-> Show StackSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StackSize] -> ShowS
$cshowList :: [StackSize] -> ShowS
show :: StackSize -> String
$cshow :: StackSize -> String
showsPrec :: Int -> StackSize -> ShowS
$cshowsPrec :: Int -> StackSize -> ShowS
Show, StackSize -> StackSize -> Bool
(StackSize -> StackSize -> Bool)
-> (StackSize -> StackSize -> Bool) -> Eq StackSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StackSize -> StackSize -> Bool
$c/= :: StackSize -> StackSize -> Bool
== :: StackSize -> StackSize -> Bool
$c== :: StackSize -> StackSize -> Bool
Eq, (forall x. StackSize -> Rep StackSize x)
-> (forall x. Rep StackSize x -> StackSize) -> Generic StackSize
forall x. Rep StackSize x -> StackSize
forall x. StackSize -> Rep StackSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep StackSize x -> StackSize
$cfrom :: forall x. StackSize -> Rep StackSize x
Generic)
instance NFData StackSize
instance Buildable StackSize where
build :: StackSize -> Doc
build (StackSize Natural
n) = Doc
"stack size " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Natural
n Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
data ExtError =
LengthMismatch U.StackTypePattern
| TypeMismatch U.StackTypePattern Int TcTypeError
| StkRestMismatch U.StackTypePattern SomeHST SomeHST TcTypeError
| TestAssertError Text
| InvalidStackReference U.StackRef StackSize
deriving stock (Int -> ExtError -> ShowS
[ExtError] -> ShowS
ExtError -> String
(Int -> ExtError -> ShowS)
-> (ExtError -> String) -> ([ExtError] -> ShowS) -> Show ExtError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtError] -> ShowS
$cshowList :: [ExtError] -> ShowS
show :: ExtError -> String
$cshow :: ExtError -> String
showsPrec :: Int -> ExtError -> ShowS
$cshowsPrec :: Int -> ExtError -> ShowS
Show, ExtError -> ExtError -> Bool
(ExtError -> ExtError -> Bool)
-> (ExtError -> ExtError -> Bool) -> Eq ExtError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtError -> ExtError -> Bool
$c/= :: ExtError -> ExtError -> Bool
== :: ExtError -> ExtError -> Bool
$c== :: ExtError -> ExtError -> Bool
Eq, (forall x. ExtError -> Rep ExtError x)
-> (forall x. Rep ExtError x -> ExtError) -> Generic ExtError
forall x. Rep ExtError x -> ExtError
forall x. ExtError -> Rep ExtError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExtError x -> ExtError
$cfrom :: forall x. ExtError -> Rep ExtError x
Generic)
instance NFData ExtError
instance Buildable ExtError where
build :: ExtError -> Doc
build = \case
LengthMismatch StackTypePattern
stk ->
Doc
"Unexpected length of stack: pattern "
Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| StackTypePattern
stk StackTypePattern -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" has length "
Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| ([TyVar] -> Int
forall i a.
(Integral i, Container a, CheckIntSubType Length i,
DefaultToInt (IsIntSubType Length i) i) =>
a -> i
length ([TyVar] -> Int)
-> (StackTypePattern -> [TyVar]) -> StackTypePattern -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TyVar], Bool) -> [TyVar]
forall a b. (a, b) -> a
fst (([TyVar], Bool) -> [TyVar])
-> (StackTypePattern -> ([TyVar], Bool))
-> StackTypePattern
-> [TyVar]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackTypePattern -> ([TyVar], Bool)
U.stackTypePatternToList) StackTypePattern
stk Int -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
TypeMismatch StackTypePattern
stk Int
i TcTypeError
e ->
Doc
"TypeMismatch: Pattern " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| StackTypePattern
stk StackTypePattern -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" at index "
Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Int
i Int -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" with error: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TcTypeError
e TcTypeError -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
StkRestMismatch StackTypePattern
stk (SomeHST HST ts
r) (SomeHST HST ts
r') TcTypeError
e ->
Doc
"StkRestMismatch in pattern " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| StackTypePattern
stk StackTypePattern -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+
Doc
" against stacks " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| HST ts
r HST ts -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" and " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| HST ts
r' HST ts -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+
Doc
" with error: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| TcTypeError
e TcTypeError -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
TestAssertError Text
t ->
Doc
"TestAssertError: " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Text
t Text -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
InvalidStackReference StackRef
i StackSize
lhs ->
Doc
"InvalidStackReference: reference is out of the stack: "
Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| StackRef
i StackRef -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
" >= " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| StackSize
lhs StackSize -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
pairWithNodeIndex :: Word -> Text
pairWithNodeIndex :: Word -> Text
pairWithNodeIndex = \case
Word
0 -> Text
"'a"
Word
ix -> Word -> Text
pairWithElems (Word -> Word
minPairLength Word
ix)
where
minPairLength :: Word -> Word
minPairLength :: Word -> Word
minPairLength = \case
Word
0 -> Word
2
Word
ix -> (Word
ix Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
3) Word -> Word -> Word
forall a. Integral a => a -> a -> a
`div` Word
2
pairWithElems :: Word -> Text
pairWithElems :: Word -> Text
pairWithElems Word
n =
Text
"pair "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
" " ([Word
1 .. Word
n] [Word] -> (Word -> Text) -> [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Word
i -> Text
"'a" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word -> Text
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show Word
i))