-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Errors that can occur when some code is being typechecked.

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

-- | Contexts where type error can occur.
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
$cshowsPrec :: Int -> TypeContext -> ShowS
showsPrec :: Int -> TypeContext -> ShowS
$cshow :: TypeContext -> String
show :: TypeContext -> String
$cshowList :: [TypeContext] -> ShowS
showList :: [TypeContext] -> ShowS
Show, TypeContext -> TypeContext -> Bool
(TypeContext -> TypeContext -> Bool)
-> (TypeContext -> TypeContext -> Bool) -> Eq TypeContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TypeContext -> TypeContext -> Bool
== :: TypeContext -> TypeContext -> Bool
$c/= :: TypeContext -> TypeContext -> Bool
/= :: 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
$cfrom :: forall x. TypeContext -> Rep TypeContext x
from :: forall x. TypeContext -> Rep TypeContext x
$cto :: forall x. Rep TypeContext x -> TypeContext
to :: forall x. Rep TypeContext x -> TypeContext
Generic)
  deriving anyclass (TypeContext -> ()
(TypeContext -> ()) -> NFData TypeContext
forall a. (a -> ()) -> NFData a
$crnf :: TypeContext -> ()
rnf :: 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
$cshowsPrec :: Int -> TopLevelType -> ShowS
showsPrec :: Int -> TopLevelType -> ShowS
$cshow :: TopLevelType -> String
show :: TopLevelType -> String
$cshowList :: [TopLevelType] -> ShowS
showList :: [TopLevelType] -> ShowS
Show, TopLevelType -> TopLevelType -> Bool
(TopLevelType -> TopLevelType -> Bool)
-> (TopLevelType -> TopLevelType -> Bool) -> Eq TopLevelType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TopLevelType -> TopLevelType -> Bool
== :: TopLevelType -> TopLevelType -> Bool
$c/= :: TopLevelType -> TopLevelType -> Bool
/= :: 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
$cfrom :: forall x. TopLevelType -> Rep TopLevelType x
from :: forall x. TopLevelType -> Rep TopLevelType x
$cto :: forall x. Rep TopLevelType x -> TopLevelType
to :: forall x. Rep TopLevelType x -> TopLevelType
Generic)
  deriving anyclass (TopLevelType -> ()
(TopLevelType -> ()) -> NFData TopLevelType
forall a. (a -> ()) -> NFData a
$crnf :: TopLevelType -> ()
rnf :: TopLevelType -> ()
NFData)

instance Buildable TopLevelType where
  build :: TopLevelType -> Doc
build = \case
    TopLevelType
TltParameterType -> Doc
"parameter"
    TopLevelType
TltStorageType -> Doc
"storage"

-- | Data type that represents various errors
-- which are related to type system.
-- These errors are used to specify info about type check errors
-- in @TcError@ data type.
data TcTypeError
  = TypeEqError (MismatchError T.T)
  -- ^ Type equality error
  | StackEqError (MismatchError [T.T])
  -- ^ Stacks equality error
  | UnsupportedTypeForScope T.T T.BadTypeForScope
  -- ^ Error that happens when type cannot be used in the corresponding scope.
  -- Argument of this constructor carries type which violates
  -- the restriction, e.g. @big_map@ in @UNPACK@, and a concrete reason why the
  -- type is unsuported.
  | NotNumericTypes T.T T.T
  -- ^ Arithmetic operation is applied to types, at least one of which is not numeric
  -- (e.g. @timestamp@ and @timestamp@ passed to @MUL@ instruction).
  | UnexpectedType (NonEmpty (NonEmpty Text))
  -- ^ Error that happens when actual types are different from the type that instruction expects.
  -- The param is an non-empty list of all expected stack types that the instruction would accept.
  -- Each expected stack types is represented as non-empty list as well.
  | UnexpectedTopLevelType TopLevelType (MismatchError T.T)
  -- ^ Error that happens when the caller expected one top-level type, but
  -- the contract has another type specified.
  | InvalidInstruction (U.InstrAbstract [] ()) Text
  -- ^ Some instruction is invalid or used in an invalid way.
  -- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.
  --
  -- The 'Text' argument is a user-readable explanation of why this instruction is invalid.
  --
  -- Since this makes sense only for primitive instructions, we keep
  -- @U.InstrAbstract@ with @()@ type argument.
  | InvalidValueType T.T
  -- ^ Error that happens when a `U.Value` is never a valid source for this type
  -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)
  | NotEnoughItemsOnStack
  -- ^ There are not enough items on stack to perform a certain instruction.
  | IllegalEntrypoint T.EpNameFromRefAnnError
  -- ^ Invalid entrypoint name provided
  | UnknownContract ContractAddress
  -- ^ Contract with given address is not originated.
  | EntrypointNotFound T.EpName
  -- ^ Given entrypoint is not present.
  | IllegalParamDecl T.ParamEpError
  -- ^ Incorrect parameter declaration (with respect to entrypoints feature).
  | NegativeNat
  -- ^ Natural numbers cannot be negative
  | MutezOverflow
  -- ^ Exceeds the maximal mutez value
  | InvalidAddress T.ParseEpAddressError
  -- ^ Address couldn't be parsed from its textual representation
  | InvalidKeyHash CryptoParseError
  -- ^ KeyHash couldn't be parsed from its textual representation
  | InvalidBls12381Object BLS.DeserializationError
  -- ^ BLS12-381 primitive couldn't be parsed
  | InvalidTimestamp
  -- ^ Timestamp is not RFC339 compliant
  | CodeAlwaysFails
  -- ^ Code always fails, but shouldn't, like in ITER body.
  -- This is actually more general, any instruction that allows no continuation
  -- (like @NEVER@) cannot appear as part of another instruction's body.
  | EmptyCode
  -- ^ Empty block of code, like ITER body.
  | AnyError
  -- ^ Generic error when instruction does not match something sensible.
  | InvalidBigMapId Integer
  -- ^ A big_map with the given ID was not found.
  | UnexpectedBigMapType
  -- ^ We found a big_map with the given big_map ID, but
  -- its key and/or value types are not the same as the requested types.
      Integer -- ^ The big_map ID we used to lookup a big_map value.
      (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
$cshowsPrec :: Int -> TcTypeError -> ShowS
showsPrec :: Int -> TcTypeError -> ShowS
$cshow :: TcTypeError -> String
show :: TcTypeError -> String
$cshowList :: [TcTypeError] -> ShowS
showList :: [TcTypeError] -> ShowS
Show, TcTypeError -> TcTypeError -> Bool
(TcTypeError -> TcTypeError -> Bool)
-> (TcTypeError -> TcTypeError -> Bool) -> Eq TcTypeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TcTypeError -> TcTypeError -> Bool
== :: TcTypeError -> TcTypeError -> Bool
$c/= :: TcTypeError -> TcTypeError -> Bool
/= :: 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
$cfrom :: forall x. TcTypeError -> Rep TcTypeError x
from :: forall x. TcTypeError -> Rep TcTypeError x
$cto :: forall x. Rep TcTypeError x -> TcTypeError
to :: forall x. Rep TcTypeError x -> TcTypeError
Generic)
  deriving anyclass (TcTypeError -> ()
(TcTypeError -> ()) -> NFData TcTypeError
forall a. (a -> ()) -> NFData a
$crnf :: TcTypeError -> ()
rnf :: 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 a b. (a -> b) -> [a] -> [b]
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

-- | Type check error
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
$cshowsPrec :: forall op. Show op => Int -> TcError' op -> ShowS
showsPrec :: Int -> TcError' op -> ShowS
$cshow :: forall op. Show op => TcError' op -> String
show :: TcError' op -> String
$cshowList :: forall op. Show op => [TcError' op] -> ShowS
showList :: [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
$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
/= :: 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
$cfrom :: forall op x. TcError' op -> Rep (TcError' op) x
from :: forall x. TcError' op -> Rep (TcError' op) x
$cto :: forall op x. Rep (TcError' op) x -> TcError' op
to :: forall x. Rep (TcError' op) x -> TcError' op
Generic)

-- | Used to smooth out the impedance mismatch between instruction arguments,
-- which must be sequences, and contract/view code which can be a singular
-- instruction. Only used for error reporting, as in general this isn't valid.
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
$cshowsPrec :: forall op. Show op => Int -> TCOpSeq op -> ShowS
showsPrec :: Int -> TCOpSeq op -> ShowS
$cshow :: forall op. Show op => TCOpSeq op -> String
show :: TCOpSeq op -> String
$cshowList :: forall op. Show op => [TCOpSeq op] -> ShowS
showList :: [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
$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
/= :: 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
$cfmap :: forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b
fmap :: forall a b. (a -> b) -> TCOpSeq a -> TCOpSeq b
$c<$ :: forall a b. a -> TCOpSeq b -> TCOpSeq a
<$ :: forall a b. a -> TCOpSeq b -> TCOpSeq a
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
$cfrom :: forall op x. TCOpSeq op -> Rep (TCOpSeq op) x
from :: forall x. TCOpSeq op -> Rep (TCOpSeq op) x
$cto :: forall op x. Rep (TCOpSeq op) x -> TCOpSeq op
to :: forall x. Rep (TCOpSeq op) x -> TCOpSeq op
Generic)
  deriving anyclass TCOpSeq op -> ()
(TCOpSeq op -> ()) -> NFData (TCOpSeq op)
forall op. NFData op => TCOpSeq op -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall op. NFData op => TCOpSeq op -> ()
rnf :: 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 a b. (a -> b) -> [a] -> [b]
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
$cshowsPrec :: Int -> StackSize -> ShowS
showsPrec :: Int -> StackSize -> ShowS
$cshow :: StackSize -> String
show :: StackSize -> String
$cshowList :: [StackSize] -> ShowS
showList :: [StackSize] -> ShowS
Show, StackSize -> StackSize -> Bool
(StackSize -> StackSize -> Bool)
-> (StackSize -> StackSize -> Bool) -> Eq StackSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StackSize -> StackSize -> Bool
== :: StackSize -> StackSize -> Bool
$c/= :: StackSize -> StackSize -> Bool
/= :: 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
$cfrom :: forall x. StackSize -> Rep StackSize x
from :: forall x. StackSize -> Rep StackSize x
$cto :: forall x. Rep StackSize x -> StackSize
to :: forall x. Rep StackSize x -> StackSize
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
""

-- | Various type errors possible when checking Morley extension commands
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
$cshowsPrec :: Int -> ExtError -> ShowS
showsPrec :: Int -> ExtError -> ShowS
$cshow :: ExtError -> String
show :: ExtError -> String
$cshowList :: [ExtError] -> ShowS
showList :: [ExtError] -> ShowS
Show, ExtError -> ExtError -> Bool
(ExtError -> ExtError -> Bool)
-> (ExtError -> ExtError -> Bool) -> Eq ExtError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExtError -> ExtError -> Bool
== :: ExtError -> ExtError -> Bool
$c/= :: ExtError -> ExtError -> Bool
/= :: 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
$cfrom :: forall x. ExtError -> Rep ExtError x
from :: forall x. ExtError -> Rep ExtError x
$cto :: forall x. Rep ExtError x -> ExtError
to :: forall x. Rep ExtError x -> ExtError
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,
 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
""

----------------------------------------------------------------------------
-- Helpers for formatting types
----------------------------------------------------------------------------

-- | Given a node index @ix@, creates a string representing the
-- smallest possible right-combed pair with at least @ix+1@ nodes.
--
-- Since the node index 0 is valid even for non-pair values
-- (e.g. we can run @GET 0@ on a @string@ or an @int@),
-- we simply return a type variable @'a@ in this case.
--
-- >>> pairWithNodeIndex 0
-- "'a"
--
-- >>> pairWithNodeIndex 4
-- "pair 'a1 'a2 'a3"
--
-- >>> pairWithNodeIndex 5
-- "pair 'a1 'a2 'a3 'a4"
pairWithNodeIndex :: Word -> Text
pairWithNodeIndex :: Word -> Text
pairWithNodeIndex = \case
  Word
0 -> Text
"'a"
  Word
ix -> Word -> Text
pairWithElems (Word -> Word
minPairLength Word
ix)
  where
    -- Given a node index @ix@, calculates the minimum number of
    -- elements a pair must have for that index to be valid.
    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

-- | Given a number @n@, creates a string representing a
-- right-combed pair of arity @n@.
--
-- > pairType 3 == "pair 'a1 'a2 'a3"
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))