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

{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TypeFamilyDependencies #-}

-- We want to make sure 'failUsingArg' is used with sane argument.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Lorentz.Errors
  ( -- * Haskell to 'Value' conversion
    IsError (..)
  , ErrorScope
  , ConstantScope
  , isoErrorToVal
  , isoErrorFromVal
  , simpleFailUsing
  , ErrorHasDoc (..)
  , typeDocMdDescriptionReferToError
  , isInternalErrorClass

  , UnspecifiedError (..)
  , Impossible (..)
  , SomeError (..)

    -- * General instructions
  , failUnexpected

    -- * Custom errors
  , NoErrorArg
  , UnitErrorArg
  , ErrorArg
  , CustomError (..)
  , CustomErrorRep
  , IsCustomErrorArgRep (..)
  , MustHaveErrorArg
  , failCustom
  , failCustom_
  , failCustomNoArg

    -- * Documentation
  , ErrorClass (..)
  , CustomErrorHasDoc (..)
  , DError (..)
  , DThrows (..)

    -- * Internals
  , errorTagToText
  , errorTagToMText
  ) where

import Data.Char qualified as C
import Data.List qualified as L
import Fmt (Buildable, build, fmt, pretty, (+|), (|+))
import Language.Haskell.TH.Syntax (Lift)

import Lorentz.Base
import Lorentz.Doc
import Lorentz.Ext
import Lorentz.Instr hiding (cast)
import Lorentz.Value
import Morley.Michelson.Text
import Morley.Michelson.Typed.Convert (untypeValue)
import Morley.Michelson.Typed.Haskell
import Morley.Michelson.Typed.Instr
import Morley.Michelson.Typed.Scope
import Morley.Michelson.Typed.Sing (castM, castSingE)
import Morley.Util.Markdown
import Morley.Util.MismatchError
import Morley.Util.Type
import Morley.Util.TypeLits
import Morley.Util.Typeable

----------------------------------------------------------------------------
-- IsError
----------------------------------------------------------------------------

-- | Since 008 it's prohibited to fail with non-packable values and with the
-- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint.
-- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information.
type ErrorScope t = ConstantScope t

type KnownError a = ErrorScope (ToT a)

-- | Haskell type representing error.
class (ErrorHasDoc e) => IsError e where

  -- | Converts a Haskell error into @Value@ representation.
  errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r

  -- | Converts a @Value@ into Haskell error.
  errorFromVal :: (SingI t) => Value t -> Either Text e

  -- | Fail with the given Haskell value.
  failUsing :: (IsError e) => e -> s :-> t
  failUsing = e -> s :-> t
forall e (s :: [*]) (t :: [*]). IsError e => e -> s :-> t
simpleFailUsing

-- | Implementation of 'errorToVal' via 'IsoValue'.
isoErrorToVal
  :: (KnownError e, IsoValue e)
  => e -> (forall t. ErrorScope t => Value t -> r) -> r
isoErrorToVal :: forall e r.
(KnownError e, IsoValue e) =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
isoErrorToVal e
e forall (t :: T). ErrorScope t => Value t -> r
cont = Value (ToT e) -> r
forall (t :: T). ErrorScope t => Value t -> r
cont (Value (ToT e) -> r) -> Value (ToT e) -> r
forall a b. (a -> b) -> a -> b
$ e -> Value (ToT e)
forall a. IsoValue a => a -> Value (ToT a)
toVal e
e

-- | Implementation of 'errorFromVal' via 'IsoValue'.
isoErrorFromVal
  :: (SingI t, KnownIsoT e, IsoValue e)
  => Value t -> Either Text e
isoErrorFromVal :: forall (t :: T) e.
(SingI t, KnownIsoT e, IsoValue e) =>
Value t -> Either Text e
isoErrorFromVal Value t
e = Value' Instr (ToT e) -> e
forall a. IsoValue a => Value (ToT a) -> a
fromVal (Value' Instr (ToT e) -> e)
-> Either Text (Value' Instr (ToT e)) -> Either Text e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value t -> Either Text (Value' Instr (ToT e))
forall (a :: T) (b :: T) (t :: T -> *).
(SingI a, SingI b) =>
t a -> Either Text (t b)
castSingE Value t
e

-- | Basic implementation for 'failUsing'.
simpleFailUsing
  :: forall e s t.
     (IsError e)
  => e -> s :-> t
simpleFailUsing :: forall e (s :: [*]) (t :: [*]). IsError e => e -> s :-> t
simpleFailUsing e
err =
  e
-> (forall (t :: T). ErrorScope t => Value t -> s :-> t) -> s :-> t
forall e r.
IsError e =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal e
err ((forall (t :: T). ErrorScope t => Value t -> s :-> t) -> s :-> t)
-> (forall (t :: T). ErrorScope t => Value t -> s :-> t) -> s :-> t
forall a b. (a -> b) -> a -> b
$ \Value t
eval ->
    DThrows -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (Proxy e -> DThrows
forall e. ErrorHasDoc e => Proxy e -> DThrows
DThrows (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)) (s :-> s) -> (s :-> t) -> s :-> t
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
    ((forall (out' :: [T]). Instr (ToTs s) out') -> s :-> t
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI ((forall (out' :: [T]). Instr (ToTs s) out') -> s :-> t)
-> (forall (out' :: [T]). Instr (ToTs s) out') -> s :-> t
forall a b. (a -> b) -> a -> b
$ Value t -> Instr (ToTs s) (t : ToTs s)
forall {inp :: [T]} {out :: [T]} (t :: T) (s :: [T]).
(inp ~ s, out ~ (t : s), ConstantScope t) =>
Value' Instr t -> Instr inp out
PUSH Value t
eval Instr (ToTs s) (t : ToTs s)
-> Instr (t : ToTs s) out' -> Instr (ToTs s) out'
forall (inp :: [T]) (b :: [T]) (out :: [T]).
Instr inp b -> Instr b out -> Instr inp out
`Seq` Instr (t : ToTs s) out'
forall (a :: T) (s :: [T]) (out :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) out
FAILWITH)

class Typeable e => ErrorHasDoc (e :: Type) where
  -- | Name of error as it appears in the corresponding section title.
  errorDocName :: Text

  -- | What should happen for this error to be raised.
  errorDocMdCause :: Markdown

  -- | Brief version of 'errorDocMdCause'.
  --
  -- This will appear along with the error when mentioned in entrypoint description.
  -- By default, the first sentence of the full description is used.
  errorDocMdCauseInEntrypoint :: Markdown
  errorDocMdCauseInEntrypoint = Builder -> Builder
pickFirstSentence (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Builder
errorDocMdCause @e

  -- | How this error is represented in Haskell.
  errorDocHaskellRep :: Markdown

  -- | Error class.
  errorDocClass :: ErrorClass
  errorDocClass = ErrorClass
ErrClassUnknown

  -- | Which definitions documentation for this error mentions.
  errorDocDependencies :: [SomeDocDefinitionItem]

  -- | Constraints which we require in a particular instance.
  -- You are not oblidged to often instantiate this correctly, it is only useful
  -- for some utilities.
  type ErrorRequirements e :: Constraint
  type ErrorRequirements _ = ()

  -- | Captured constraints which we require in a particular instance.
  -- This is a way to encode a bidirectional instance in the nowaday Haskell,
  -- for @class MyConstraint => ErrorHasDoc MyType@ instance it lets deducing
  -- @MyConstraint@ by @ErrorHasDoc MyType@.
  --
  -- You are not oblidged to always instantiate, it is only useful for some
  -- utilities which otherwise would not compile.
  errorDocRequirements :: Dict (ErrorRequirements e)
  default errorDocRequirements :: ErrorRequirements e => Dict (ErrorRequirements e)
  errorDocRequirements = Dict (ErrorRequirements e)
forall (a :: Constraint). a => Dict a
Dict

-- | Helper for managing descriptions.
pickFirstSentence :: Markdown -> Markdown
pickFirstSentence :: Builder -> Builder
pickFirstSentence = Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> (Builder -> Text) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Builder -> String) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go (String -> String) -> (Builder -> String) -> Builder -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall b. FromBuilder b => Builder -> b
fmt
  where
    go :: String -> String
    go :: String -> String
go = \case
      Char
'.' : Char
c : String
_ | Char -> DocItemReferencedKind
C.isSpace Char
c -> String
"."
      Char
c : String
s -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      String
"" -> String
""

----------------------------------------------------------------------------
-- Instances
----------------------------------------------------------------------------

-- | Use this for internal errors only.
--
-- \"Normal\" error scenarios should use the mechanism of custom errors, see below.
instance IsError MText where
  errorToVal :: forall r.
MText -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal = MText -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
forall e r.
(KnownError e, IsoValue e) =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
isoErrorToVal
  errorFromVal :: forall (t :: T). SingI t => Value t -> Either Text MText
errorFromVal = Value t -> Either Text MText
forall (t :: T) e.
(SingI t, KnownIsoT e, IsoValue e) =>
Value t -> Either Text e
isoErrorFromVal

instance ErrorHasDoc MText where
  errorDocName :: Text
errorDocName = Text
"InternalError"
  errorDocMdCause :: Builder
errorDocMdCause =
    Builder
"Some internal error occurred."
  errorDocHaskellRep :: Builder
errorDocHaskellRep =
    Builder
"Textual error message, see " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Proxy MText -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MText) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"."
  errorDocClass :: ErrorClass
errorDocClass = ErrorClass
ErrClassContractInternal
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = [DType -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (Proxy MText -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy MText -> DType) -> Proxy MText -> DType
forall a b. (a -> b) -> a -> b
$ forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MText)]

instance TypeError ('Text "Use representative error messages") => IsError () where
  errorToVal :: forall r.
() -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal ()
_ forall (t :: T). ErrorScope t => Value t -> r
_ = Text -> r
forall a. HasCallStack => Text -> a
error Text
"impossible"
  errorFromVal :: forall (t :: T). SingI t => Value t -> Either Text ()
errorFromVal = Text -> Value t -> Either Text ()
forall a. HasCallStack => Text -> a
error Text
"impossible"

instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where
  errorDocName :: Text
errorDocName = Text -> Text
forall a. HasCallStack => Text -> a
error Text
"impossible"
  errorDocMdCause :: Builder
errorDocMdCause = Text -> Builder
forall a. HasCallStack => Text -> a
error Text
"impossible"
  errorDocHaskellRep :: Builder
errorDocHaskellRep = Text -> Builder
forall a. HasCallStack => Text -> a
error Text
"impossible"
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Text -> [SomeDocDefinitionItem]
forall a. HasCallStack => Text -> a
error Text
"impossible"

-- | Use this type as replacement for @()@ when you __really__ want to leave
-- error cause unspecified.
data UnspecifiedError = UnspecifiedError
  deriving stock (forall x. UnspecifiedError -> Rep UnspecifiedError x)
-> (forall x. Rep UnspecifiedError x -> UnspecifiedError)
-> Generic UnspecifiedError
forall x. Rep UnspecifiedError x -> UnspecifiedError
forall x. UnspecifiedError -> Rep UnspecifiedError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnspecifiedError x -> UnspecifiedError
$cfrom :: forall x. UnspecifiedError -> Rep UnspecifiedError x
Generic
  deriving anyclass WellTypedToT UnspecifiedError
WellTypedToT UnspecifiedError
-> (UnspecifiedError -> Value (ToT UnspecifiedError))
-> (Value (ToT UnspecifiedError) -> UnspecifiedError)
-> IsoValue UnspecifiedError
Value (ToT UnspecifiedError) -> UnspecifiedError
UnspecifiedError -> Value (ToT UnspecifiedError)
forall a.
WellTypedToT a
-> (a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
fromVal :: Value (ToT UnspecifiedError) -> UnspecifiedError
$cfromVal :: Value (ToT UnspecifiedError) -> UnspecifiedError
toVal :: UnspecifiedError -> Value (ToT UnspecifiedError)
$ctoVal :: UnspecifiedError -> Value (ToT UnspecifiedError)
IsoValue

instance IsError UnspecifiedError where
  errorToVal :: forall r.
UnspecifiedError
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal = UnspecifiedError
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
forall e r.
(KnownError e, IsoValue e) =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
isoErrorToVal
  errorFromVal :: forall (t :: T). SingI t => Value t -> Either Text UnspecifiedError
errorFromVal = Value t -> Either Text UnspecifiedError
forall (t :: T) e.
(SingI t, KnownIsoT e, IsoValue e) =>
Value t -> Either Text e
isoErrorFromVal

instance ErrorHasDoc UnspecifiedError where
  errorDocName :: Text
errorDocName = Text
"Unspecified error"
  errorDocMdCause :: Builder
errorDocMdCause = Builder
"Some error occurred."
  errorDocHaskellRep :: Builder
errorDocHaskellRep = Proxy () -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @()) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"."
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Proxy () -> [SomeDocDefinitionItem]
forall a. TypeHasDoc a => Proxy a -> [SomeDocDefinitionItem]
typeDocDependencies (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @())

-- | Use this error when sure that failing at the current position is possible
-- in no curcumstances (including invalid user input or misconfigured storage).
--
-- To use this as error, you have to briefly specify the reason why the error
-- scenario is impossible (experimental feature).
data Impossible (reason :: Symbol) = HasCallStack => Impossible

instance KnownSymbol reason => IsError (Impossible reason) where
  errorToVal :: forall r.
Impossible reason
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal Impossible reason
Impossible forall (t :: T). ErrorScope t => Value t -> r
cont = Value 'TUnit -> r
forall (t :: T). ErrorScope t => Value t -> r
cont (Value 'TUnit -> r) -> Value 'TUnit -> r
forall a b. (a -> b) -> a -> b
$ () -> Value (ToT ())
forall a. IsoValue a => a -> Value (ToT a)
toVal ()
  errorFromVal :: forall (t :: T).
SingI t =>
Value t -> Either Text (Impossible reason)
errorFromVal = Text -> Value t -> Either Text (Impossible reason)
forall a. HasCallStack => Text -> a
error Text
"Extracting impossible error"

  failUsing :: forall (s :: [*]) (t :: [*]).
IsError (Impossible reason) =>
Impossible reason -> s :-> t
failUsing err :: Impossible reason
err@Impossible reason
Impossible =
    Text -> s :-> s
forall (s :: [*]). Text -> s :-> s
justComment Text
codeComment (s :-> s) -> (s :-> s) -> s :-> s
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
    Text
-> PrintComment (ToTs s)
-> (s :-> (DocItemReferencedKind : s))
-> s :-> s
forall (inp :: [*]) (out :: [*]).
HasCallStack =>
Text
-> PrintComment (ToTs inp)
-> (inp :-> (DocItemReferencedKind : out))
-> inp :-> inp
testAssert Text
testDescription PrintComment (ToTs s)
"" (DocItemReferencedKind -> s :-> (DocItemReferencedKind : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push DocItemReferencedKind
False) (s :-> s) -> (s :-> t) -> s :-> t
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
    Impossible reason -> s :-> t
forall e (s :: [*]) (t :: [*]). IsError e => e -> s :-> t
simpleFailUsing Impossible reason
err
    where
      codeComment :: Text
codeComment = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Failure from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
      testDescription :: Text
testDescription =
        Text
"Impossible happened: unexpected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
        \At: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack)

instance KnownSymbol reason => ErrorHasDoc (Impossible reason) where
  errorDocName :: Text
errorDocName = Text
"Impossible error"
  errorDocMdCause :: Builder
errorDocMdCause =
    Builder
"An impossible error happened.\n\n\
    \If this error occured, contact the contract authors."
  errorDocHaskellRep :: Builder
errorDocHaskellRep = Proxy () -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @()) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"."
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Proxy () -> [SomeDocDefinitionItem]
forall a. TypeHasDoc a => Proxy a -> [SomeDocDefinitionItem]
typeDocDependencies (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @())

-- | Type wrapper for an @IsError@.
data SomeError = forall e. (IsError e, Eq e) => SomeError e

instance Eq SomeError where
  SomeError e
e1 == :: SomeError -> SomeError -> DocItemReferencedKind
== SomeError e
e2 = e -> e -> DocItemReferencedKind
forall a1 a2.
(Typeable a1, Typeable a2, Eq a1) =>
a1 -> a2 -> DocItemReferencedKind
eqExt e
e1 e
e2

instance Buildable SomeError where
  build :: SomeError -> Builder
build (SomeError e
e) = e
-> (forall (t :: T). ErrorScope t => Value t -> Builder) -> Builder
forall e r.
IsError e =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal e
e (Value -> Builder
forall p. Buildable p => p -> Builder
build (Value -> Builder)
-> (Value' Instr t -> Value) -> Value' Instr t -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value' Instr t -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue)

----------------------------------------------------------------------------
-- General instructions
----------------------------------------------------------------------------

-- | Fail, providing a reference to the place in the code where
-- this function is called.
--
-- Like 'error' in Haskell code, this instruction is for internal errors only.
failUnexpected :: MText -> s :-> t
failUnexpected :: forall (s :: [*]) (t :: [*]). MText -> s :-> t
failUnexpected MText
msg = MText -> s :-> t
forall e (s :: [*]) (t :: [*]).
(IsError e, IsError e) =>
e -> s :-> t
failUsing (MText -> s :-> t) -> MText -> s :-> t
forall a b. (a -> b) -> a -> b
$ [mt|Unexpected: |] MText -> MText -> MText
forall a. Semigroup a => a -> a -> a
<> MText
msg

----------------------------------------------------------------------------
-- Custom errors
----------------------------------------------------------------------------

{- | Declares a custom error, defining @error name - error argument@ relation.

If your error is supposed to carry no argument, then provide @()@.

Note that this relation is defined globally rather than on per-contract basis,
so define errors accordingly. If your error has argument specific to your
contract, call it such that error name reflects its belonging to this contract.

This is the basic [error format].
-}

{- About global registry of errors:

Pros: this allows defining pieces of code which can be reused among the contracts.

Cons: possible name collisions. Example of worst case: two libraries define
different errors for the same tag, attempt to use both of these libraries would
cause compile-time error. But such infrastructure will barely take place in
practice.
-}
{- For future work:

* Assosiating unique numeric error codes to tags, and put codes into
the contract instead of tags. This allows getting rid of overhead related to
often long tag literals.

* Allow using arbitrary type instead of tag (and 'KnownSymbol' constraint will
be replaced with a more generic one).
Some users may prefer using datatypes as tags rather than type-level strings as tags
because
  * there will be no orphan instances then
  * no problem with name collisions
  * compiler will prompt a hint in case of typo in tag name
  * in some cases autocomplete handles declarations in code better than strings
(and cons here is that each such tag will need to be declared first).

-}
type family ErrorArg (tag :: Symbol) :: Type

-- | Material custom error.
--
-- Use this in pattern matches against error (e.g. in tests).
data CustomError (tag :: Symbol) = CustomError
  { forall (tag :: Symbol). CustomError tag -> Label tag
ceTag :: Label tag
  , forall (tag :: Symbol). CustomError tag -> CustomErrorRep tag
ceArg :: CustomErrorRep tag
  }

deriving stock instance Eq (CustomErrorRep tag) => Eq (CustomError tag)
deriving stock instance Show (CustomErrorRep tag) => Show (CustomError tag)

instance Buildable (CustomError tag) where
  build :: CustomError tag -> Builder
build (CustomError Label tag
tg CustomErrorRep tag
_err) = Builder
"CustomError #" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Label tag -> Builder
forall p. Buildable p => p -> Builder
build Label tag
tg

-- | To be used as @ErrorArg@ instance when failing with just
-- a @string@ instead of @pair string x@
data NoErrorArg

-- | To be used as @ErrorArg@ instances. This is equivalent to using
-- @()@ but using @UnitErrorArg@ is preferred since @()@ behavior could
-- be changed in the future.
data UnitErrorArg

-- | How 'CustomError' is actually represented in Michelson.
type CustomErrorRep tag = CustomErrorArgRep (ErrorArg tag)

type family CustomErrorArgRep (errArg :: Type) where
  CustomErrorArgRep NoErrorArg = MText
  CustomErrorArgRep UnitErrorArg = (MText, ())
  CustomErrorArgRep errArg = (MText, errArg)

-- | Typeclass implements various method that work with `CustomErrorArgRep`.
class IsCustomErrorArgRep a where
  verifyErrorTag :: MText -> a -> Either Text a
  customErrorRepDocDeps :: [SomeDocDefinitionItem]
  customErrorHaskellRep
    :: (KnownSymbol tag, CustomErrorHasDoc tag)
    => Proxy tag -> Markdown

instance IsCustomErrorArgRep MText where
  verifyErrorTag :: MText -> MText -> Either Text MText
verifyErrorTag MText
expectedTag MText
tag =
    if MText
tag MText -> MText -> DocItemReferencedKind
forall a. Eq a => a -> a -> DocItemReferencedKind
== MText
expectedTag
    then MText -> Either Text MText
forall a b. b -> Either a b
Right MText
tag
    else Text -> Either Text MText
forall a b. a -> Either a b
Left (Text -> Either Text MText) -> Text -> Either Text MText
forall a b. (a -> b) -> a -> b
$ Builder
"Bad tag, expected " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| MText
expectedTag MText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
", got " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| MText
tag MText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  customErrorRepDocDeps :: [SomeDocDefinitionItem]
customErrorRepDocDeps = []
  customErrorHaskellRep :: forall (tag :: Symbol).
(KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Builder
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) =
    Builder -> Builder
mdTicked (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
forall p. Buildable p => p -> Builder
build (forall (s :: Symbol). KnownSymbol s => Text
errorTagToText @tag)

instance (TypeHasDoc errArg)
  => IsCustomErrorArgRep (MText, errArg) where
  verifyErrorTag :: MText -> (MText, errArg) -> Either Text (MText, errArg)
verifyErrorTag MText
expectedTag (MText
tag, errArg
arg) =
    if MText
tag MText -> MText -> DocItemReferencedKind
forall a. Eq a => a -> a -> DocItemReferencedKind
== MText
expectedTag
    then (MText, errArg) -> Either Text (MText, errArg)
forall a b. b -> Either a b
Right (MText
tag, errArg
arg)
    else Text -> Either Text (MText, errArg)
forall a b. a -> Either a b
Left (Text -> Either Text (MText, errArg))
-> Text -> Either Text (MText, errArg)
forall a b. (a -> b) -> a -> b
$ Builder
"Bad tag, expected " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| MText
expectedTag MText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
", got " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| MText
tag MText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
  customErrorRepDocDeps :: [SomeDocDefinitionItem]
customErrorRepDocDeps =
    [ DType -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (DType -> SomeDocDefinitionItem) -> DType -> SomeDocDefinitionItem
forall a b. (a -> b) -> a -> b
$ Proxy errArg -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy errArg -> DType) -> Proxy errArg -> DType
forall a b. (a -> b) -> a -> b
$ forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @errArg ]
  customErrorHaskellRep :: forall (tag :: Symbol).
(KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Builder
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Builder -> Builder
mdTicked (Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build (forall (s :: Symbol). KnownSymbol s => Text
errorTagToText @tag) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
", " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"<error argument>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")")
    , (Builder
"\n\nProvided error argument will be of type "
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Proxy (MText, errArg) -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(MText, errArg)) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False)
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Builder -> (Builder -> Builder) -> Maybe Builder -> Builder
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Builder
"" (\Builder
txt -> Builder
" and stand for " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
txt) (forall (tag :: Symbol). CustomErrorHasDoc tag => Maybe Builder
customErrArgumentSemantics @tag))
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"."
      )
    ]

-- | This instance cannot be implemented, use 'IsError' instance instead.
instance (WellTypedToT (CustomErrorRep tag), TypeError ('Text "CustomError has no IsoValue instance")) =>
         IsoValue (CustomError tag) where
  -- Originally we had a `TypeError` here, but that had to be changed when
  -- `WellTyped (ToT a)` was added as a superclass of `IsoValue`, because it
  -- resulted in the type error being triggerred from the evaluation of `ToT`
  -- typefamily in the super class clause.
  type ToT (CustomError tag) = (ToT (CustomErrorRep tag))
  toVal :: CustomError tag -> Value (ToT (CustomError tag))
toVal = Text -> CustomError tag -> Value (ToT (CustomErrorRep tag))
forall a. HasCallStack => Text -> a
error Text
"impossible"
  fromVal :: Value (ToT (CustomError tag)) -> CustomError tag
fromVal = Text -> Value (ToT (CustomErrorRep tag)) -> CustomError tag
forall a. HasCallStack => Text -> a
error Text
"impossible"

instance ( CustomErrorHasDoc tag
         , KnownError (CustomErrorRep tag)
         , IsoValue (CustomErrorRep tag)
         , IsCustomErrorArgRep (CustomErrorRep tag)
         )
  => IsError (CustomError tag) where

  errorToVal :: forall r.
CustomError tag
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal (CustomError Label tag
_ CustomErrorRep tag
arg) forall (t :: T). ErrorScope t => Value t -> r
cont =
    Value (ToT (CustomErrorRep tag)) -> r
forall (t :: T). ErrorScope t => Value t -> r
cont (Value (ToT (CustomErrorRep tag)) -> r)
-> Value (ToT (CustomErrorRep tag)) -> r
forall a b. (a -> b) -> a -> b
$ forall a. IsoValue a => a -> Value (ToT a)
toVal @(CustomErrorRep tag) CustomErrorRep tag
arg

  errorFromVal :: forall (t :: T).
SingI t =>
Value t -> Either Text (CustomError tag)
errorFromVal Value t
v = do
    let expectedTag :: MText
expectedTag = Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @tag)
    Value (ToT (CustomErrorRep tag))
v' <- Value t
-> (forall x. MismatchError T -> Either Text x)
-> Either Text (Value (ToT (CustomErrorRep tag)))
forall (a :: T) (b :: T) (t :: T -> *) (m :: * -> *).
(SingI a, SingI b, Monad m) =>
t a -> (forall x. MismatchError T -> m x) -> m (t b)
castM Value t
v \MkMismatchError{T
meExpected :: forall a. MismatchError a -> a
meActual :: forall a. MismatchError a -> a
meActual :: T
meExpected :: T
..} -> Text -> Either Text x
forall a b. a -> Either a b
Left (Text -> Either Text x) -> Text -> Either Text x
forall a b. (a -> b) -> a -> b
$ Text
"Wrong type for custom error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> T -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty T
meActual
    CustomErrorRep tag
errArg <- forall a. IsCustomErrorArgRep a => MText -> a -> Either Text a
verifyErrorTag @(CustomErrorRep tag) MText
expectedTag
            (CustomErrorRep tag -> Either Text (CustomErrorRep tag))
-> CustomErrorRep tag -> Either Text (CustomErrorRep tag)
forall a b. (a -> b) -> a -> b
$ forall a. IsoValue a => Value (ToT a) -> a
fromVal @(CustomErrorRep tag) Value (ToT (CustomErrorRep tag))
v'
    pure $ Label tag -> CustomErrorRep tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> CustomErrorRep tag -> CustomError tag
CustomError Label tag
forall (x :: Symbol) a. IsLabel x a => a
fromLabel CustomErrorRep tag
errArg

instance ( CustomErrorHasDoc tag
         , IsCustomErrorArgRep (CustomErrorRep tag)
         )
  => ErrorHasDoc (CustomError tag) where
  errorDocName :: Text
errorDocName = forall (s :: Symbol). KnownSymbol s => Text
errorTagToText @tag
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = forall a. IsCustomErrorArgRep a => [SomeDocDefinitionItem]
customErrorRepDocDeps @(CustomErrorRep tag)
  errorDocMdCause :: Builder
errorDocMdCause = forall (tag :: Symbol). CustomErrorHasDoc tag => Builder
customErrDocMdCause @tag
  errorDocMdCauseInEntrypoint :: Builder
errorDocMdCauseInEntrypoint = forall (tag :: Symbol). CustomErrorHasDoc tag => Builder
customErrDocMdCauseInEntrypoint @tag
  errorDocClass :: ErrorClass
errorDocClass = forall (tag :: Symbol). CustomErrorHasDoc tag => ErrorClass
customErrClass @tag
  errorDocHaskellRep :: Builder
errorDocHaskellRep = forall a (tag :: Symbol).
(IsCustomErrorArgRep a, KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Builder
customErrorHaskellRep @(CustomErrorRep tag) (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tag)

  type ErrorRequirements (CustomError tag) = (CustomErrorHasDoc tag, IsCustomErrorArgRep (CustomErrorRep tag))
  errorDocRequirements :: Dict (ErrorRequirements (CustomError tag))
errorDocRequirements = Dict (ErrorRequirements (CustomError tag))
forall (a :: Constraint). a => Dict a
Dict

-- | Demote error tag to term level.
errorTagToMText :: Label tag -> MText
errorTagToMText :: forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l =
  -- Now tags come not from constructor names, but from labels,
  -- we have to lead the first letter to upper case to preserve
  -- compatibility with FA1.2 interface.
  HasCallStack => MText -> MText
MText -> MText
mtextHeadToUpper (MText -> MText) -> MText -> MText
forall a b. (a -> b) -> a -> b
$
    Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
labelToMText Label tag
l

errorTagToText :: forall tag. KnownSymbol tag => Text
errorTagToText :: forall (s :: Symbol). KnownSymbol s => Text
errorTagToText = MText -> Text
forall a. ToText a => a -> Text
toText (MText -> Text) -> MText -> Text
forall a b. (a -> b) -> a -> b
$ Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText (forall (x :: Symbol) a. IsLabel x a => a
fromLabel @tag)

-- | Fail with given custom error.
failCustom
  :: forall tag err s any.
     ( MustHaveErrorArg tag (MText, err)
     , CustomErrorHasDoc tag
     , KnownError err
     )
  => Label tag -> err : s :-> any
failCustom :: forall (tag :: Symbol) err (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, err), CustomErrorHasDoc tag,
 KnownError err) =>
Label tag -> (err : s) :-> any
failCustom Label tag
l =
  DThrows -> (err : s) :-> (err : s)
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (Proxy (CustomError tag) -> DThrows
forall e. ErrorHasDoc e => Proxy e -> DThrows
DThrows (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CustomError tag))) ((err : s) :-> (err : s))
-> ((err : s) :-> (MText : err : s))
-> (err : s) :-> (MText : err : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  MText -> (err : s) :-> (MText : err : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l) ((err : s) :-> (MText : err : s))
-> ((MText : err : s) :-> ((MText, err) : s))
-> (err : s) :-> ((MText, err) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair @MText @err ((err : s) :-> ((MText, err) : s))
-> (((MText, err) : s) :-> any) -> (err : s) :-> any
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  (forall (out' :: [T]). Instr (ToTs ((MText, err) : s)) out')
-> ((MText, err) : s) :-> any
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI (forall (a :: T) (s :: [T]) (out :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) out
FAILWITH @(ToT (MText, err)))

-- | Fail with given custom error.
failCustomNoArg
  :: forall tag s any.
     ( MustHaveErrorArg tag MText
     , CustomErrorHasDoc tag
     )
  => Label tag -> s :-> any
failCustomNoArg :: forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag MText, CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustomNoArg Label tag
l =
  DThrows -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (Proxy (CustomError tag) -> DThrows
forall e. ErrorHasDoc e => Proxy e -> DThrows
DThrows (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CustomError tag))) (s :-> s) -> (s :-> (MText : s)) -> s :-> (MText : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  MText -> s :-> (MText : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l) (s :-> (MText : s)) -> ((MText : s) :-> any) -> s :-> any
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  (forall (out' :: [T]). Instr (ToTs (MText : s)) out')
-> (MText : s) :-> any
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI (forall (a :: T) (s :: [T]) (out :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) out
FAILWITH @(ToT (MText)))


type MustHaveErrorArg errorTag expectedArgRep =
  FailUnlessEqual (CustomErrorRep errorTag) expectedArgRep
    ('Text "Error argument type is "
      ':<>: 'ShowType (expectedArgRep)
      ':<>: 'Text " but given error requires argument of type "
      ':<>: 'ShowType (CustomErrorRep errorTag)
    )

-- | Specialization of 'failCustom' for unit-arg errors.
failCustom_
  :: forall tag s any.
     ( MustHaveErrorArg tag (MText, ())
     , CustomErrorHasDoc tag
     )
  => Label tag -> s :-> any
failCustom_ :: forall (tag :: Symbol) (s :: [*]) (any :: [*]).
(MustHaveErrorArg tag (MText, ()), CustomErrorHasDoc tag) =>
Label tag -> s :-> any
failCustom_ Label tag
l =
  DThrows -> s :-> s
forall di (s :: [*]). DocItem di => di -> s :-> s
doc (Proxy (CustomError tag) -> DThrows
forall e. ErrorHasDoc e => Proxy e -> DThrows
DThrows (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CustomError tag))) (s :-> s) -> (s :-> (() : s)) -> s :-> (() : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  s :-> (() : s)
forall (s :: [*]). s :-> (() : s)
unit (s :-> (() : s))
-> ((() : s) :-> (MText : () : s)) -> s :-> (MText : () : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  MText -> (() : s) :-> (MText : () : s)
forall t (s :: [*]). NiceConstant t => t -> s :-> (t : s)
push (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l) (s :-> (MText : () : s))
-> ((MText : () : s) :-> ((MText, ()) : s))
-> s :-> ((MText, ()) : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# forall a b (s :: [*]). (a : b : s) :-> ((a, b) : s)
pair @MText @() (s :-> ((MText, ()) : s))
-> (((MText, ()) : s) :-> any) -> s :-> any
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
#
  (forall (out' :: [T]). Instr (ToTs ((MText, ()) : s)) out')
-> ((MText, ()) : s) :-> any
forall (inp :: [*]) (out :: [*]).
(forall (out' :: [T]). Instr (ToTs inp) out') -> inp :-> out
FI (forall (a :: T) (s :: [T]) (out :: [T]).
(SingI a, ConstantScope a) =>
Instr (a : s) out
FAILWITH @(ToT (MText, ())))

-- Special treatment of no-arg errors
----------------------------------------------------------------------------

-- | If 'CustomError' constructor is not provided its argument, we assume
-- that this is unit-arg error and interpret the passed value as complete.
instance ( Typeable arg
         , IsError (CustomError tag)
         , arg ~ ErrorArg tag
         , FailUnlessEqual arg ()
            ('Text "This error requires argument of type "
              ':<>: 'ShowType (ErrorArg tag)
            )
         ) =>
         IsError (arg -> CustomError tag) where
  errorToVal :: forall r.
(arg -> CustomError tag)
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal arg -> CustomError tag
mkCustomError forall (t :: T). ErrorScope t => Value t -> r
cont =
    CustomError tag
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
forall e r.
IsError e =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal (arg -> CustomError tag
mkCustomError ()) forall (t :: T). ErrorScope t => Value t -> r
cont
  errorFromVal :: forall (t :: T).
SingI t =>
Value t -> Either Text (arg -> CustomError tag)
errorFromVal Value t
v =
    Value t -> Either Text (CustomError tag)
forall e (t :: T). (IsError e, SingI t) => Value t -> Either Text e
errorFromVal Value t
v Either Text (CustomError tag)
-> (CustomError tag -> arg -> CustomError tag)
-> Either Text (arg -> CustomError tag)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(CustomError Label tag
l CustomErrorRep tag
a) arg
b -> Label tag -> CustomErrorRep tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> CustomErrorRep tag -> CustomError tag
CustomError Label tag
l ((MText, ()) -> MText
forall a b. (a, b) -> a
fst (MText, ())
CustomErrorRep tag
a, arg
b)

instance (Typeable arg, ErrorHasDoc (CustomError tag)) =>
         ErrorHasDoc (arg -> CustomError tag) where
  errorDocName :: Text
errorDocName = forall e. ErrorHasDoc e => Text
errorDocName @(CustomError tag)
  errorDocMdCauseInEntrypoint :: Builder
errorDocMdCauseInEntrypoint = forall e. ErrorHasDoc e => Builder
errorDocMdCauseInEntrypoint @(CustomError tag)
  errorDocMdCause :: Builder
errorDocMdCause = forall e. ErrorHasDoc e => Builder
errorDocMdCause @(CustomError tag)
  errorDocHaskellRep :: Builder
errorDocHaskellRep = forall e. ErrorHasDoc e => Builder
errorDocHaskellRep @(CustomError tag)
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = forall e. ErrorHasDoc e => [SomeDocDefinitionItem]
errorDocDependencies @(CustomError tag)

----------------------------------------------------------------------------
-- Errors documentation injection into contracts
----------------------------------------------------------------------------

-- | Error class on how the error should be handled by the client.
data ErrorClass
  = ErrClassActionException
    -- ^ Normal expected error.
    -- Examples: "insufficient balance", "wallet does not exist".
  | ErrClassBadArgument
    -- ^ Invalid argument passed to entrypoint.
    -- Examples: your entrypoint accepts an enum represented as @nat@, and
    -- unknown value is provided.
    -- This includes more complex cases which involve multiple entrypoints.
    -- E.g. API provides iterator interface, middleware should care about using it
    -- hiding complex details and exposing a simpler API to user; then an attempt to
    -- request non-existing element would also correspond to an error from this class.
  | ErrClassContractInternal
    -- ^ Unexpected error. Most likely it means that there is a bug in
    -- the contract or the contract has been deployed incorrectly.
  | ErrClassUnknown
    -- ^ It's possible to leave error class unspecified.
  deriving stock ((forall (m :: * -> *). Quote m => ErrorClass -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    ErrorClass -> Code m ErrorClass)
-> Lift ErrorClass
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => ErrorClass -> m Exp
forall (m :: * -> *). Quote m => ErrorClass -> Code m ErrorClass
liftTyped :: forall (m :: * -> *). Quote m => ErrorClass -> Code m ErrorClass
$cliftTyped :: forall (m :: * -> *). Quote m => ErrorClass -> Code m ErrorClass
lift :: forall (m :: * -> *). Quote m => ErrorClass -> m Exp
$clift :: forall (m :: * -> *). Quote m => ErrorClass -> m Exp
Lift)

instance Buildable ErrorClass where
  build :: ErrorClass -> Builder
build = \case
    ErrorClass
ErrClassActionException -> Builder
"Action exception"
    ErrorClass
ErrClassBadArgument -> Builder
"Bad argument"
    ErrorClass
ErrClassContractInternal -> Builder
"Internal"
    ErrorClass
ErrClassUnknown -> Builder
"-"

-- | Whether given error class is about internal errors.
--
-- Internal errors are not enlisted on per-entrypoint basis, only once for
-- the entire contract.
isInternalErrorClass :: ErrorClass -> Bool
isInternalErrorClass :: ErrorClass -> DocItemReferencedKind
isInternalErrorClass = \case
  ErrorClass
ErrClassActionException -> DocItemReferencedKind
False
  ErrorClass
ErrClassBadArgument -> DocItemReferencedKind
False
  ErrorClass
ErrClassContractInternal -> DocItemReferencedKind
True
  ErrorClass
ErrClassUnknown -> DocItemReferencedKind
False

class (KnownSymbol tag, TypeHasDoc (CustomErrorRep tag), IsError (CustomError tag)) =>
      CustomErrorHasDoc tag where
  -- | What should happen for this error to be raised.
  customErrDocMdCause :: Markdown

  -- | Brief version of 'customErrDocMdCause'.
  -- This will appear along with the error when mentioned in entrypoint description.
  --
  -- By default, the first sentence of the full description is used.
  customErrDocMdCauseInEntrypoint :: Markdown
  customErrDocMdCauseInEntrypoint = Builder -> Builder
pickFirstSentence (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol). CustomErrorHasDoc tag => Builder
customErrDocMdCause @tag

  -- | Error class.
  --
  -- By default this returns "unknown error" class; though you should provide
  -- explicit implementation in order to avoid a warning.
  customErrClass :: ErrorClass
  customErrClass = ErrorClass
ErrClassUnknown

  -- | Clarification of error argument meaning.
  --
  -- Provide when it's not obvious, e.g. argument is not named with t'Lorentz.ADT.:!'.
  --
  -- NOTE: This should /not/ be an entire sentence, rather just the semantic
  -- backbone.
  --
  -- Bad:
  -- * @Error argument stands for the previous value of approval.@
  --
  -- Good:
  -- * @the previous value of approval@
  -- * @pair, first argument of which is one thing, and the second is another@
  customErrArgumentSemantics :: Maybe Markdown
  customErrArgumentSemantics = Maybe Builder
forall a. Maybe a
Nothing
  {-# MINIMAL customErrDocMdCause, customErrClass #-}

-- | Mentions that contract uses given error.
data DError where
  DError :: ErrorHasDoc e => Proxy e -> DError

instance Eq DError where
  DError Proxy e
e1 == :: DError -> DError -> DocItemReferencedKind
== DError Proxy e
e2 = Proxy e
e1 Proxy e -> Proxy e -> DocItemReferencedKind
forall {k} (a1 :: k) (a2 :: k) (t :: k -> *).
(Typeable a1, Typeable a2, Eq (t a1)) =>
t a1 -> t a2 -> DocItemReferencedKind
`eqParam1` Proxy e
e2
instance Ord DError where
  DError Proxy e
e1 compare :: DError -> DError -> Ordering
`compare` DError Proxy e
e2 = Proxy e
e1 Proxy e -> Proxy e -> Ordering
forall a1 a2.
(Typeable a1, Typeable a2, Ord a1) =>
a1 -> a2 -> Ordering
`compareExt` Proxy e
e2

instance DocItem DError where
  type DocItemPlacement DError = 'DocItemInDefinitions
  type DocItemReferenced DError = 'True

  docItemPos :: Natural
docItemPos = Natural
5010
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Errors"
  docItemSectionDescription :: Maybe Builder
docItemSectionDescription = Builder -> Maybe Builder
forall a. a -> Maybe a
Just Builder
errorsDocumentation
  docItemRef :: DError
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
docItemRef (DError (Proxy e
_ :: Proxy e)) = DocItemId -> DocItemRef 'DocItemInDefinitions 'True
DocItemRef (DocItemId -> DocItemRef 'DocItemInDefinitions 'True)
-> DocItemId -> DocItemRef 'DocItemInDefinitions 'True
forall a b. (a -> b) -> a -> b
$
    Text -> DocItemId
DocItemId (Text
"errors-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall e. ErrorHasDoc e => Text
errorDocName @e)
  docItemToMarkdown :: HeaderLevel -> DError -> Builder
docItemToMarkdown HeaderLevel
lvl (DError (Proxy e
_ :: Proxy e)) =
    [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Builder
mdSeparator
    , HeaderLevel -> Builder -> Builder
mdHeader HeaderLevel
lvl (Builder -> Builder
mdTicked (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Text
errorDocName @e)
    , Builder -> Builder -> Builder
mdSubsection Builder
"Class" (ErrorClass -> Builder
forall p. Buildable p => p -> Builder
build (ErrorClass -> Builder) -> ErrorClass -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => ErrorClass
errorDocClass @e)
    , Builder
"\n\n"
    , Builder -> Builder -> Builder
mdSubsection Builder
"Fires if" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Builder
errorDocMdCause @e
    , Builder
"\n\n"
    , Builder -> Builder -> Builder
mdSubsection Builder
"Representation" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Builder
errorDocHaskellRep @e
    ]
  docItemToToc :: HeaderLevel -> DError -> Builder
docItemToToc HeaderLevel
lvl d :: DError
d@(DError (Proxy e
_ :: Proxy e)) =
    HeaderLevel -> Builder -> DError -> Builder
forall d.
(DocItem d, DocItemReferenced d ~ 'True) =>
HeaderLevel -> Builder -> d -> Builder
mdTocFromRef HeaderLevel
lvl (Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Text
errorDocName @e) DError
d

  docItemDependencies :: DError -> [SomeDocDefinitionItem]
docItemDependencies (DError (Proxy e
_ :: Proxy e)) = forall e. ErrorHasDoc e => [SomeDocDefinitionItem]
errorDocDependencies @e

errorDocMdReference :: forall e. ErrorHasDoc e => Markdown
errorDocMdReference :: forall e. ErrorHasDoc e => Builder
errorDocMdReference =
  let DocItemRef DocItemId
docItemId = DError
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef (DError
 -> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError))
-> DError
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
forall a b. (a -> b) -> a -> b
$ Proxy e -> DError
forall e. ErrorHasDoc e => Proxy e -> DError
DError (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e)
  in Builder -> DocItemId -> Builder
forall anchor. ToAnchor anchor => Builder -> anchor -> Builder
mdLocalRef (Builder -> Builder
mdTicked (Builder -> Builder) -> (Text -> Builder) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Text
errorDocName @e) DocItemId
docItemId

-- | Documentation for custom errors.

-- | Mentions that entrypoint throws given error.
data DThrows where
  DThrows :: ErrorHasDoc e => Proxy e -> DThrows

instance Eq DThrows where
  DThrows Proxy e
e1 == :: DThrows -> DThrows -> DocItemReferencedKind
== DThrows Proxy e
e2 = Proxy e -> Proxy e -> DocItemReferencedKind
forall {k} (a1 :: k) (a2 :: k) (t :: k -> *).
(Typeable a1, Typeable a2, Eq (t a1)) =>
t a1 -> t a2 -> DocItemReferencedKind
eqParam1 Proxy e
e1 Proxy e
e2

instance DocItem DThrows where
  docItemPos :: Natural
docItemPos = Natural
5011
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Possible errors"
  docItemSectionNameStyle :: DocSectionNameStyle
docItemSectionNameStyle = DocSectionNameStyle
DocSectionNameSmall
  docItemDependencies :: DThrows -> [SomeDocDefinitionItem]
docItemDependencies (DThrows Proxy e
ds) =
    [DError -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (Proxy e -> DError
forall e. ErrorHasDoc e => Proxy e -> DError
DError Proxy e
ds)]
  docItemToMarkdown :: HeaderLevel -> DThrows -> Builder
docItemToMarkdown HeaderLevel
_ (DThrows (Proxy e
_ :: Proxy e)) =
    Builder
"* " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall e. ErrorHasDoc e => Builder
errorDocMdReference @e Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" — " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall e. ErrorHasDoc e => Builder
errorDocMdCauseInEntrypoint @e
  docItemsOrder :: [DThrows] -> [DThrows]
docItemsOrder =
    let errType :: DThrows -> ErrorClass
errType (DThrows (Proxy e
_ :: Proxy e)) = forall e. ErrorHasDoc e => ErrorClass
errorDocClass @e
    in [DThrows] -> [DThrows]
forall a. Eq a => [a] -> [a]
L.nub ([DThrows] -> [DThrows])
-> ([DThrows] -> [DThrows]) -> [DThrows] -> [DThrows]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DThrows -> DocItemReferencedKind) -> [DThrows] -> [DThrows]
forall a. (a -> DocItemReferencedKind) -> [a] -> [a]
filter (DocItemReferencedKind -> DocItemReferencedKind
Prelude.not (DocItemReferencedKind -> DocItemReferencedKind)
-> (DThrows -> DocItemReferencedKind)
-> DThrows
-> DocItemReferencedKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorClass -> DocItemReferencedKind
isInternalErrorClass (ErrorClass -> DocItemReferencedKind)
-> (DThrows -> ErrorClass) -> DThrows -> DocItemReferencedKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DThrows -> ErrorClass
errType)

-- | Implementation of 'typeDocMdDescription' (of 'TypeHasDoc' typeclass)
-- for Haskell types which sole purpose is to be error.
typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown
typeDocMdDescriptionReferToError :: forall e. IsError e => Builder
typeDocMdDescriptionReferToError =
  Builder
"This type is primarily used as error, see " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
  Builder -> DError -> Builder
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
Builder -> d -> Builder
docDefinitionRef Builder
"description in section with errors" (Proxy e -> DError
forall e. ErrorHasDoc e => Proxy e -> DError
DError (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @e))

-- | This is to be included on top of @Errors@ section of the generated
-- documentation.
errorsDocumentation :: Markdown
errorsDocumentation :: Builder
errorsDocumentation =
  -- Note: this description should remain general enough to fit into all our
  -- error formats, seek for [error format] to find all the relevant
  -- declarations.
  [md|
  Our contract implies the possibility of error scenarios, this section enlists
  all values which the contract can produce via calling `FAILWITH` instruction
  on them. In case of error, no changes to contract state will be applied.

  Each entrypoint also contains a list of errors which can be raised during its
  execution; only for no-throw entrypoints this list will be omitted.
  Errors in these lists are placed in the order in which the corresponding
  properties are checked unless the opposite is specified. I.e., if for a
  given entrypoint call two different errors may take place, the one which
  appears in the list first will be thrown.

  The errors are represented either as a string `error tag` or a pair `(error tag, error argument)`.
  See the list of errors below for details.

  We distinquish several error classes:
  + #{errClassActionException}: given action cannot be performed with
    regard to the current contract state.

    Examples: "insufficient balance", "wallet does not exist".

    If you are implementing a middleware, such errors should be propagated to
    the client.

  + #{errClassBadArgument}: invalid argument supplied to the entrypoint.

    Examples: entrypoint accepts a natural number from `0-3` range, and you
    supply `5`.

    If you are implementing a middleware, you should care about not letting
    such errors happen.

  + #{errClassContractInternal}: contract-internal error.

    In ideal case, such errors should not take place, but still, make sure
    that you are ready to handle them. They can signal either invalid contract
    deployment or a bug in contract implementation.

    If an internal error is thrown, please report it to the author of this contract.
  |]
  where
    errClassActionException :: Builder
errClassActionException  = Builder -> Builder
mdBold (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Builder
forall p. Buildable p => p -> Builder
build ErrorClass
ErrClassActionException
    errClassBadArgument :: Builder
errClassBadArgument      = Builder -> Builder
mdBold (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Builder
forall p. Buildable p => p -> Builder
build ErrorClass
ErrClassBadArgument
    errClassContractInternal :: Builder
errClassContractInternal = Builder -> Builder
mdBold (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Builder
forall p. Buildable p => p -> Builder
build ErrorClass
ErrClassContractInternal