-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# 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
  , isoErrorToVal
  , isoErrorFromVal
  , ErrorHasDoc (..)
  , typeDocMdDescriptionReferToError
  , customErrorDocHaskellRepGeneral

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

    -- * General instructions
  , failUsing
  , failUnexpected

    -- * Custom errors
  , ErrorArg
  , CustomError (..)
  , failCustom
  , RequireNoArgError
  , failCustom_

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

    -- * Internals
  , errorTagToText
  , errorTagToMText
  ) where

import qualified Data.Char as C
import qualified Data.Kind as Kind
import qualified Data.List as L
import Data.Singletons (demote)
import Data.Typeable (cast)
import Fmt (Buildable, build, fmt, pretty, (+|), (|+))
import Language.Haskell.TH.Syntax (Lift)
import Text.Read (readsPrec)
import qualified Text.Show

import Lorentz.Base
import Lorentz.Doc
import Lorentz.Instr hiding (cast)
import Lorentz.Value
import Michelson.Text
import Michelson.Typed.Convert (untypeValue)
import Michelson.Typed.Haskell
import Michelson.Typed.Instr
import Michelson.Typed.Scope
import Michelson.Typed.T
import Util.Markdown
import Util.Type
import Util.Typeable
import Util.TypeLits

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

type ErrorScope t =
  -- We can require a weaker constraint (e.g. no 'HasNoOp'), but
  -- for now it's the simplest way to make 'failUsing' work
  ( Typeable t
  , ConstantScope t
  )

type KnownError a = ErrorScope (ToT a)

-- | Haskell type representing error.
class (Typeable e, 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 :: (KnownT t) => Value t -> Either Text e

-- | Implementation of 'errorToVal' via 'IsoValue'.
isoErrorToVal
  :: (KnownError e, IsoValue e)
  => e -> (forall t. ErrorScope t => Value t -> r) -> r
isoErrorToVal :: e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
isoErrorToVal e :: e
e cont :: 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
  :: (Typeable t, Typeable (ToT e), IsoValue e)
  => Value t -> Either Text e
isoErrorFromVal :: Value t -> Either Text e
isoErrorFromVal e :: 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 k (a :: k) (b :: k) (t :: k -> *).
(Typeable a, Typeable b) =>
t a -> Either Text (t b)
gcastE Value t
e

class Typeable e => ErrorHasDoc (e :: Kind.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 = Markdown -> Markdown
pickFirstSentence (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Markdown
forall e. ErrorHasDoc e => Markdown
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 e = ()

  -- | 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 :: Markdown -> Markdown
pickFirstSentence = Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> (Markdown -> Text) -> Markdown -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Markdown -> String) -> Markdown -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go (String -> String) -> (Markdown -> String) -> Markdown -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> String
forall b. FromBuilder b => Markdown -> b
fmt
  where
    go :: String -> String
    go :: String -> String
go = \case
      '.' : c :: Char
c : _ | Char -> Bool
C.isSpace Char
c -> "."
      c :: Char
c : s :: String
s -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
s
      "" -> ""

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

-- | Use this for internal errors only.
--
-- "Normal" error scenarios should use the mechanism of custom errors, see below.
instance IsError MText where
  errorToVal :: 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 :: Value t -> Either Text MText
errorFromVal = Value t -> Either Text MText
forall (t :: T) e.
(Typeable t, Typeable (ToT e), IsoValue e) =>
Value t -> Either Text e
isoErrorFromVal

instance ErrorHasDoc MText where
  errorDocName :: Text
errorDocName = "InternalError"
  errorDocMdCause :: Markdown
errorDocMdCause =
    "Some internal error occured."
  errorDocHaskellRep :: Markdown
errorDocHaskellRep =
    "Textual error message, see " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    Proxy MText -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference (Proxy MText
forall k (t :: k). Proxy t
Proxy @MText) (Bool -> WithinParens
WithinParens Bool
False) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "."
  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
$ Proxy MText
forall k (t :: k). Proxy t
Proxy @MText)]

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

instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where
  errorDocName :: Text
errorDocName = Text -> Text
forall a. HasCallStack => Text -> a
error "impossible"
  errorDocMdCause :: Markdown
errorDocMdCause = Text -> Markdown
forall a. HasCallStack => Text -> a
error "impossible"
  errorDocHaskellRep :: Markdown
errorDocHaskellRep = Text -> Markdown
forall a. HasCallStack => Text -> a
error "impossible"
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Text -> [SomeDocDefinitionItem]
forall a. HasCallStack => Text -> a
error "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)
$cp1IsoValue :: WellTypedToT UnspecifiedError
IsoValue

instance IsError UnspecifiedError where
  errorToVal :: 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 :: Value t -> Either Text UnspecifiedError
errorFromVal = Value t -> Either Text UnspecifiedError
forall (t :: T) e.
(Typeable t, Typeable (ToT e), IsoValue e) =>
Value t -> Either Text e
isoErrorFromVal

instance ErrorHasDoc UnspecifiedError where
  errorDocName :: Text
errorDocName = "Unspecified error"
  errorDocMdCause :: Markdown
errorDocMdCause = "Some error occured."
  errorDocHaskellRep :: Markdown
errorDocHaskellRep = Proxy () -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference (Proxy ()
forall k (t :: k). Proxy t
Proxy @()) (Bool -> WithinParens
WithinParens Bool
False) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "."
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Proxy () -> [SomeDocDefinitionItem]
forall a. TypeHasDoc a => Proxy a -> [SomeDocDefinitionItem]
typeDocDependencies (Proxy ()
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 e1 :: e
e1 == :: SomeError -> SomeError -> Bool
== SomeError e2 :: e
e2 = e -> e -> Bool
forall a1 a2. (Typeable a1, Typeable a2, Eq a1) => a1 -> a2 -> Bool
eqExt e
e1 e
e2

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

instance Show SomeError where
  show :: SomeError -> String
show = SomeError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty

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

-- | Fail with the given Haskell value.
failUsing
  :: forall e s t.
     (IsError e)
  => e -> s :-> t
failUsing :: e -> s :-> t
failUsing err :: 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
$ \eval :: 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 (Proxy e
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 (t :: T) (inp :: [T]).
ConstantScope t =>
Value' Instr t -> Instr inp (t : inp)
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]).
KnownT a =>
Instr (a : s) out
FAILWITH)

-- | 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 :: MText -> s :-> t
failUnexpected msg :: MText
msg = MText -> s :-> t
forall e (s :: [*]) (t :: [*]). 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) :: Kind.Type

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

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

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

-- | This instance cannot be implemented, use 'IsError' instance instead.
instance (WellTypedIsoValue (ErrorArg 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 (MText, ErrorArg tag))
  toVal :: CustomError tag -> Value (ToT (CustomError tag))
toVal = Text
-> CustomError tag -> Value ('TPair 'TString (ToT (ErrorArg tag)))
forall a. HasCallStack => Text -> a
error "impossible"
  fromVal :: Value (ToT (CustomError tag)) -> CustomError tag
fromVal = Text
-> Value ('TPair 'TString (ToT (ErrorArg tag))) -> CustomError tag
forall a. HasCallStack => Text -> a
error "impossible"

instance (CustomErrorHasDoc tag, KnownError (ErrorArg tag), IsoValue (ErrorArg tag)) =>
         IsError (CustomError tag) where
  errorToVal :: CustomError tag
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal (CustomError l :: Label tag
l arg :: ErrorArg tag
arg) cont :: forall (t :: T). ErrorScope t => Value t -> r
cont =
    Value ('TPair 'TString (ToT (ErrorArg tag))) -> r
forall (t :: T). ErrorScope t => Value t -> r
cont (Value ('TPair 'TString (ToT (ErrorArg tag))) -> r)
-> Value ('TPair 'TString (ToT (ErrorArg tag))) -> r
forall a b. (a -> b) -> a -> b
$ CustomErrorRep tag -> Value (ToT (CustomErrorRep tag))
forall a. IsoValue a => a -> Value (ToT a)
toVal @(CustomErrorRep tag) (Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l, ErrorArg tag
arg)
  errorFromVal :: Value t -> Either Text (CustomError tag)
errorFromVal (Value t
v :: Value t) =
    let expectedTag :: MText
expectedTag = Label tag -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText (forall a. IsLabel tag a => a
forall (x :: Symbol) a. IsLabel x a => a
fromLabel @tag)
    in case Value t -> Maybe (Value ('TPair 'TString (ToT (ErrorArg tag))))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Value t
v of
        Just v' :: Value ('TPair 'TString (ToT (ErrorArg tag)))
v' ->
          let (tag :: MText
tag, arg :: ErrorArg tag
arg) = Value (ToT (CustomErrorRep tag)) -> CustomErrorRep tag
forall a. IsoValue a => Value (ToT a) -> a
fromVal @(CustomErrorRep tag) Value (ToT (CustomErrorRep tag))
Value ('TPair 'TString (ToT (ErrorArg tag)))
v'
          in if MText
tag MText -> MText -> Bool
forall a. Eq a => a -> a -> Bool
== MText
expectedTag
             then CustomError tag -> Either Text (CustomError tag)
forall a b. b -> Either a b
Right (CustomError tag -> Either Text (CustomError tag))
-> CustomError tag -> Either Text (CustomError tag)
forall a b. (a -> b) -> a -> b
$ Label tag -> ErrorArg tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> ErrorArg tag -> CustomError tag
CustomError Label tag
forall (x :: Symbol) a. IsLabel x a => a
fromLabel ErrorArg tag
arg
             else Text -> Either Text (CustomError tag)
forall a b. a -> Either a b
Left (Text -> Either Text (CustomError tag))
-> Text -> Either Text (CustomError tag)
forall a b. (a -> b) -> a -> b
$ "Bad tag, expected " Markdown -> Markdown -> Text
forall b. FromBuilder b => Markdown -> Markdown -> b
+| MText
expectedTag MText -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ ", got " Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| MText
tag MText -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ ""
        Nothing -> Text -> Either Text (CustomError tag)
forall a b. a -> Either a b
Left (Text -> Either Text (CustomError tag))
-> Text -> Either Text (CustomError tag)
forall a b. (a -> b) -> a -> b
$ "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 ((SingKind T, SingI t) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @t)

instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>
         ErrorHasDoc (CustomError tag) where
  errorDocName :: Text
errorDocName = KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = [DType -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (DType -> SomeDocDefinitionItem) -> DType -> SomeDocDefinitionItem
forall a b. (a -> b) -> a -> b
$ Proxy (ErrorArg tag) -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy (ErrorArg tag) -> DType) -> Proxy (ErrorArg tag) -> DType
forall a b. (a -> b) -> a -> b
$ Proxy (ErrorArg tag)
forall k (t :: k). Proxy t
Proxy @(ErrorArg tag)]
  errorDocMdCause :: Markdown
errorDocMdCause = CustomErrorHasDoc tag => Markdown
forall (tag :: Symbol). CustomErrorHasDoc tag => Markdown
customErrDocMdCause @tag
  errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = CustomErrorHasDoc tag => Markdown
forall (tag :: Symbol). CustomErrorHasDoc tag => Markdown
customErrDocMdCauseInEntrypoint @tag
  errorDocClass :: ErrorClass
errorDocClass = CustomErrorHasDoc tag => ErrorClass
forall (tag :: Symbol). CustomErrorHasDoc tag => ErrorClass
customErrClass @tag
  errorDocHaskellRep :: Markdown
errorDocHaskellRep =
    Text -> Proxy tag -> Markdown
forall (tag :: Symbol).
(SingI (ToT (ErrorArg tag)), IsError (CustomError tag),
 TypeHasDoc (ErrorArg tag), CustomErrorHasDoc tag) =>
Text -> Proxy tag -> Markdown
customErrorDocHaskellRepGeneral (Text -> Text
forall b a. (Show a, IsString b) => a -> b
show (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag) (Proxy tag
forall k (t :: k). Proxy t
Proxy @tag)

  type ErrorRequirements (CustomError tag) = (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag)))
  errorDocRequirements :: Dict (ErrorRequirements (CustomError tag))
errorDocRequirements = Dict (ErrorRequirements (CustomError tag))
forall (a :: Constraint). a => Dict a
Dict

-- | Description of error representation in Haskell.
customErrorDocHaskellRepGeneral
  :: ( SingI (ToT (ErrorArg tag)), IsError (CustomError tag)
     , TypeHasDoc (ErrorArg tag), CustomErrorHasDoc tag
     )
  => Text -> Proxy tag -> Markdown
customErrorDocHaskellRepGeneral :: Text -> Proxy tag -> Markdown
customErrorDocHaskellRepGeneral tagName :: Text
tagName (Proxy tag
_ :: Proxy tag) =
  let hasArg :: Bool
hasArg = (SingKind T, SingI (ToT (ErrorArg tag))) => Demote T
forall k (a :: k). (SingKind k, SingI a) => Demote k
demote @(ToT (ErrorArg tag)) T -> T -> Bool
forall a. Eq a => a -> a -> Bool
/= T
TUnit
      tagName' :: Markdown
tagName' = Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
tagName
  in [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ [Maybe Markdown] -> [Markdown]
forall a. [Maybe a] -> [a]
catMaybes
    [ Markdown -> Maybe Markdown
forall a. a -> Maybe a
Just (Markdown -> Maybe Markdown) -> Markdown -> Maybe Markdown
forall a b. (a -> b) -> a -> b
$
        ( if Bool
hasArg
          then Markdown -> Markdown
mdTicked ("(" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
tagName' Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ", " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "<error argument>" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ")")
          else Markdown -> Markdown
mdTicked ("(" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
tagName' Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ", ())")
        ) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "."
    , Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
hasArg Maybe () -> Markdown -> Maybe Markdown
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>
        ("\n\nProvided error argument will be of type "
        Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Proxy (ErrorArg tag) -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference (Proxy (ErrorArg tag)
forall k (t :: k). Proxy t
Proxy @(ErrorArg tag)) (Bool -> WithinParens
WithinParens Bool
False)
        Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> (Markdown -> (Markdown -> Markdown) -> Maybe Markdown -> Markdown
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (\txt :: Markdown
txt -> " and stand for " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
txt) (CustomErrorHasDoc tag => Maybe Markdown
forall (tag :: Symbol). CustomErrorHasDoc tag => Maybe Markdown
customErrArgumentSemantics @tag))
        Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "."
        )
    ]

-- | Demote error tag to term level.
errorTagToMText :: Label tag -> MText
errorTagToMText :: Label tag -> MText
errorTagToMText l :: 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 :: 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 a. IsLabel tag a => a
forall (x :: Symbol) a. IsLabel x a => a
fromLabel @tag)

-- | Fail with given custom error.
failCustom
  :: forall tag err s any.
     ( err ~ ErrorArg tag
     , CustomErrorHasDoc tag
     , KnownError err
     )
  => Label tag -> err : s :-> any
failCustom :: Label tag -> (err : s) :-> any
failCustom l :: 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 (Proxy (CustomError tag)
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 (s :: [*]). (MText & (err & s)) :-> ((MText, err) & s)
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 (s :: [T]) (out :: [T]).
KnownT (ToT (CustomErrorRep tag)) =>
Instr (ToT (CustomErrorRep tag) : s) out
forall (a :: T) (s :: [T]) (out :: [T]).
KnownT a =>
Instr (a : s) out
FAILWITH @(ToT (CustomErrorRep tag)))

type RequireNoArgError tag msg =
  ( TypeErrorUnless (ErrorArg tag == ()) msg
  , msg ~
    ('Text "Expected no-arg error, but given error requires argument of type "
      ':<>: 'ShowType (ErrorArg tag)
    )
  )

-- | Specialization of 'failCustom' for no-arg errors.
failCustom_
  :: forall tag s any notVoidErrorMsg.
     ( RequireNoArgError tag notVoidErrorMsg
     , CustomErrorHasDoc tag
     )
  => Label tag -> s :-> any
failCustom_ :: Label tag -> s :-> any
failCustom_ l :: Label tag
l =
  forall (cond :: Bool) (err :: ErrorMessage) a.
TypeErrorUnless cond err =>
((cond ~ 'True) => a) -> a
forall a.
TypeErrorUnless (ErrorArg tag == ()) notVoidErrorMsg =>
(((ErrorArg tag == ()) ~ 'True) => a) -> a
inTypeErrorUnless @(ErrorArg tag == ()) @notVoidErrorMsg ((((ErrorArg tag == ()) ~ 'True) => s :-> any) -> s :-> any)
-> (((ErrorArg tag == ()) ~ 'True) => s :-> any) -> s :-> any
forall a b. (a -> b) -> a -> b
$
  forall x.
((ErrorArg tag == ()) ~ 'True) =>
((ErrorArg tag ~ ()) => x) -> x
forall k (a :: k) (b :: k) x.
((a == b) ~ 'True) =>
((a ~ b) => x) -> x
reifyTypeEquality @(ErrorArg tag) @() (((ErrorArg tag ~ ()) => s :-> any) -> s :-> any)
-> ((ErrorArg tag ~ ()) => s :-> any) -> s :-> any
forall a b. (a -> b) -> a -> b
$
    s :-> (() & s)
forall (s :: [*]). s :-> (() & s)
unit (s :-> (() & s)) -> ((() & s) :-> any) -> s :-> any
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Label tag -> (() & s) :-> any
forall (tag :: Symbol) err (s :: [*]) (any :: [*]).
(err ~ ErrorArg tag, CustomErrorHasDoc tag, KnownError err) =>
Label tag -> (err : s) :-> any
failCustom Label tag
l

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

instance Eq (ErrorArg tag) => Eq (() -> CustomError tag) where
  e1 :: () -> CustomError tag
e1 == :: (() -> CustomError tag) -> (() -> CustomError tag) -> Bool
== e2 :: () -> CustomError tag
e2 = () -> CustomError tag
e1 () CustomError tag -> CustomError tag -> Bool
forall a. Eq a => a -> a -> Bool
== () -> CustomError tag
e2 ()
instance Show (ErrorArg tag) => Show (() -> CustomError tag) where
  show :: (() -> CustomError tag) -> String
show e :: () -> CustomError tag
e = CustomError tag -> String
forall b a. (Show a, IsString b) => a -> b
show (() -> CustomError tag
e ())

-- | If 'CustomError' constructor is not provided its argument, we assume
-- that this is no-arg error and interpret the passed value as complete.
instance ( Typeable arg
         , IsError (CustomError tag)
         , TypeErrorUnless (arg == ()) notVoidError
         , arg ~ ErrorArg tag
         , notVoidError ~
            ('Text "This error requires argument of type "
              ':<>: 'ShowType (ErrorArg tag)
            )
         ) =>
         IsError (arg -> CustomError tag) where
  errorToVal :: (arg -> CustomError tag)
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal mkCustomError :: arg -> CustomError tag
mkCustomError cont :: forall (t :: T). ErrorScope t => Value t -> r
cont =
    forall (cond :: Bool) (err :: ErrorMessage) a.
TypeErrorUnless cond err =>
((cond ~ 'True) => a) -> a
forall a.
TypeErrorUnless (arg == ()) notVoidError =>
(((arg == ()) ~ 'True) => a) -> a
inTypeErrorUnless @(arg == ()) @notVoidError ((((arg == ()) ~ 'True) => r) -> r)
-> (((arg == ()) ~ 'True) => r) -> r
forall a b. (a -> b) -> a -> b
$
    forall x. ((arg == ()) ~ 'True) => ((arg ~ ()) => x) -> x
forall k (a :: k) (b :: k) x.
((a == b) ~ 'True) =>
((a ~ b) => x) -> x
reifyTypeEquality @arg @() (((arg ~ ()) => r) -> r) -> ((arg ~ ()) => r) -> r
forall a b. (a -> b) -> a -> b
$
      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 :: Value t -> Either Text (arg -> CustomError tag)
errorFromVal v :: Value t
v =
    forall (cond :: Bool) (err :: ErrorMessage) a.
TypeErrorUnless cond err =>
((cond ~ 'True) => a) -> a
forall a.
TypeErrorUnless (arg == ()) notVoidError =>
(((arg == ()) ~ 'True) => a) -> a
inTypeErrorUnless @(arg == ()) @notVoidError ((((arg == ()) ~ 'True) => Either Text (arg -> CustomError tag))
 -> Either Text (arg -> CustomError tag))
-> (((arg == ()) ~ 'True) => Either Text (arg -> CustomError tag))
-> Either Text (arg -> CustomError tag)
forall a b. (a -> b) -> a -> b
$
    forall x. ((arg == ()) ~ 'True) => ((arg ~ ()) => x) -> x
forall k (a :: k) (b :: k) x.
((a == b) ~ 'True) =>
((a ~ b) => x) -> x
reifyTypeEquality @arg @() (((arg ~ ()) => Either Text (arg -> CustomError tag))
 -> Either Text (arg -> CustomError tag))
-> ((arg ~ ()) => Either Text (arg -> CustomError tag))
-> Either Text (arg -> CustomError tag)
forall a b. (a -> b) -> a -> b
$
      Value t -> Either Text (CustomError tag)
forall e (t :: T).
(IsError e, KnownT t) =>
Value t -> Either Text e
errorFromVal Value t
v Either Text (CustomError tag)
-> (CustomError tag -> ErrorArg tag -> CustomError tag)
-> Either Text (ErrorArg tag -> CustomError tag)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(CustomError l :: Label tag
l ()) -> Label tag -> ErrorArg tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> ErrorArg tag -> CustomError tag
CustomError Label tag
l

instance (Typeable arg, ErrorHasDoc (CustomError tag)) =>
         ErrorHasDoc (arg -> CustomError tag) where
  errorDocName :: Text
errorDocName = ErrorHasDoc (CustomError tag) => Text
forall e. ErrorHasDoc e => Text
errorDocName @(CustomError tag)
  errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = ErrorHasDoc (CustomError tag) => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCauseInEntrypoint @(CustomError tag)
  errorDocMdCause :: Markdown
errorDocMdCause = ErrorHasDoc (CustomError tag) => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCause @(CustomError tag)
  errorDocHaskellRep :: Markdown
errorDocHaskellRep = ErrorHasDoc (CustomError tag) => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocHaskellRep @(CustomError tag)
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = ErrorHasDoc (CustomError tag) => [SomeDocDefinitionItem]
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 (ErrorClass -> Q Exp
(ErrorClass -> Q Exp) -> Lift ErrorClass
forall t. (t -> Q Exp) -> Lift t
lift :: ErrorClass -> Q Exp
$clift :: ErrorClass -> Q Exp
Lift)

instance Read ErrorClass where
  readsPrec :: Int -> ReadS ErrorClass
readsPrec _ = \case
    "exception" -> [(ErrorClass
ErrClassActionException, "")]
    "bad-argument" -> [(ErrorClass
ErrClassBadArgument, "")]
    "contract-internal" -> [(ErrorClass
ErrClassContractInternal, "")]
    "unknown" -> [(ErrorClass
ErrClassUnknown, "")]
    _ -> []

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

isInternalErrorClass :: ErrorClass -> Bool
isInternalErrorClass :: ErrorClass -> Bool
isInternalErrorClass = \case
  ErrClassActionException -> Bool
False
  ErrClassBadArgument -> Bool
False
  ErrClassContractInternal -> Bool
True
  ErrClassUnknown -> Bool
False

class (KnownSymbol tag, TypeHasDoc (ErrorArg 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 = Markdown -> Markdown
pickFirstSentence (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ CustomErrorHasDoc tag => Markdown
forall (tag :: Symbol). CustomErrorHasDoc tag => Markdown
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 ':!'.
  --
  -- 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 Markdown
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 e1 :: Proxy e
e1 == :: DError -> DError -> Bool
== DError e2 :: Proxy e
e2 = Proxy e
e1 Proxy e -> Proxy e -> Bool
forall k (a1 :: k) (a2 :: k) (t :: k -> *).
(Typeable a1, Typeable a2, Eq (t a1)) =>
t a1 -> t a2 -> Bool
`eqParam1` Proxy e
e2
instance Ord DError where
  DError e1 :: Proxy e
e1 compare :: DError -> DError -> Ordering
`compare` DError e2 :: 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 = 5010
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just "Errors"
  docItemSectionDescription :: Maybe Markdown
docItemSectionDescription = Markdown -> Maybe Markdown
forall a. a -> Maybe a
Just Markdown
errorsDocumentation
  docItemRef :: DError
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
docItemRef (DError (Proxy e
_ :: Proxy e)) = DocItemId
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
DocItemId -> DocItemRef 'DocItemInDefinitions 'True
DocItemRef (DocItemId
 -> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError))
-> DocItemId
-> DocItemRef (DocItemPlacement DError) (DocItemReferenced DError)
forall a b. (a -> b) -> a -> b
$
    Text -> DocItemId
DocItemId ("errors-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ErrorHasDoc e => Text
forall e. ErrorHasDoc e => Text
errorDocName @e)
  docItemToMarkdown :: HeaderLevel -> DError -> Markdown
docItemToMarkdown lvl :: HeaderLevel
lvl (DError (Proxy e
_ :: Proxy e)) =
    [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
    [ Markdown
mdSeparator
    , HeaderLevel -> Markdown -> Markdown
mdHeader HeaderLevel
lvl (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> (Text -> Markdown) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Text
forall e. ErrorHasDoc e => Text
errorDocName @e)
    , Markdown -> Markdown -> Markdown
mdSubsection "Class" (ErrorClass -> Markdown
forall p. Buildable p => p -> Markdown
build (ErrorClass -> Markdown) -> ErrorClass -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => ErrorClass
forall e. ErrorHasDoc e => ErrorClass
errorDocClass @e)
    , "\n\n"
    , Markdown -> Markdown -> Markdown
mdSubsection "Fires if" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCause @e
    , "\n\n"
    , Markdown -> Markdown -> Markdown
mdSubsection "Representation" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocHaskellRep @e
    ]
  docItemToToc :: HeaderLevel -> DError -> Markdown
docItemToToc lvl :: HeaderLevel
lvl d :: DError
d@(DError (Proxy e
_ :: Proxy e)) =
    HeaderLevel -> Markdown -> DError -> Markdown
forall d.
(DocItem d, DocItemReferenced d ~ 'True) =>
HeaderLevel -> Markdown -> d -> Markdown
mdTocFromRef HeaderLevel
lvl (Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Text
forall e. ErrorHasDoc e => Text
errorDocName @e) DError
d

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

errorDocMdReference :: forall e. ErrorHasDoc e => Markdown
errorDocMdReference :: Markdown
errorDocMdReference =
  let DocItemRef docItemId = DError -> DocItemRef 'DocItemInDefinitions 'True
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef (DError -> DocItemRef 'DocItemInDefinitions 'True)
-> DError -> DocItemRef 'DocItemInDefinitions 'True
forall a b. (a -> b) -> a -> b
$ Proxy e -> DError
forall e. ErrorHasDoc e => Proxy e -> DError
DError (Proxy e
forall k (t :: k). Proxy t
Proxy @e)
  in Markdown -> DocItemId -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef (Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> (Text -> Markdown) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ ErrorHasDoc e => Text
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 e1 :: Proxy e
e1 == :: DThrows -> DThrows -> Bool
== DThrows e2 :: Proxy e
e2 = Proxy e -> Proxy e -> Bool
forall k (a1 :: k) (a2 :: k) (t :: k -> *).
(Typeable a1, Typeable a2, Eq (t a1)) =>
t a1 -> t a2 -> Bool
eqParam1 Proxy e
e1 Proxy e
e2

instance DocItem DThrows where
  docItemPos :: Natural
docItemPos = 5011
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just "Possible errors"
  docItemSectionNameStyle :: DocSectionNameStyle
docItemSectionNameStyle = DocSectionNameStyle
DocSectionNameSmall
  docItemDependencies :: DThrows -> [SomeDocDefinitionItem]
docItemDependencies (DThrows ds :: 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 -> Markdown
docItemToMarkdown _ (DThrows (Proxy e
_ :: Proxy e)) =
    "* " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ErrorHasDoc e => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdReference @e Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> " — " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ErrorHasDoc e => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCauseInEntrypoint @e
  docItemsOrder :: [DThrows] -> [DThrows]
docItemsOrder =
    let errType :: DThrows -> ErrorClass
errType (DThrows (Proxy e
_ :: Proxy e)) = ErrorHasDoc e => ErrorClass
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 -> Bool) -> [DThrows] -> [DThrows]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
Prelude.not (Bool -> Bool) -> (DThrows -> Bool) -> DThrows -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorClass -> Bool
isInternalErrorClass (ErrorClass -> Bool) -> (DThrows -> ErrorClass) -> DThrows -> Bool
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 :: Markdown
typeDocMdDescriptionReferToError =
  "This type is primarily used as error, see " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
  Markdown -> DError -> Markdown
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
Markdown -> d -> Markdown
docDefinitionRef "description in section with errors" (Proxy e -> DError
forall e. ErrorHasDoc e => Proxy e -> DError
DError (Proxy e
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 :: Markdown
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.

  Most of the errors are represented according to the same
  `(error tag, error argument)` pattern. See the list of errors below
  for details.

  We distinquish several error classes:
  + #{mdBold $ build 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.

  + #{mdBold $ build 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.

  + #{mdBold $ build 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.
  |]