{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.Errors
(
IsError (..)
, ErrorScope
, ConstantScope
, isoErrorToVal
, isoErrorFromVal
, simpleFailUsing
, ErrorHasDoc (..)
, typeDocMdDescriptionReferToError
, isInternalErrorClass
, UnspecifiedError (..)
, Impossible (..)
, SomeError (..)
, failUnexpected
, NoErrorArg
, UnitErrorArg
, ErrorArg
, CustomError (..)
, CustomErrorRep
, IsCustomErrorArgRep (..)
, MustHaveErrorArg
, failCustom
, failCustom_
, failCustomNoArg
, ErrorClass (..)
, CustomErrorHasDoc (..)
, DError (..)
, DThrows (..)
, errorTagToText
, errorTagToMText
) where
import Data.Char qualified as C
import Data.Constraint (Bottom(..))
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.Typeable
import Morley.Util.TypeLits
type ErrorScope t = ConstantScope t
type KnownError a = ErrorScope (ToT a)
class (ErrorHasDoc e) => IsError e where
errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r
errorFromVal :: (SingI t) => Value t -> Either Text e
failUsing :: (IsError e) => e -> s :-> t
failUsing = e -> s :-> t
forall e (s :: [*]) (t :: [*]). IsError e => e -> s :-> t
simpleFailUsing
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
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
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
errorDocName :: Text
errorDocMdCause :: Markdown
errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = Doc -> Doc
pickFirstSentence (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Doc
errorDocMdCause @e
errorDocHaskellRep :: Markdown
errorDocClass :: ErrorClass
errorDocClass = ErrorClass
ErrClassUnknown
errorDocDependencies :: [SomeDocDefinitionItem]
type ErrorRequirements e :: Constraint
type ErrorRequirements _ = ()
errorDocRequirements :: Dict (ErrorRequirements e)
default errorDocRequirements :: ErrorRequirements e => Dict (ErrorRequirements e)
errorDocRequirements = Dict (ErrorRequirements e)
forall (a :: Constraint). a => Dict a
Dict
pickFirstSentence :: Markdown -> Markdown
pickFirstSentence :: Doc -> Doc
pickFirstSentence = Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> (Doc -> Text) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Doc -> String) -> Doc -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go (String -> String) -> (Doc -> String) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. FromDoc a => Doc -> a
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
""
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 :: Doc
errorDocMdCause =
Doc
"Some internal error occurred."
errorDocHaskellRep :: Doc
errorDocHaskellRep =
Doc
"Textual error message, see " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
Proxy MText -> WithinParens -> Doc
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Doc
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MText) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
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 (Bottom, 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
_ = r
forall a. Bottom => a
no
errorFromVal :: forall (t :: T). SingI t => Value t -> Either Text ()
errorFromVal = forall a. Bottom => a
Value t -> Either Text ()
no
instance (Bottom, TypeError ('Text "Use representative error messages")) => ErrorHasDoc () where
errorDocName :: Text
errorDocName = Text
forall a. Bottom => a
no
errorDocMdCause :: Doc
errorDocMdCause = Doc
forall a. Bottom => a
no
errorDocHaskellRep :: Doc
errorDocHaskellRep = Doc
forall a. Bottom => a
no
errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = [SomeDocDefinitionItem]
forall a. Bottom => a
no
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 :: Doc
errorDocMdCause = Doc
"Some error occurred."
errorDocHaskellRep :: Doc
errorDocHaskellRep = Proxy () -> WithinParens -> Doc
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Doc
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @()) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Proxy () -> [SomeDocDefinitionItem]
forall a. TypeHasDoc a => Proxy a -> [SomeDocDefinitionItem]
typeDocDependencies (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @())
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 :: Doc
errorDocMdCause =
Doc
"An impossible error happened.\n\n\
\If this error occured, contact the contract authors."
errorDocHaskellRep :: Doc
errorDocHaskellRep = Proxy () -> WithinParens -> Doc
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Doc
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @()) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = Proxy () -> [SomeDocDefinitionItem]
forall a. TypeHasDoc a => Proxy a -> [SomeDocDefinitionItem]
typeDocDependencies (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @())
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 -> Doc
build (SomeError e
e) = e -> (forall (t :: T). ErrorScope t => Value t -> Doc) -> Doc
forall e r.
IsError e =>
e -> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal e
e (Value -> Doc
forall a. Buildable a => a -> Doc
build (Value -> Doc)
-> (Value' Instr t -> Value) -> Value' Instr t -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value' Instr t -> Value
forall (t :: T). ForbidOp t => Value' Instr t -> Value
untypeValue)
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
type family ErrorArg (tag :: Symbol) :: Type
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 {-# overlappable #-} Buildable (CustomError tag) where
build :: CustomError tag -> Doc
build (CustomError Label tag
tg CustomErrorRep tag
_err) = Doc
"CustomError #" Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| Label tag -> Doc
forall a. Buildable a => a -> Doc
build Label tag
tg
data NoErrorArg
data UnitErrorArg
type CustomErrorRep tag = CustomErrorArgRep (ErrorArg tag)
type family CustomErrorArgRep (errArg :: Type) where
CustomErrorArgRep NoErrorArg = MText
CustomErrorArgRep UnitErrorArg = (MText, ())
CustomErrorArgRep errArg = (MText, errArg)
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
$ Doc
"Bad tag, expected " Doc -> Doc -> Text
forall b. FromDoc b => Doc -> Doc -> b
+| MText
expectedTag MText -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
", got " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MText
tag MText -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
customErrorRepDocDeps :: [SomeDocDefinitionItem]
customErrorRepDocDeps = []
customErrorHaskellRep :: forall (tag :: Symbol).
(KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Doc
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) =
Doc -> Doc
mdTicked (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
forall a. Buildable a => a -> Doc
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
$ Doc
"Bad tag, expected " Doc -> Doc -> Text
forall b. FromDoc b => Doc -> Doc -> b
+| MText
expectedTag MText -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
", got " Doc -> Doc -> Doc
forall b. FromDoc b => Doc -> Doc -> b
+| MText
tag MText -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
""
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 -> Doc
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
[ Doc -> Doc
mdTicked (Doc
"(" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Buildable a => a -> Doc
build (forall (s :: Symbol). KnownSymbol s => Text
errorTagToText @tag) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
", " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"<error argument>" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")")
, (Doc
"\n\nProvided error argument will be of type "
Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Proxy (MText, errArg) -> WithinParens -> Doc
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Doc
typeDocMdReference (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(MText, errArg)) (DocItemReferencedKind -> WithinParens
WithinParens DocItemReferencedKind
False)
Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (Doc -> (Doc -> Doc) -> Maybe Doc -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"" (\Doc
txt -> Doc
" and stand for " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
txt) (forall (tag :: Symbol). CustomErrorHasDoc tag => Maybe Doc
customErrArgumentSemantics @tag))
Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
)
]
instance (Bottom, WellTypedToT (CustomErrorRep tag), TypeError ('Text "CustomError has no IsoValue instance")) =>
IsoValue (CustomError tag) where
type ToT (CustomError tag) = (ToT (CustomErrorRep tag))
toVal :: CustomError tag -> Value (ToT (CustomError tag))
toVal = forall a. Bottom => a
CustomError tag -> Value (ToT (CustomError tag))
no
fromVal :: Value (ToT (CustomError tag)) -> CustomError tag
fromVal = forall a. Bottom => a
Value (ToT (CustomError tag)) -> CustomError tag
no
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, FromDoc 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 :: Doc
errorDocMdCause = forall (tag :: Symbol). CustomErrorHasDoc tag => Doc
customErrDocMdCause @tag
errorDocMdCauseInEntrypoint :: Doc
errorDocMdCauseInEntrypoint = forall (tag :: Symbol). CustomErrorHasDoc tag => Doc
customErrDocMdCauseInEntrypoint @tag
errorDocClass :: ErrorClass
errorDocClass = forall (tag :: Symbol). CustomErrorHasDoc tag => ErrorClass
customErrClass @tag
errorDocHaskellRep :: Doc
errorDocHaskellRep = forall a (tag :: Symbol).
(IsCustomErrorArgRep a, KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Doc
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
errorTagToMText :: Label tag -> MText
errorTagToMText :: forall (tag :: Symbol). Label tag -> MText
errorTagToMText Label tag
l =
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)
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)))
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)
)
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, ())))
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 :: Doc
errorDocMdCauseInEntrypoint = forall e. ErrorHasDoc e => Doc
errorDocMdCauseInEntrypoint @(CustomError tag)
errorDocMdCause :: Doc
errorDocMdCause = forall e. ErrorHasDoc e => Doc
errorDocMdCause @(CustomError tag)
errorDocHaskellRep :: Doc
errorDocHaskellRep = forall e. ErrorHasDoc e => Doc
errorDocHaskellRep @(CustomError tag)
errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = forall e. ErrorHasDoc e => [SomeDocDefinitionItem]
errorDocDependencies @(CustomError tag)
data ErrorClass
= ErrClassActionException
| ErrClassBadArgument
| ErrClassContractInternal
| ErrClassUnknown
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 -> Doc
build = \case
ErrorClass
ErrClassActionException -> Doc
"Action exception"
ErrorClass
ErrClassBadArgument -> Doc
"Bad argument"
ErrorClass
ErrClassContractInternal -> Doc
"Internal"
ErrorClass
ErrClassUnknown -> Doc
"-"
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
customErrDocMdCause :: Markdown
customErrDocMdCauseInEntrypoint :: Markdown
customErrDocMdCauseInEntrypoint = Doc -> Doc
pickFirstSentence (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ forall (tag :: Symbol). CustomErrorHasDoc tag => Doc
customErrDocMdCause @tag
customErrClass :: ErrorClass
customErrClass = ErrorClass
ErrClassUnknown
customErrArgumentSemantics :: Maybe Markdown
customErrArgumentSemantics = Maybe Doc
forall a. Maybe a
Nothing
{-# MINIMAL customErrDocMdCause, customErrClass #-}
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 Doc
docItemSectionDescription = Doc -> Maybe Doc
forall a. a -> Maybe a
Just Doc
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 -> Doc
docItemToMarkdown HeaderLevel
lvl (DError (Proxy e
_ :: Proxy e)) =
[Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
[ Doc
mdSeparator
, HeaderLevel -> Doc -> Doc
mdHeader HeaderLevel
lvl (Doc -> Doc
mdTicked (Doc -> Doc) -> (Text -> Doc) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Text
errorDocName @e)
, Doc -> Doc -> Doc
mdSubsection Doc
"Class" (ErrorClass -> Doc
forall a. Buildable a => a -> Doc
build (ErrorClass -> Doc) -> ErrorClass -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => ErrorClass
errorDocClass @e)
, Doc
"\n\n"
, Doc -> Doc -> Doc
mdSubsection Doc
"Fires if" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Doc
errorDocMdCause @e
, Doc
"\n\n"
, Doc -> Doc -> Doc
mdSubsection Doc
"Representation" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Doc
errorDocHaskellRep @e
]
docItemToToc :: HeaderLevel -> DError -> Doc
docItemToToc HeaderLevel
lvl d :: DError
d@(DError (Proxy e
_ :: Proxy e)) =
HeaderLevel -> Doc -> DError -> Doc
forall d.
(DocItem d, DocItemReferenced d ~ 'True) =>
HeaderLevel -> Doc -> d -> Doc
mdTocFromRef HeaderLevel
lvl (Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> Text -> Doc
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 => Doc
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 Doc -> DocItemId -> Doc
forall anchor. ToAnchor anchor => Doc -> anchor -> Doc
mdLocalRef (Doc -> Doc
mdTicked (Doc -> Doc) -> (Text -> Doc) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ forall e. ErrorHasDoc e => Text
errorDocName @e) DocItemId
docItemId
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 -> Doc
docItemToMarkdown HeaderLevel
_ (DThrows (Proxy e
_ :: Proxy e)) =
Doc
"* " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> forall e. ErrorHasDoc e => Doc
errorDocMdReference @e Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" — " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> forall e. ErrorHasDoc e => Doc
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
forall a. Boolean a => a -> a
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)
typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown
typeDocMdDescriptionReferToError :: forall e. IsError e => Doc
typeDocMdDescriptionReferToError =
Doc
"This type is primarily used as error, see " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
Doc -> DError -> Doc
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
Doc -> d -> Doc
docDefinitionRef Doc
"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))
errorsDocumentation :: Markdown
errorsDocumentation :: Doc
errorsDocumentation =
[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 :: Doc
errClassActionException = Doc -> Doc
mdBold (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Doc
forall a. Buildable a => a -> Doc
build ErrorClass
ErrClassActionException
errClassBadArgument :: Doc
errClassBadArgument = Doc -> Doc
mdBold (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Doc
forall a. Buildable a => a -> Doc
build ErrorClass
ErrClassBadArgument
errClassContractInternal :: Doc
errClassContractInternal = Doc -> Doc
mdBold (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ ErrorClass -> Doc
forall a. Buildable a => a -> Doc
build ErrorClass
ErrClassContractInternal