module Michelson.TypeCheck.Error
( TypeContext (..)
, TCTypeError (..)
, TCError (..)
, ExtError (..)
, StackSize (..)
, pairWithNodeIndex
, pairWithElems
) where
import Fmt (Buildable(..), listF, pretty, unlinesF, (+|), (+||), (|+), (||+))
import qualified Text.Show (show)
import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..))
import Michelson.Printer.Util (doesntNeedParens, printDocB, renderDoc)
import Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp)
import Michelson.TypeCheck.Types (SomeHST(..))
import qualified Michelson.Typed as T
import Michelson.Typed.Annotation (AnnConvergeError(..))
import Michelson.Typed.Extract (toUType)
import Michelson.Typed.T (buildStack)
import Michelson.Untyped (StackFn, Ty, Var)
import qualified Michelson.Untyped as U
import Tezos.Address (Address)
import Tezos.Crypto (CryptoParseError)
import qualified Tezos.Crypto.BLS12381 as BLS
data TypeContext
= LambdaArgument
| LambdaCode
| DipCode
| ConsArgument
| ComparisonArguments
| ContractParameter
| ContractStorage
| ArithmeticOperation
| Iteration
| Cast
| CarArgument
| CdrArgument
| If
| ConcatArgument
| ContainerKeyType
| ContainerValueType
| FailwithArgument
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 -> Builder
build = \case
TypeContext
LambdaArgument -> Builder
"argument to some lambda"
TypeContext
LambdaCode -> Builder
"code in LAMBDA"
TypeContext
DipCode -> Builder
"code in DIP"
TypeContext
ConsArgument -> Builder
"argument to CONS"
TypeContext
ComparisonArguments -> Builder
"arguments to comparison function"
TypeContext
ContractParameter -> Builder
"contract parameter"
TypeContext
ContractStorage -> Builder
"contract storage"
TypeContext
ArithmeticOperation -> Builder
"arguments to arithmetic operation"
TypeContext
Iteration -> Builder
"iteration (ITER / MAP / etc) code"
TypeContext
Cast -> Builder
"argument to CAST"
TypeContext
CarArgument -> Builder
"argument to CAR"
TypeContext
CdrArgument -> Builder
"argument to CDR"
TypeContext
If -> Builder
"conditional expression"
TypeContext
ConcatArgument -> Builder
"argument to CONCAT"
TypeContext
ContainerKeyType -> Builder
"container key type"
TypeContext
ContainerValueType -> Builder
"container value type"
TypeContext
FailwithArgument -> Builder
"argument to FAILWITH"
data TCTypeError
= AnnError AnnConvergeError
| TypeEqError T.T T.T
| StackEqError [T.T] [T.T]
| UnsupportedTypeForScope T.T T.BadTypeForScope
| NotNumericTypes T.T T.T
| UnexpectedType (NonEmpty (NonEmpty Text))
| InvalidInstruction U.ExpandedInstr Text
| InvalidValueType T.T
| NotEnoughItemsOnStack
| IllegalEntrypoint T.EpNameFromRefAnnError
| UnknownContract Address
| EntrypointNotFound T.EpName
| IllegalParamDecl T.ParamEpError
| NegativeNat
| MutezOverflow
| InvalidAddress T.ParseEpAddressError
| InvalidKeyHash CryptoParseError
| InvalidBls12381Object BLS.DeserializationError
| InvalidTimestamp
| CodeAlwaysFails
| EmptyCode
| AnyError
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 -> Builder
build = \case
AnnError AnnConvergeError
e -> AnnConvergeError -> Builder
forall p. Buildable p => p -> Builder
build AnnConvergeError
e
TypeEqError T
type1 T
type2 ->
Builder
"Types not equal: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
type1 T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" /= " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
type2 T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
StackEqError [T]
st1 [T]
st2 ->
Builder
"Stacks not equal: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| [T] -> Builder
buildStack [T]
st1 Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" /= " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| [T] -> Builder
buildStack [T]
st2 Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
UnsupportedTypeForScope T
typ BadTypeForScope
reason ->
Builder
"Type '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
typ T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"' is unsupported here because it "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| BadTypeForScope
reason BadTypeForScope -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
NotNumericTypes T
t1 T
t2 ->
Builder
"Some of the types in an arithmetic operation are not numeric: "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
t1 T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" and " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
t2 T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
UnexpectedType (NonEmpty Text
t :| [NonEmpty Text]
ts) ->
Builder
"Wrong stack type for instruction, expect stack type to begin with " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|
( String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or "
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (NonEmpty Text -> String) -> [NonEmpty Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
x :| [Text]
xs) -> Builder
"" Builder -> Builder -> String
forall b. FromBuilder b => Builder -> Builder -> b
+| [Text] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"")
([NonEmpty Text] -> [String]) -> [NonEmpty Text] -> [String]
forall a b. (a -> b) -> a -> b
$ (NonEmpty Text
tNonEmpty Text -> [NonEmpty Text] -> [NonEmpty Text]
forall a. a -> [a] -> [a]
:[NonEmpty Text]
ts)
) String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
InvalidInstruction ExpandedInstr
instr Text
reason -> [Text] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
[ Builder
"Invalid instruction " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| ExpandedInstr
instr ExpandedInstr -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
, Text
"Reason: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
]
InvalidValueType T
t ->
Builder
"Value type is never a valid `" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T
t T -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"`"
TCTypeError
NotEnoughItemsOnStack ->
Builder
"Not enough items on stack"
UnknownContract Address
addr ->
Builder
"Contract is not registered: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Address
addr Address -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
IllegalEntrypoint EpNameFromRefAnnError
err -> EpNameFromRefAnnError -> Builder
forall p. Buildable p => p -> Builder
build EpNameFromRefAnnError
err
EntrypointNotFound EpName
ep ->
Builder
"No such entrypoint '" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| EpName
ep EpName -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"'"
IllegalParamDecl ParamEpError
err -> ParamEpError -> Builder
forall p. Buildable p => p -> Builder
build ParamEpError
err
TCTypeError
NegativeNat -> Builder
"Natural number cannot be negative"
TCTypeError
MutezOverflow -> Builder
"Exceeds maximal value for mutez"
InvalidAddress ParseEpAddressError
e -> ParseEpAddressError -> Builder
forall p. Buildable p => p -> Builder
build ParseEpAddressError
e
InvalidKeyHash CryptoParseError
e -> CryptoParseError -> Builder
forall p. Buildable p => p -> Builder
build CryptoParseError
e
InvalidBls12381Object DeserializationError
e -> DeserializationError -> Builder
forall p. Buildable p => p -> Builder
build DeserializationError
e
TCTypeError
InvalidTimestamp -> Builder
"Is not a valid RFC3339 timestamp"
TCTypeError
CodeAlwaysFails ->
Builder
"Cannot use a terminate instruction (like FAILWITH) as part of another \
\instruction's body"
TCTypeError
EmptyCode -> Builder
"Code block is empty"
TCTypeError
AnyError -> Builder
"Some of the arguments have invalid types"
data TCError
= TCFailedOnInstr U.ExpandedInstr SomeHST InstrCallStack (Maybe TypeContext) (Maybe TCTypeError)
| TCFailedOnValue U.Value T.T Text InstrCallStack (Maybe TCTypeError)
| TCContractError Text (Maybe TCTypeError)
| TCUnreachableCode InstrCallStack (NonEmpty U.ExpandedOp)
| TCExtError SomeHST InstrCallStack ExtError
| TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)
deriving stock (TCError -> TCError -> Bool
(TCError -> TCError -> Bool)
-> (TCError -> TCError -> Bool) -> Eq TCError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TCError -> TCError -> Bool
$c/= :: TCError -> TCError -> Bool
== :: TCError -> TCError -> Bool
$c== :: TCError -> TCError -> Bool
Eq, (forall x. TCError -> Rep TCError x)
-> (forall x. Rep TCError x -> TCError) -> Generic TCError
forall x. Rep TCError x -> TCError
forall x. TCError -> Rep TCError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TCError x -> TCError
$cfrom :: forall x. TCError -> Rep TCError x
Generic)
instance NFData TCError
instance Buildable TCError where
build :: TCError -> Builder
build = \case
TCFailedOnInstr ExpandedInstr
instr (SomeHST HST ts
t) InstrCallStack
ics Maybe TypeContext
mbTCTypeContext Maybe TCTypeError
mbTCTypeError ->
Builder
"Error checking expression "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ExpandedInstr
instr ExpandedInstr -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" against input stack type "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| HST ts
t HST ts -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder -> (TypeContext -> Builder) -> Maybe TypeContext -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (\TypeContext
c -> Builder
". Error in " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TypeContext
c TypeContext -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"") Maybe TypeContext
mbTCTypeContext
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Builder -> (TCTypeError -> Builder) -> Maybe TCTypeError -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
". " (\TCTypeError
e -> Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
". ") Maybe TCTypeError
mbTCTypeError
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| InstrCallStack -> Builder
forall b. FromBuilder b => InstrCallStack -> b
buildCallStack InstrCallStack
ics
TCFailedOnValue Value
v T
t Text
custom InstrCallStack
ics Maybe TCTypeError
mbTCTypeError ->
Builder
"Error checking value "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Value
v Value -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" against type "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| T -> Ty
toUType T
t Ty -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder -> Builder -> Bool -> Builder
forall a. a -> a -> Bool -> a
bool (Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
custom Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" ") Builder
"." (Text -> Bool
forall t. Container t => t -> Bool
null Text
custom)
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| (Builder -> (TCTypeError -> Builder) -> Maybe TCTypeError -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (\TCTypeError
e -> Builder
"\n" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
".\n") Maybe TCTypeError
mbTCTypeError)
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| InstrCallStack -> Builder
forall b. FromBuilder b => InstrCallStack -> b
buildCallStack InstrCallStack
ics
TCContractError Text
msg Maybe TCTypeError
typeError ->
Builder
"Error occurred during contract typecheck: "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| Text
msg Text -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ (Builder -> (TCTypeError -> Builder) -> Maybe TCTypeError -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (\TCTypeError
e -> Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"") Maybe TCTypeError
typeError)
TCUnreachableCode InstrCallStack
ics NonEmpty ExpandedOp
instrs ->
Builder
"Unreachable code: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Int -> [ExpandedOp] -> Builder
forall a. Buildable [a] => Int -> [a] -> Builder
buildTruncated Int
3 (NonEmpty ExpandedOp -> [Element (NonEmpty ExpandedOp)]
forall t. Container t => t -> [Element t]
toList NonEmpty ExpandedOp
instrs) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
". "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| InstrCallStack -> Builder
forall b. FromBuilder b => InstrCallStack -> b
buildCallStack InstrCallStack
ics
TCExtError (SomeHST HST ts
t) InstrCallStack
ics ExtError
e ->
Builder
"Error occurred during Morley extension typecheck: "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ExtError
e ExtError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" on stack " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| HST ts
t HST ts -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
". "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| InstrCallStack -> Builder
forall b. FromBuilder b => InstrCallStack -> b
buildCallStack InstrCallStack
ics
TCIncompletelyTyped TCError
err Contract' TypeCheckedOp
contract ->
Builder
"\n"
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Bool -> Doc -> Builder
printDocB Bool
False (RenderContext -> Contract' TypeCheckedOp -> Doc
forall a. RenderDoc a => RenderContext -> a -> Doc
renderDoc RenderContext
doesntNeedParens Contract' TypeCheckedOp
contract) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n"
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCError -> Builder
forall p. Buildable p => p -> Builder
build TCError
err
where
buildTruncated :: Int -> [a] -> Builder
buildTruncated Int
k [a]
l
| [a] -> Bool
forall t. Container t => t -> Bool
null (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
k [a]
l) = [a] -> Builder
forall p. Buildable p => p -> Builder
build [a]
l
| Bool
otherwise = [a] -> Builder
forall p. Buildable p => p -> Builder
build (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
k [a]
l) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" ..."
buildCallStack :: InstrCallStack -> b
buildCallStack InstrCallStack{LetCallStack
icsCallStack :: InstrCallStack -> LetCallStack
icsCallStack :: LetCallStack
icsCallStack, icsSrcPos :: InstrCallStack -> SrcPos
icsSrcPos = SrcPos (Pos Word
line) (Pos Word
col)} =
Builder
"Error occurred on line " Builder -> Builder -> b
forall b. FromBuilder b => Builder -> Builder -> b
+| Word
line Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1 Word -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" char " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Word
col Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1 Word -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| case LetCallStack
icsCallStack of
[] -> Builder
"."
LetCallStack
_ -> Builder
" inside these let defenitions: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| LetCallStack -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
listF LetCallStack
icsCallStack Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"."
instance Show TCError where
show :: TCError -> String
show = TCError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty
instance Exception TCError
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
data ExtError =
LengthMismatch U.StackTypePattern
| VarError Text StackFn
| TypeMismatch U.StackTypePattern Int TCTypeError
| TyVarMismatch Var Ty U.StackTypePattern Int TCTypeError
| StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError
| TestAssertError Text
| InvalidStackReference U.StackRef StackSize
deriving stock (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 -> Builder
build = \case
LengthMismatch StackTypePattern
stk ->
Builder
"Unexpected length of stack: pattern "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackTypePattern
stk StackTypePattern -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" has length "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ([TyVar] -> Int
forall t. Container t => t -> Int
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 -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
VarError Text
t StackFn
sf ->
Builder
"In defenition of " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
t Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
": VarError "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackFn
sf StackFn -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
TypeMismatch StackTypePattern
stk Int
i TCTypeError
e ->
Builder
"TypeMismatch: Pattern " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackTypePattern
stk StackTypePattern -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" at index "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
i Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" with error: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
TyVarMismatch Var
v Ty
t StackTypePattern
stk Int
i TCTypeError
e ->
Builder
"TyVarMismach: Variable " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Var
v Var -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" is bound to type "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Ty
t Ty -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" but pattern " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackTypePattern
stk StackTypePattern -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" failed at index "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
i Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" with error: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
StkRestMismatch StackTypePattern
stk (SomeHST HST ts
r) (SomeHST HST ts
r') TCTypeError
e ->
Builder
"StkRestMismatch in pattern " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackTypePattern
stk StackTypePattern -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+
Builder
" against stacks " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| HST ts
r HST ts -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" and " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| HST ts
r' HST ts -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+
Builder
" with error: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| TCTypeError
e TCTypeError -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
TestAssertError Text
t ->
Builder
"TestAssertError: " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
t Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
InvalidStackReference StackRef
i StackSize
lhs ->
Builder
"InvalidStackReference: reference is out of the stack: "
Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackRef
i StackRef -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" >= " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| StackSize
lhs StackSize -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
""
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. (Show a, IsString b) => a -> b
show Word
i))