{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.Errors
(
IsError (..)
, ErrorScope
, isoErrorToVal
, isoErrorFromVal
, ErrorHasDoc (..)
, typeDocMdDescriptionReferToError
, isInternalErrorClass
, UnspecifiedError (..)
, SomeError (..)
, failUsing
, failUnexpected
, NoErrorArg
, UnitErrorArg
, ErrorArg
, CustomError (..)
, CustomErrorRep
, IsCustomErrorArgRep (..)
, MustHaveErrorArg
, failCustom
, failCustom_
, failCustomNoArg
, ErrorClass (..)
, CustomErrorHasDoc (..)
, DError (..)
, DThrows (..)
, 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 Util.Markdown
import Util.Type
import Util.Typeable
import Util.TypeLits
type ErrorScope t =
( Typeable t
, ConstantScope t
)
type KnownError a = ErrorScope (ToT a)
class (Typeable e, ErrorHasDoc e) => IsError e where
errorToVal :: e -> (forall t. ErrorScope t => Value t -> r) -> r
errorFromVal :: (KnownT t) => Value t -> Either Text e
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
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
errorDocName :: Text
errorDocMdCause :: Markdown
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
errorDocHaskellRep :: Markdown
errorDocClass :: ErrorClass
errorDocClass = ErrorClass
ErrClassUnknown
errorDocDependencies :: [SomeDocDefinitionItem]
type ErrorRequirements e :: Constraint
type ErrorRequirements e = ()
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 :: 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
"" -> ""
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 occurred."
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"
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 occurred."
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 @())
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
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, ConstantScope a) =>
Instr (a : s) out
FAILWITH)
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
type family ErrorArg (tag :: Symbol) :: Kind.Type
data CustomError (tag :: Symbol) = CustomError
{ CustomError tag -> Label tag
ceTag :: Label tag
, CustomError tag -> CustomErrorRep tag
ceArg :: CustomErrorRep tag
}
deriving stock instance Eq (CustomErrorRep tag) => Eq (CustomError tag)
deriving stock instance Show (CustomErrorRep tag) => Show (CustomError tag)
instance Buildable (CustomError tag) where
build :: CustomError tag -> Markdown
build (CustomError tg :: Label tag
tg _err :: CustomErrorRep tag
_err) = "CustomError #" Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Label tag -> Markdown
forall p. Buildable p => p -> Markdown
build Label tag
tg
data NoErrorArg
data UnitErrorArg
type CustomErrorRep tag = CustomErrorArgRep (ErrorArg tag)
type family CustomErrorArgRep (errArg :: Kind.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 expectedTag :: MText
expectedTag tag :: MText
tag =
if MText
tag MText -> MText -> Bool
forall a. Eq a => a -> a -> Bool
== 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
$ "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
|+ ""
customErrorRepDocDeps :: [SomeDocDefinitionItem]
customErrorRepDocDeps = []
customErrorHaskellRep :: Proxy tag -> Markdown
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) =
Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ Text -> Markdown
forall p. Buildable p => p -> Markdown
build (KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag)
instance (TypeHasDoc errArg)
=> IsCustomErrorArgRep (MText, errArg) where
verifyErrorTag :: MText -> (MText, errArg) -> Either Text (MText, errArg)
verifyErrorTag expectedTag :: MText
expectedTag (tag :: MText
tag, arg :: errArg
arg) =
if MText
tag MText -> MText -> Bool
forall a. Eq a => a -> a -> Bool
== 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
$ "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
|+ ""
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
$ Proxy errArg
forall k (t :: k). Proxy t
Proxy @errArg ]
customErrorHaskellRep :: Proxy tag -> Markdown
customErrorHaskellRep (Proxy tag
_ :: Proxy tag) = [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
[ Markdown -> Markdown
mdTicked ("(" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Text -> Markdown
forall p. Buildable p => p -> Markdown
build (KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag) 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
<> ")")
, ("\n\nProvided error argument will be of type "
Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Proxy (MText, errArg) -> WithinParens -> Markdown
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Markdown
typeDocMdReference (Proxy (MText, errArg)
forall k (t :: k). Proxy t
Proxy @(MText, errArg)) (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
<> "."
)
]
instance (WellTypedIsoValue (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 = Text -> CustomError tag -> Value (ToT (CustomErrorRep tag))
forall a. HasCallStack => Text -> a
error "impossible"
fromVal :: Value (ToT (CustomError tag)) -> CustomError tag
fromVal = Text -> Value (ToT (CustomErrorRep tag)) -> CustomError tag
forall a. HasCallStack => Text -> a
error "impossible"
instance ( CustomErrorHasDoc tag
, KnownError (CustomErrorRep tag)
, IsoValue (CustomErrorRep tag)
, IsCustomErrorArgRep (CustomErrorRep tag)
)
=> IsError (CustomError tag) where
errorToVal :: CustomError tag
-> (forall (t :: T). ErrorScope t => Value t -> r) -> r
errorToVal (CustomError _ arg :: CustomErrorRep tag
arg) cont :: 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
$ CustomErrorRep tag -> Value (ToT (CustomErrorRep tag))
forall a. IsoValue a => a -> Value (ToT a)
toVal @(CustomErrorRep tag) CustomErrorRep 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 (ToT (CustomErrorRep tag)))
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Value t
v of
Just v' :: Value (ToT (CustomErrorRep tag))
v' -> do
CustomErrorRep tag
errArg <- MText -> CustomErrorRep tag -> Either Text (CustomErrorRep tag)
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
$ Value (ToT (CustomErrorRep tag)) -> CustomErrorRep tag
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
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
, IsCustomErrorArgRep (CustomErrorRep tag)
)
=> ErrorHasDoc (CustomError tag) where
errorDocName :: Text
errorDocName = KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag
errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = IsCustomErrorArgRep (CustomErrorRep tag) => [SomeDocDefinitionItem]
forall a. IsCustomErrorArgRep a => [SomeDocDefinitionItem]
customErrorRepDocDeps @(CustomErrorRep 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 = Proxy tag -> Markdown
forall a (tag :: Symbol).
(IsCustomErrorArgRep a, KnownSymbol tag, CustomErrorHasDoc tag) =>
Proxy tag -> Markdown
customErrorHaskellRep @(CustomErrorRep tag) (Proxy tag
forall k (t :: k). 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 :: Label tag -> MText
errorTagToMText l :: 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 :: 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)
failCustom
:: forall tag err s any.
( MustHaveErrorArg tag (MText, err)
, 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 (MText, err)), ConstantScope (ToT (MText, err))) =>
Instr (ToT (MText, err) : s) out
forall (a :: T) (s :: [T]) (out :: [T]).
(KnownT 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 :: Label tag -> s :-> any
failCustomNoArg l :: 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 (Proxy (CustomError tag)
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 (s :: [T]) (out :: [T]).
(KnownT (ToT MText), ConstantScope (ToT MText)) =>
Instr (ToT MText : s) out
forall (a :: T) (s :: [T]) (out :: [T]).
(KnownT a, ConstantScope a) =>
Instr (a : s) out
FAILWITH @(ToT (MText)))
type MustHaveErrorArg errorTag expectedArgRep =
( TypeErrorUnless (CustomErrorRep errorTag == expectedArgRep)
('Text "Error argument type is "
':<>: 'ShowType (expectedArgRep)
':<>: 'Text " but given error requires argument of type "
':<>: 'ShowType (CustomErrorRep errorTag)
)
, CustomErrorRep errorTag ~ expectedArgRep
)
failCustom_
:: forall tag s any.
( MustHaveErrorArg tag (MText, ())
, CustomErrorHasDoc tag
)
=> Label tag -> s :-> any
failCustom_ :: Label tag -> s :-> any
failCustom_ l :: Label tag
l =
forall x.
((CustomErrorRep tag == (MText, ())) ~ 'True) =>
((CustomErrorRep tag ~ (MText, ())) => x) -> x
forall k (a :: k) (b :: k) x.
((a == b) ~ 'True) =>
((a ~ b) => x) -> x
reifyTypeEquality @(CustomErrorRep tag) @(MText, ()) (((CustomErrorRep tag ~ (MText, ())) => s :-> any) -> s :-> any)
-> ((CustomErrorRep tag ~ (MText, ())) => s :-> any) -> s :-> any
forall a b. (a -> b) -> a -> b
$
DThrows -> s :-> 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))) (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 (s :: [*]). (MText : () : s) :-> ((MText, ()) : s)
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 (s :: [T]) (out :: [T]).
(KnownT (ToT (MText, ())), ConstantScope (ToT (MText, ()))) =>
Instr (ToT (MText, ()) : s) out
forall (a :: T) (s :: [T]) (out :: [T]).
(KnownT a, ConstantScope a) =>
Instr (a : s) out
FAILWITH @(ToT (MText, ())))
instance Eq (CustomErrorRep 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 (CustomErrorRep 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 ())
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 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 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 -> () -> CustomError tag)
-> Either Text (() -> CustomError tag)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(CustomError l :: Label tag
l (a, ())) -> \b :: ()
b -> Label tag -> CustomErrorRep tag -> CustomError tag
forall (tag :: Symbol).
Label tag -> CustomErrorRep tag -> CustomError tag
CustomError Label tag
l (MText
a, ()
b)
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)
data ErrorClass
= ErrClassActionException
| ErrClassBadArgument
| ErrClassContractInternal
| ErrClassUnknown
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 (CustomErrorRep tag), IsError (CustomError tag)) =>
CustomErrorHasDoc tag where
customErrDocMdCause :: Markdown
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
customErrClass :: ErrorClass
customErrClass = ErrorClass
ErrClassUnknown
customErrArgumentSemantics :: Maybe Markdown
customErrArgumentSemantics = Maybe Markdown
forall a. Maybe a
Nothing
{-# MINIMAL customErrDocMdCause, customErrClass #-}
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
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)
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))
errorsDocumentation :: Markdown
errorsDocumentation :: Markdown
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:
+ #{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.
|]