{-# LANGUAGE DerivingStrategies, DeriveAnyClass #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.Errors
(
IsError (..)
, isoErrorToVal
, isoErrorFromVal
, ErrorHasDoc (..)
, typeDocMdDescriptionReferToError
, UnspecifiedError (..)
, failUsing
, failUnexpected
, ErrorArg
, CustomError (..)
, failCustom
, failCustom_
, ErrorClass (..)
, CustomErrorHasDoc (..)
, DError (..)
, DThrows (..)
, customErrorToVal
, customErrorFromVal
, failUsingArg
, FailUsingArg
, CustomErrorNoIsoValue
, deriveCustomError
, errorsDocumentation
) where
import Data.Singletons (SingI(..), demote)
import qualified Data.Char as C
import qualified Data.List as L
import Data.Typeable (cast)
import qualified Text.Show
import qualified Language.Haskell.TH as TH
import Data.Vinyl.Derived (Label)
import Data.Constraint (Dict (..))
import Fmt ((+|), (+||), (|+), (||+), pretty, fmt, build, Buildable)
import qualified Data.Kind as Kind
import Data.Type.Equality (type (==))
import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal, Symbol)
import Lorentz.Base
import Lorentz.Doc
import Lorentz.Instr hiding (cast)
import Lorentz.Value
import Michelson.Text
import Michelson.Typed.Haskell
import Michelson.Typed.Instr
import Michelson.Typed.Scope
import Michelson.Typed.Sing
import Michelson.Typed.T
import Michelson.Typed.Value
import Util.Typeable
import Util.TypeLits
import Util.Type
import Util.Markdown
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 :: (Typeable t, SingI t) => Value t -> Either Text e
isoErrorToVal
:: (KnownError e, IsoValue e)
=> e -> (forall t. ErrorScope t => Value t -> r) -> r
isoErrorToVal e cont = cont $ toVal e
isoErrorFromVal
:: (Typeable t, Typeable (ToT e), IsoValue e)
=> Value t -> Either Text e
isoErrorFromVal e = fromVal <$> gcastE e
class ErrorHasDoc e where
errorDocName :: Text
errorDocMdCause :: Markdown
errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = pickFirstSentence $ errorDocMdCause @e
errorDocHaskellRep :: Markdown
errorDocClass :: ErrorClass
errorDocClass = ErrClassUnknown
errorDocDependencies :: [SomeDocDefinitionItem]
pickFirstSentence :: Markdown -> Markdown
pickFirstSentence = build . toText . go . fmt
where
go :: String -> String
go = \case
'.' : c : _ | C.isSpace c -> "."
c : s -> c : go s
"" -> ""
instance IsError MText where
errorToVal = isoErrorToVal
errorFromVal = isoErrorFromVal
instance ErrorHasDoc MText where
errorDocName = "InternalError"
errorDocMdCause =
"Internal error occured."
errorDocHaskellRep =
"Textual error message, see " <>
typeDocMdReference (Proxy @MText) (WithinParens False) <> "."
errorDocClass = ErrClassContractInternal
errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @MText)]
instance TypeError ('Text "Use representative error messages") => IsError () where
errorToVal _ _ = error "impossible"
errorFromVal = error "impossible"
instance TypeError ('Text "Use representative error messages") => ErrorHasDoc () where
errorDocName = error "impossible"
errorDocMdCause = error "impossible"
errorDocHaskellRep = error "impossible"
errorDocDependencies = error "impossible"
data UnspecifiedError = UnspecifiedError
deriving stock Generic
deriving anyclass IsoValue
instance IsError UnspecifiedError where
errorToVal = isoErrorToVal
errorFromVal = isoErrorFromVal
instance ErrorHasDoc UnspecifiedError where
errorDocName = "Unspecified error"
errorDocMdCause = "Some error occured."
errorDocHaskellRep = typeDocMdReference (Proxy @()) (WithinParens False) <> "."
errorDocDependencies = typeDocDependencies' (Proxy @())
failUsing
:: forall e s t.
(IsError e)
=> e -> s :-> t
failUsing err =
errorToVal err $ \eval ->
doc (DThrows (Proxy @e)) #
(FI $ PUSH eval `Seq` FAILWITH)
failUnexpected :: MText -> s :-> t
failUnexpected msg = failUsing $ [mt|Internal: |] <> msg
type family ErrorArg (tag :: Symbol) :: Kind.Type
data CustomError (tag :: Symbol) = CustomError
{ ceTag :: Label tag
, ceArg :: ErrorArg tag
}
deriving stock instance Eq (ErrorArg tag) => Eq (CustomError tag)
deriving stock instance Show (ErrorArg tag) => Show (CustomError tag)
type CustomErrorRep tag = (MText, ErrorArg tag)
instance TypeError ('Text "CustomError has no IsoValue instance") =>
IsoValue (CustomError tag) where
type ToT (CustomError tag) = TypeError ('Text "CustomError has no IsoValue instance")
toVal = error "impossible"
fromVal = error "impossible"
instance (CustomErrorHasDoc tag, KnownError (ErrorArg tag), IsoValue (ErrorArg tag)) =>
IsError (CustomError tag) where
errorToVal (CustomError l arg) cont =
cont $ toVal @(CustomErrorRep tag) (errorTagToMText l, arg)
errorFromVal (v :: Value t) =
let expectedTag = errorTagToMText (fromLabel @tag)
in case cast v of
Just v' ->
let (tag, arg) = fromVal @(CustomErrorRep tag) v'
in if tag == expectedTag
then Right $ CustomError fromLabel arg
else Left $ "Bad tag, expected " +| expectedTag |+ ", got " +| tag |+ ""
Nothing -> Left $ "Wrong type for custom error: " <> pretty (demote @t)
instance (CustomErrorHasDoc tag, SingI (ToT (ErrorArg tag))) =>
ErrorHasDoc (CustomError tag) where
errorDocName = errorTagToText @tag
errorDocDependencies = typeDocDependencies' (Proxy @(ErrorArg tag))
errorDocMdCause = customErrDocMdCause @tag
errorDocMdCauseInEntrypoint = customErrDocMdCauseInEntrypoint @tag
errorDocClass = customErrClass @tag
errorDocHaskellRep =
let hasArg = demote @(ToT (ErrorArg tag)) /= TUnit
name = build $ errorTagToText @tag
in mconcat $ catMaybes
[ Just $
( if hasArg
then mdTicked ("(\"" <> name <> "\", " <> "<error argument>" <> ")")
else mdTicked ("(\"" <> name <> "\", ())")
) <> "."
, guard hasArg $>
("\n\nProvided error argument will be of type "
<> typeDocMdReference (Proxy @(ErrorArg tag)) (WithinParens False)
<> (maybe "" (\txt -> " and stand for " <> txt) (customErrArgumentSemantics @tag))
<> "."
)
]
errorTagToMText :: KnownSymbol tag => Label tag -> MText
errorTagToMText l =
mtextHeadToUpper $
labelToMText l
errorTagToText :: forall tag. KnownSymbol tag => Text
errorTagToText = toText $ errorTagToMText (fromLabel @tag)
failCustom
:: forall tag err s any.
( err ~ ErrorArg tag
, CustomErrorHasDoc tag
, KnownError err
)
=> Label tag -> err : s :-> any
failCustom l =
doc (DThrows (Proxy @(CustomError tag))) #
push (errorTagToMText l) # pair @MText @err #
FI (FAILWITH @(ToT (CustomErrorRep tag)))
failCustom_
:: forall tag s any notVoidError.
( TypeErrorUnless (ErrorArg tag == ()) notVoidError
, CustomErrorHasDoc tag
, notVoidError ~
('Text "Expected no-arg error, but given error requires argument of type "
':<>: 'ShowType (ErrorArg tag)
)
)
=> Label tag -> s :-> any
failCustom_ l =
inTypeErrorUnless @(ErrorArg tag == ()) @notVoidError $
reifyTypeEquality @(ErrorArg tag) @() $
unit # failCustom l
instance Eq (ErrorArg tag) => Eq (() -> CustomError tag) where
e1 == e2 = e1 () == e2 ()
instance Show (ErrorArg tag) => Show (() -> CustomError tag) where
show e = show (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 mkCustomError cont =
inTypeErrorUnless @(arg == ()) @notVoidError $
reifyTypeEquality @arg @() $
errorToVal (mkCustomError ()) cont
errorFromVal v =
inTypeErrorUnless @(arg == ()) @notVoidError $
reifyTypeEquality @arg @() $
errorFromVal v <&> \(CustomError l ()) -> CustomError l
instance ErrorHasDoc (CustomError tag) => ErrorHasDoc (arg -> CustomError tag) where
errorDocName = errorDocName @(CustomError tag)
errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @(CustomError tag)
errorDocMdCause = errorDocMdCause @(CustomError tag)
errorDocHaskellRep = errorDocHaskellRep @(CustomError tag)
errorDocDependencies = errorDocDependencies @(CustomError tag)
data ErrorClass
= ErrClassActionException
| ErrClassBadArgument
| ErrClassContractInternal
| ErrClassUnknown
instance Buildable ErrorClass where
build = \case
ErrClassActionException -> "Action exception"
ErrClassBadArgument -> "Bad argument"
ErrClassContractInternal -> "Internal"
ErrClassUnknown -> "-"
isInternalErrorClass :: ErrorClass -> Bool
isInternalErrorClass = \case
ErrClassActionException -> False
ErrClassBadArgument -> False
ErrClassContractInternal -> True
ErrClassUnknown -> False
class (KnownSymbol tag, TypeHasDoc (ErrorArg tag), IsError (CustomError tag)) =>
CustomErrorHasDoc tag where
customErrDocMdCause :: Markdown
customErrDocMdCauseInEntrypoint :: Markdown
customErrDocMdCauseInEntrypoint = pickFirstSentence $ customErrDocMdCause @tag
customErrClass :: ErrorClass
customErrClass = ErrClassUnknown
customErrArgumentSemantics :: Maybe Markdown
customErrArgumentSemantics = Nothing
{-# MINIMAL customErrDocMdCause, customErrClass #-}
data DError where
DError :: IsError e => Proxy e -> DError
instance Eq DError where
DError e1 == DError e2 = e1 `eqParam1` e2
instance Ord DError where
DError e1 `compare` DError e2 = e1 `compareExt` e2
instance DocItem DError where
type DocItemPosition DError = 5010
type DocItemPlacement DError = 'DocItemInDefinitions
docItemSectionName = Just "Errors"
docItemSectionDescription = Just errorsDocumentation
docItemRef (DError (_ :: Proxy e)) = DocItemRef $
DocItemId ("errors-" <> errorDocName @e)
docItemToMarkdown lvl (DError (_ :: Proxy e)) =
mconcat
[ mdSeparator
, mdHeader lvl (mdTicked . build $ errorDocName @e)
, mdSubsection "Class" (build $ errorDocClass @e)
, "\n\n"
, mdSubsection "Fires if" $ errorDocMdCause @e
, "\n\n"
, mdSubsection "Representation" $ errorDocHaskellRep @e
]
docItemDependencies (DError (_ :: Proxy e)) = errorDocDependencies @e
errorDocMdReference :: forall e. IsError e => Markdown
errorDocMdReference =
let DocItemRef (DocItemId anchor) = docItemRef $ DError (Proxy @e)
in mdLocalRef (mdTicked . build $ errorDocName @e) anchor
data DThrows where
DThrows :: IsError e => Proxy e -> DThrows
instance Eq DThrows where
DThrows e1 == DThrows e2 = eqParam1 e1 e2
instance DocItem DThrows where
type DocItemPosition DThrows = 5011
docItemSectionName = Just "Possible errors"
docItemSectionNameStyle = DocSectionNameSmall
docItemDependencies (DThrows ds) =
[SomeDocDefinitionItem (DError ds)]
docItemToMarkdown _ (DThrows (_ :: Proxy e)) =
"* " <> errorDocMdReference @e <> " — " <> errorDocMdCauseInEntrypoint @e
docItemsOrder =
let errType (DThrows (_ :: Proxy e)) = errorDocClass @e
in L.nub . filter (Prelude.not . isInternalErrorClass . errType)
typeDocMdDescriptionReferToError :: forall e. IsError e => Markdown
typeDocMdDescriptionReferToError =
"This type is primarily used as error, see " <>
docDefinitionRef "description in section with errors" (DError (Proxy @e))
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.
Most of the errors are represented according to the same
`(error name, 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.
|]
customErrorToVal
:: (LooseSumC e, HasCallStack)
=> e
-> (forall t. ErrorScope t => Value t -> r)
-> r
customErrorToVal e cont =
case toTaggedVal e of
(tag, SomeValue (datVal :: Value t)) ->
let tag' = mkMTextUnsafe tag
in case (opAbsense (sing @t), bigMapAbsense (sing @t), contractTypeAbsense (sing @t)) of
(Just Dict, Just Dict, Just Dict) -> cont $ VPair (VC (CvString tag'), datVal)
(Nothing, _, _) -> error "Operation in constructor data"
(_, Nothing, _) -> error "BigMap in constructor data"
(_, _, Nothing) -> error "Contract in constructor data"
{-# DEPRECATED customErrorToVal "Datatype error declarations has been deprecated" #-}
customErrorFromVal
:: forall t e.
(SingI t, LooseSumC e)
=> Value t -> Either Text e
customErrorFromVal v = case (v, sing @t) of
(VPair (VC (CvString tag), datVal), STPair _ _) ->
case fromTaggedVal (toText tag, SomeValue datVal) of
ComposeOk e ->
Right e
ComposeCtorNotFound ->
Left $ "Unknown error constructor " +| tag |+ ""
ComposeFieldTypeMismatch got expected ->
Left $ "Error data type mismatch, expected " +|| expected ||+
", got " +|| got ||+ ""
_ -> Left $ "Expected a (tag, dat) pair representing error"
{-# DEPRECATED customErrorFromVal "Datatype error declarations has been deprecated" #-}
type family CustomErrorNoIsoValue a where
CustomErrorNoIsoValue a = TypeError
('Text "No IsoValue instance for " ':<>: 'ShowType a ':$$:
'Text "It has custom error representation")
deriveCustomError :: TH.Name -> TH.Q [TH.Dec]
deriveCustomError name =
[d|
instance IsError $ty where
errorToVal = customErrorToVal
errorFromVal = customErrorFromVal
instance CustomErrorNoIsoValue $ty => IsoValue $ty where
type ToT $ty = CustomErrorNoIsoValue $ty
toVal = error "impossible"
fromVal = error "impossible"
instance ErrorHasDoc $ty where
errorDocName = "Some error"
errorDocMdCause = "An error occurred."
errorDocHaskellRep = "-"
errorDocClass = ErrClassUnknown
errorDocDependencies = []
|]
where
ty = pure (TH.ConT name)
{-# DEPRECATED deriveCustomError "Datatype error declarations has been deprecated" #-}
type FailUsingArg e name fieldTy s s'
= ( KnownSymbol name, IsError e
, IsoValue fieldTy
, CtorHasOnlyField name e fieldTy, Each [Typeable, SingI] '[ToT fieldTy]
, HasCallStack
)
=> Label name -> fieldTy : s :-> s'
failUsingArg
:: forall err name fieldTy s s'.
FailUsingArg err name fieldTy s s'
failUsingArg _ =
push (mkMTextUnsafe ctor) #
pair #
failWith
where
ctor = case symbolVal (Proxy @name) of
'c' : other -> toText other
other -> error $ "Bad label provided: " +| other |+ ""
{-# DEPRECATED failUsingArg "Datatype error declarations has been deprecated" #-}