-- SPDX-FileCopyrightText: 2020 Tocqueville Group -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ -- | Autodoc for numeric errors. module Lorentz.Errors.Numeric.Doc ( DDescribeErrorTagMap (..) , applyErrorTagToErrorsDoc , applyErrorTagToErrorsDocWith , NumericErrorDocHandler , NumericErrorDocHandlerError , customErrorDocHandler , voidResultDocHandler , baseErrorDocHandlers -- * Internals , NumericErrorWrapper ) where import Control.Monad.Cont (callCC, runCont) import qualified Data.Bimap as Bimap import qualified Data.Kind as Kind import Data.Typeable (typeRep) import Fmt (build, pretty) import GHC.TypeNats (Nat) import Lorentz.Base import Lorentz.Doc import Lorentz.Errors import Lorentz.Errors.Numeric.Contract import Lorentz.Macro import Michelson.Text (MText) import Michelson.Typed import Util.Markdown import Util.Typeable -- | Adds a section which explains error tag mapping. data DDescribeErrorTagMap = DDescribeErrorTagMap { detmSrcLoc :: Text -- ^ Describes where the error tag map is defined in Haskell code. } deriving stock (Eq, Ord) instance DocItem DDescribeErrorTagMap where type DocItemPlacement DDescribeErrorTagMap = 'DocItemInDefinitions type DocItemReferenced DDescribeErrorTagMap = 'True docItemPos = 4090 docItemSectionName = Just "About error tags mapping" docItemRef DDescribeErrorTagMap{..} = DocItemRef $ DocItemId $ "error-mapping-" <> detmSrcLoc docItemToMarkdown _ DDescribeErrorTagMap{..} = [md| This contract uses numeric representation of error tags. Nevertheless, the original Lorentz code operates with string tags which are later mapped to naturals. If you need to handle errors produced by this contract, we recommend converting numeric tags back to strings first, preserving textual tags which are already present, and then pattern-match on textual tags. This conversion can be performed with the help of the error tag map defined at `#{detmSrcLoc}`. Note that some errors can still use a textual tag, for instance to satisfy rules of an interface. In [TM-376](https://issues.serokell.io/issue/TM-376) we are going to provide more type-safe and convenient mechanisms for errors handling. |] -- TODO [TM-376]: update the comment above on how to work with our errors -- from Haskell -- | Anchor which refers to the section describing error tag mapping. dDescribeErrorTagMapAnchor :: Anchor dDescribeErrorTagMapAnchor = Anchor "about-error-tags-mapping" -- | Errors for 'NumericErrorDocHandler' data NumericErrorDocHandlerError = EheNotApplicable -- ^ Given handler is not suitable, probably another one will fit. | EheConversionUnnecessary -- ^ Given handler suits and tells that given error should remain unchanged. data SomeErrorWithDoc = forall err. ErrorHasDoc err => SomeErrorWithDoc (Proxy err) -- | Handler which changes documentation for one particular error type. newtype NumericErrorDocHandler = NumericErrorDocHandler { _unNumericErrorDocHandler :: forall givenErr. (ErrorHasDoc givenErr) => ErrorTagMap -> Proxy givenErr -> Either NumericErrorDocHandlerError SomeErrorWithDoc } -- | Modify documentation generated for given code so that all 'CustomError' -- mention not their textual error tag rather respective numeric one from the -- given map. -- -- If some documented error is not present in the map, it remains unmodified. -- This function may fail with 'error' if contract uses some uncommon errors, -- see 'applyErrorTagToErrorsDocWith' for details. applyErrorTagToErrorsDoc :: HasCallStack => ErrorTagMap -> inp :-> out -> inp :-> out applyErrorTagToErrorsDoc = applyErrorTagToErrorsDocWith baseErrorDocHandlers -- | Extended version of 'applyErrorTagToErrorsDoc' which accepts error -- handlers. -- -- In most cases that function should be enough for your purposes, but it uses -- a fixed set of base handlers which may be not enough in case when you define -- your own errors. In this case define and pass all the necessary handlers to -- this function. -- -- It fails with 'error' if some of the errors used in the contract cannot be -- handled with given handlers. applyErrorTagToErrorsDocWith :: HasCallStack => [NumericErrorDocHandler] -> ErrorTagMap -> inp :-> out -> inp :-> out applyErrorTagToErrorsDocWith handlers errorTagMap = iMapAnyCode $ modifyInstrDoc @_ @DThrows $ \(DThrows ep) -> flip runCont id $ callCC $ \quitWith -> do forM_ handlers $ \(NumericErrorDocHandler handler) -> case handler errorTagMap ep of Left EheNotApplicable -> pass Left EheConversionUnnecessary -> quitWith Nothing Right (SomeErrorWithDoc nep) -> quitWith $ Just (DThrows nep) error $ "No handler found for error " <> show (typeRep ep) mkGeneralNumericWrapper :: forall err. (ErrorHasDoc err, ErrorHasNumericDoc err) => ErrorTagMap -> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc mkGeneralNumericWrapper errorTagMap strTag = do numErrTag <- Bimap.lookupR strTag errorTagMap & maybeToRight EheConversionUnnecessary SomeNat (_ :: Proxy numTag) <- pure $ someNatVal numErrTag return $ SomeErrorWithDoc $ Proxy @(NumericErrorWrapper numTag err) -- | Handler for all 'CustomError's. customErrorDocHandler :: NumericErrorDocHandler customErrorDocHandler = NumericErrorDocHandler $ \errorTagMap (_ :: Proxy givenErr) -> join . maybeToRight EheNotApplicable $ eqTypeIgnoringPhantom @CustomError @givenErr $ \Refl (_ :: Proxy strTag) -> case errorDocRequirements @(CustomError strTag) of Dict -> do let strTag = errorTagToMText (fromLabel @strTag) mkGeneralNumericWrapper @givenErr errorTagMap strTag -- | Handler for 'VoidResult'. voidResultDocHandler :: NumericErrorDocHandler voidResultDocHandler = NumericErrorDocHandler $ \errorTagMap (_ :: Proxy givenErr) -> join . maybeToRight EheNotApplicable $ eqTypeIgnoringPhantom @VoidResult @givenErr $ \Refl (_ :: Proxy res) -> do mkGeneralNumericWrapper @givenErr errorTagMap voidResultTag -- | Handler for textual error messages. textErrorDocHandler :: NumericErrorDocHandler textErrorDocHandler = NumericErrorDocHandler $ \_errorTagMap (_ :: Proxy givenErr) -> case eqT @givenErr @MText of Nothing -> Left EheNotApplicable Just Refl -> pure $ SomeErrorWithDoc $ Proxy @NumericTextError -- | Handlers for most common errors defined in Lorentz. baseErrorDocHandlers :: [NumericErrorDocHandler] baseErrorDocHandlers = [ customErrorDocHandler , voidResultDocHandler , textErrorDocHandler ] -- | Pseudo error which stands for textual errors converted to numeric codes. data NumericTextError instance ErrorHasDoc NumericTextError where errorDocName = errorDocName @MText errorDocMdCause = errorDocMdCause @MText errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @MText errorDocClass = errorDocClass @MText errorDocDependencies = [SomeDocDefinitionItem (DType $ Proxy @Natural)] errorDocHaskellRep = "Numeric code for an error message, see also " <> mdLocalRef "error tags mapping" dDescribeErrorTagMapAnchor <> "." -- | Some error with a numeric tag attached. data NumericErrorWrapper (numTag :: Nat) (err :: Kind.Type) instance ( ErrorHasDoc err , KnownNat numTag, ErrorHasNumericDoc err ) => ErrorHasDoc (NumericErrorWrapper numTag err) where errorDocName = errorDocName @err errorDocMdCause = errorDocMdCause @err errorDocMdCauseInEntrypoint = errorDocMdCauseInEntrypoint @err errorDocClass = errorDocClass @err errorDocDependencies = errorDocDependencies @err errorDocHaskellRep = case errorDocRequirements @err of Dict -> mconcat [ let numTag = pretty (natVal $ Proxy @numTag) <> " :: nat" in numericErrorDocHaskellRep @err numTag , "\n\n" , mdSubsection "Respective textual tag" $ mdTicked (build $ numericErrorDocTextualTag @err) ] -- | Helper typeclass which overloads representation for errors. class ErrorHasNumericDoc err where -- | Error representation with respect to tags being changed to numeric ones. numericErrorDocHaskellRep :: ErrorRequirements err => Text -> Markdown numericErrorDocTextualTag :: ErrorRequirements err => Text instance ErrorHasNumericDoc (CustomError tag) where numericErrorDocHaskellRep numTag = customErrorDocHaskellRepGeneral numTag (Proxy @tag) numericErrorDocTextualTag = errorTagToText @tag instance ErrorHasDoc (VoidResult res) => ErrorHasNumericDoc (VoidResult res) where numericErrorDocHaskellRep numTag = case errorDocRequirements @(VoidResult res) of Dict -> mdTicked $ "(" <> build numTag <> ", " <> "" <> ")" numericErrorDocTextualTag = toText voidResultTag