-- 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
  { DDescribeErrorTagMap -> Text
detmSrcLoc :: Text
    -- ^ Describes where the error tag map is defined in Haskell code.
  }
  deriving stock (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
(DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> Eq DDescribeErrorTagMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c/= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
== :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c== :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
Eq, Eq DDescribeErrorTagMap
Eq DDescribeErrorTagMap =>
(DDescribeErrorTagMap -> DDescribeErrorTagMap -> Ordering)
-> (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> (DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool)
-> (DDescribeErrorTagMap
    -> DDescribeErrorTagMap -> DDescribeErrorTagMap)
-> (DDescribeErrorTagMap
    -> DDescribeErrorTagMap -> DDescribeErrorTagMap)
-> Ord DDescribeErrorTagMap
DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
DDescribeErrorTagMap -> DDescribeErrorTagMap -> Ordering
DDescribeErrorTagMap
-> DDescribeErrorTagMap -> DDescribeErrorTagMap
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DDescribeErrorTagMap
-> DDescribeErrorTagMap -> DDescribeErrorTagMap
$cmin :: DDescribeErrorTagMap
-> DDescribeErrorTagMap -> DDescribeErrorTagMap
max :: DDescribeErrorTagMap
-> DDescribeErrorTagMap -> DDescribeErrorTagMap
$cmax :: DDescribeErrorTagMap
-> DDescribeErrorTagMap -> DDescribeErrorTagMap
>= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c>= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
> :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c> :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
<= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c<= :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
< :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
$c< :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Bool
compare :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Ordering
$ccompare :: DDescribeErrorTagMap -> DDescribeErrorTagMap -> Ordering
$cp1Ord :: Eq DDescribeErrorTagMap
Ord)

instance DocItem DDescribeErrorTagMap where
  type DocItemPlacement DDescribeErrorTagMap = 'DocItemInDefinitions
  type DocItemReferenced DDescribeErrorTagMap = 'True
  docItemPos :: Natural
docItemPos = 4090
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just "About error tags mapping"
  docItemRef :: DDescribeErrorTagMap
-> DocItemRef
     (DocItemPlacement DDescribeErrorTagMap)
     (DocItemReferenced DDescribeErrorTagMap)
docItemRef DDescribeErrorTagMap{..} = DocItemId
-> DocItemRef
     (DocItemPlacement DDescribeErrorTagMap)
     (DocItemReferenced DDescribeErrorTagMap)
DocItemId -> DocItemRef 'DocItemInDefinitions 'True
DocItemRef (DocItemId
 -> DocItemRef
      (DocItemPlacement DDescribeErrorTagMap)
      (DocItemReferenced DDescribeErrorTagMap))
-> DocItemId
-> DocItemRef
     (DocItemPlacement DDescribeErrorTagMap)
     (DocItemReferenced DDescribeErrorTagMap)
forall a b. (a -> b) -> a -> b
$
    Text -> DocItemId
DocItemId (Text -> DocItemId) -> Text -> DocItemId
forall a b. (a -> b) -> a -> b
$ "error-mapping-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
detmSrcLoc
  docItemToMarkdown :: HeaderLevel -> DDescribeErrorTagMap -> Markdown
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
dDescribeErrorTagMapAnchor = Text -> Anchor
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
  { NumericErrorDocHandler
-> forall givenErr.
   ErrorHasDoc givenErr =>
   ErrorTagMap
   -> Proxy givenErr
   -> Either NumericErrorDocHandlerError SomeErrorWithDoc
_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 :: ErrorTagMap -> (inp :-> out) -> inp :-> out
applyErrorTagToErrorsDoc = [NumericErrorDocHandler]
-> ErrorTagMap -> (inp :-> out) -> inp :-> out
forall (inp :: [*]) (out :: [*]).
HasCallStack =>
[NumericErrorDocHandler]
-> ErrorTagMap -> (inp :-> out) -> inp :-> out
applyErrorTagToErrorsDocWith [NumericErrorDocHandler]
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 :: [NumericErrorDocHandler]
-> ErrorTagMap -> (inp :-> out) -> inp :-> out
applyErrorTagToErrorsDocWith handlers :: [NumericErrorDocHandler]
handlers errorTagMap :: ErrorTagMap
errorTagMap =
  (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out) -> inp :-> out
forall (i1 :: [*]) (i2 :: [*]) (o :: [*]).
(forall (o' :: [T]). Instr (ToTs i1) o' -> Instr (ToTs i2) o')
-> (i1 :-> o) -> i2 :-> o
iMapAnyCode ((forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
 -> (inp :-> out) -> inp :-> out)
-> (forall (o' :: [T]). Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (inp :-> out)
-> inp :-> out
forall a b. (a -> b) -> a -> b
$ forall (inp :: [T]) (out :: [T]).
(DocItem DThrows, DocItem DThrows) =>
(DThrows -> Maybe DThrows) -> Instr inp out -> Instr inp out
forall i1 i2 (inp :: [T]) (out :: [T]).
(DocItem i1, DocItem i2) =>
(i1 -> Maybe i2) -> Instr inp out -> Instr inp out
modifyInstrDoc @_ @DThrows ((DThrows -> Maybe DThrows)
 -> Instr (ToTs inp) o' -> Instr (ToTs inp) o')
-> (DThrows -> Maybe DThrows)
-> Instr (ToTs inp) o'
-> Instr (ToTs inp) o'
forall a b. (a -> b) -> a -> b
$
  \(DThrows ep :: Proxy e
ep) ->
    (Cont (Maybe DThrows) (Maybe DThrows)
 -> (Maybe DThrows -> Maybe DThrows) -> Maybe DThrows)
-> (Maybe DThrows -> Maybe DThrows)
-> Cont (Maybe DThrows) (Maybe DThrows)
-> Maybe DThrows
forall a b c. (a -> b -> c) -> b -> a -> c
flip Cont (Maybe DThrows) (Maybe DThrows)
-> (Maybe DThrows -> Maybe DThrows) -> Maybe DThrows
forall r a. Cont r a -> (a -> r) -> r
runCont Maybe DThrows -> Maybe DThrows
forall a. a -> a
id (Cont (Maybe DThrows) (Maybe DThrows) -> Maybe DThrows)
-> Cont (Maybe DThrows) (Maybe DThrows) -> Maybe DThrows
forall a b. (a -> b) -> a -> b
$
    ((Maybe DThrows -> ContT (Maybe DThrows) Identity ())
 -> Cont (Maybe DThrows) (Maybe DThrows))
-> Cont (Maybe DThrows) (Maybe DThrows)
forall (m :: * -> *) a b. MonadCont m => ((a -> m b) -> m a) -> m a
callCC (((Maybe DThrows -> ContT (Maybe DThrows) Identity ())
  -> Cont (Maybe DThrows) (Maybe DThrows))
 -> Cont (Maybe DThrows) (Maybe DThrows))
-> ((Maybe DThrows -> ContT (Maybe DThrows) Identity ())
    -> Cont (Maybe DThrows) (Maybe DThrows))
-> Cont (Maybe DThrows) (Maybe DThrows)
forall a b. (a -> b) -> a -> b
$ \quitWith :: Maybe DThrows -> ContT (Maybe DThrows) Identity ()
quitWith -> do
      [NumericErrorDocHandler]
-> (Element [NumericErrorDocHandler]
    -> ContT (Maybe DThrows) Identity ())
-> ContT (Maybe DThrows) Identity ()
forall t (m :: * -> *) b.
(Container t, Monad m) =>
t -> (Element t -> m b) -> m ()
forM_ [NumericErrorDocHandler]
handlers ((Element [NumericErrorDocHandler]
  -> ContT (Maybe DThrows) Identity ())
 -> ContT (Maybe DThrows) Identity ())
-> (Element [NumericErrorDocHandler]
    -> ContT (Maybe DThrows) Identity ())
-> ContT (Maybe DThrows) Identity ()
forall a b. (a -> b) -> a -> b
$ \(NumericErrorDocHandler handler) ->
        case ErrorTagMap
-> Proxy e -> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall givenErr.
ErrorHasDoc givenErr =>
ErrorTagMap
-> Proxy givenErr
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
handler ErrorTagMap
errorTagMap Proxy e
ep of
          Left EheNotApplicable -> ContT (Maybe DThrows) Identity ()
forall (f :: * -> *). Applicative f => f ()
pass
          Left EheConversionUnnecessary -> Maybe DThrows -> ContT (Maybe DThrows) Identity ()
quitWith Maybe DThrows
forall a. Maybe a
Nothing
          Right (SomeErrorWithDoc nep :: Proxy err
nep) -> Maybe DThrows -> ContT (Maybe DThrows) Identity ()
quitWith (Maybe DThrows -> ContT (Maybe DThrows) Identity ())
-> Maybe DThrows -> ContT (Maybe DThrows) Identity ()
forall a b. (a -> b) -> a -> b
$ DThrows -> Maybe DThrows
forall a. a -> Maybe a
Just (Proxy err -> DThrows
forall e. ErrorHasDoc e => Proxy e -> DThrows
DThrows Proxy err
nep)
      Text -> Cont (Maybe DThrows) (Maybe DThrows)
forall a. HasCallStack => Text -> a
error (Text -> Cont (Maybe DThrows) (Maybe DThrows))
-> Text -> Cont (Maybe DThrows) (Maybe DThrows)
forall a b. (a -> b) -> a -> b
$ "No handler found for error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show (Proxy e -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy e
ep)

mkGeneralNumericWrapper
  :: forall err.
     (ErrorHasDoc err, ErrorHasNumericDoc err)
  => ErrorTagMap
  -> MText
  -> Either NumericErrorDocHandlerError SomeErrorWithDoc
mkGeneralNumericWrapper :: ErrorTagMap
-> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc
mkGeneralNumericWrapper errorTagMap :: ErrorTagMap
errorTagMap strTag :: MText
strTag = do
  Natural
numErrTag <- MText -> ErrorTagMap -> Maybe Natural
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
Bimap.lookupR MText
strTag ErrorTagMap
errorTagMap
              Maybe Natural
-> (Maybe Natural -> Either NumericErrorDocHandlerError Natural)
-> Either NumericErrorDocHandlerError Natural
forall a b. a -> (a -> b) -> b
& NumericErrorDocHandlerError
-> Maybe Natural -> Either NumericErrorDocHandlerError Natural
forall l r. l -> Maybe r -> Either l r
maybeToRight NumericErrorDocHandlerError
EheConversionUnnecessary
  SomeNat (Proxy n
_ :: Proxy numTag) <- SomeNat -> Either NumericErrorDocHandlerError SomeNat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeNat -> Either NumericErrorDocHandlerError SomeNat)
-> SomeNat -> Either NumericErrorDocHandlerError SomeNat
forall a b. (a -> b) -> a -> b
$ Natural -> SomeNat
someNatVal Natural
numErrTag
  SomeErrorWithDoc
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeErrorWithDoc
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> SomeErrorWithDoc
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$ Proxy (NumericErrorWrapper n err) -> SomeErrorWithDoc
forall err. ErrorHasDoc err => Proxy err -> SomeErrorWithDoc
SomeErrorWithDoc (Proxy (NumericErrorWrapper n err) -> SomeErrorWithDoc)
-> Proxy (NumericErrorWrapper n err) -> SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$ Proxy (NumericErrorWrapper n err)
forall k (t :: k). Proxy t
Proxy @(NumericErrorWrapper numTag err)

-- | Handler for all 'CustomError's.
customErrorDocHandler :: NumericErrorDocHandler
customErrorDocHandler :: NumericErrorDocHandler
customErrorDocHandler = (forall givenErr.
 ErrorHasDoc givenErr =>
 ErrorTagMap
 -> Proxy givenErr
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
NumericErrorDocHandler ((forall givenErr.
  ErrorHasDoc givenErr =>
  ErrorTagMap
  -> Proxy givenErr
  -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> NumericErrorDocHandler)
-> (forall givenErr.
    ErrorHasDoc givenErr =>
    ErrorTagMap
    -> Proxy givenErr
    -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
forall a b. (a -> b) -> a -> b
$
  \errorTagMap :: ErrorTagMap
errorTagMap (Proxy givenErr
_ :: Proxy givenErr) ->
    Either
  NumericErrorDocHandlerError
  (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either
   NumericErrorDocHandlerError
   (Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> (Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
    -> Either
         NumericErrorDocHandlerError
         (Either NumericErrorDocHandlerError SomeErrorWithDoc))
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumericErrorDocHandlerError
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either
     NumericErrorDocHandlerError
     (Either NumericErrorDocHandlerError SomeErrorWithDoc)
forall l r. l -> Maybe r -> Either l r
maybeToRight NumericErrorDocHandlerError
EheNotApplicable (Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$
    forall r.
(Typeable givenErr, Typeable CustomError) =>
(forall (a :: Symbol).
 Typeable a =>
 (CustomError a :~: givenErr) -> Proxy a -> r)
-> Maybe r
forall k1 k2 (c :: k1 -> k2) (x :: k2) r.
(Typeable x, Typeable c) =>
(forall (a :: k1). Typeable a => (c a :~: x) -> Proxy a -> r)
-> Maybe r
eqTypeIgnoringPhantom @CustomError @givenErr ((forall (a :: Symbol).
  Typeable a =>
  (CustomError a :~: givenErr)
  -> Proxy a -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc))
-> (forall (a :: Symbol).
    Typeable a =>
    (CustomError a :~: givenErr)
    -> Proxy a -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
forall a b. (a -> b) -> a -> b
$ \Refl (Proxy a
_ :: Proxy strTag) ->
      case ErrorHasDoc (CustomError a) =>
Dict (ErrorRequirements (CustomError a))
forall e. ErrorHasDoc e => Dict (ErrorRequirements e)
errorDocRequirements @(CustomError strTag) of
        Dict -> do
          let strTag :: MText
strTag = Label a -> MText
forall (tag :: Symbol). Label tag -> MText
errorTagToMText (forall a. IsLabel a a => a
forall (x :: Symbol) a. IsLabel x a => a
fromLabel @strTag)
          ErrorTagMap
-> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall err.
(ErrorHasDoc err, ErrorHasNumericDoc err) =>
ErrorTagMap
-> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc
mkGeneralNumericWrapper @givenErr ErrorTagMap
errorTagMap MText
strTag

-- | Handler for 'VoidResult'.
voidResultDocHandler :: NumericErrorDocHandler
voidResultDocHandler :: NumericErrorDocHandler
voidResultDocHandler = (forall givenErr.
 ErrorHasDoc givenErr =>
 ErrorTagMap
 -> Proxy givenErr
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
NumericErrorDocHandler ((forall givenErr.
  ErrorHasDoc givenErr =>
  ErrorTagMap
  -> Proxy givenErr
  -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> NumericErrorDocHandler)
-> (forall givenErr.
    ErrorHasDoc givenErr =>
    ErrorTagMap
    -> Proxy givenErr
    -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
forall a b. (a -> b) -> a -> b
$
  \errorTagMap :: ErrorTagMap
errorTagMap (Proxy givenErr
_ :: Proxy givenErr) ->
    Either
  NumericErrorDocHandlerError
  (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either
   NumericErrorDocHandlerError
   (Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> (Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
    -> Either
         NumericErrorDocHandlerError
         (Either NumericErrorDocHandlerError SomeErrorWithDoc))
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumericErrorDocHandlerError
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either
     NumericErrorDocHandlerError
     (Either NumericErrorDocHandlerError SomeErrorWithDoc)
forall l r. l -> Maybe r -> Either l r
maybeToRight NumericErrorDocHandlerError
EheNotApplicable (Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$
    forall r.
(Typeable givenErr, Typeable VoidResult) =>
(forall a.
 Typeable a =>
 (VoidResult a :~: givenErr) -> Proxy a -> r)
-> Maybe r
forall k1 k2 (c :: k1 -> k2) (x :: k2) r.
(Typeable x, Typeable c) =>
(forall (a :: k1). Typeable a => (c a :~: x) -> Proxy a -> r)
-> Maybe r
eqTypeIgnoringPhantom @VoidResult @givenErr ((forall a.
  Typeable a =>
  (VoidResult a :~: givenErr)
  -> Proxy a -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc))
-> (forall a.
    Typeable a =>
    (VoidResult a :~: givenErr)
    -> Proxy a -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> Maybe (Either NumericErrorDocHandlerError SomeErrorWithDoc)
forall a b. (a -> b) -> a -> b
$ \Refl (Proxy a
_ :: Proxy res) -> do
      ErrorTagMap
-> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall err.
(ErrorHasDoc err, ErrorHasNumericDoc err) =>
ErrorTagMap
-> MText -> Either NumericErrorDocHandlerError SomeErrorWithDoc
mkGeneralNumericWrapper @givenErr ErrorTagMap
errorTagMap MText
voidResultTag

-- | Handler for textual error messages.
textErrorDocHandler :: NumericErrorDocHandler
textErrorDocHandler :: NumericErrorDocHandler
textErrorDocHandler = (forall givenErr.
 ErrorHasDoc givenErr =>
 ErrorTagMap
 -> Proxy givenErr
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
NumericErrorDocHandler ((forall givenErr.
  ErrorHasDoc givenErr =>
  ErrorTagMap
  -> Proxy givenErr
  -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
 -> NumericErrorDocHandler)
-> (forall givenErr.
    ErrorHasDoc givenErr =>
    ErrorTagMap
    -> Proxy givenErr
    -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> NumericErrorDocHandler
forall a b. (a -> b) -> a -> b
$
  \_errorTagMap :: ErrorTagMap
_errorTagMap (Proxy givenErr
_ :: Proxy givenErr) ->
    case (Typeable givenErr, Typeable MText) => Maybe (givenErr :~: MText)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @givenErr @MText of
      Nothing -> NumericErrorDocHandlerError
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall a b. a -> Either a b
Left NumericErrorDocHandlerError
EheNotApplicable
      Just Refl -> SomeErrorWithDoc
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeErrorWithDoc
 -> Either NumericErrorDocHandlerError SomeErrorWithDoc)
-> SomeErrorWithDoc
-> Either NumericErrorDocHandlerError SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$ Proxy NumericTextError -> SomeErrorWithDoc
forall err. ErrorHasDoc err => Proxy err -> SomeErrorWithDoc
SomeErrorWithDoc (Proxy NumericTextError -> SomeErrorWithDoc)
-> Proxy NumericTextError -> SomeErrorWithDoc
forall a b. (a -> b) -> a -> b
$ Proxy NumericTextError
forall k (t :: k). Proxy t
Proxy @NumericTextError

-- | Handlers for most common errors defined in Lorentz.
baseErrorDocHandlers :: [NumericErrorDocHandler]
baseErrorDocHandlers :: [NumericErrorDocHandler]
baseErrorDocHandlers =
  [ NumericErrorDocHandler
customErrorDocHandler
  , NumericErrorDocHandler
voidResultDocHandler
  , NumericErrorDocHandler
textErrorDocHandler
  ]

-- | Pseudo error which stands for textual errors converted to numeric codes.
data NumericTextError

instance ErrorHasDoc NumericTextError where
  errorDocName :: Text
errorDocName = ErrorHasDoc MText => Text
forall e. ErrorHasDoc e => Text
errorDocName @MText
  errorDocMdCause :: Markdown
errorDocMdCause = ErrorHasDoc MText => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCause @MText
  errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = ErrorHasDoc MText => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCauseInEntrypoint @MText
  errorDocClass :: ErrorClass
errorDocClass = ErrorHasDoc MText => ErrorClass
forall e. ErrorHasDoc e => ErrorClass
errorDocClass @MText
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = [DType -> SomeDocDefinitionItem
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
d -> SomeDocDefinitionItem
SomeDocDefinitionItem (Proxy Natural -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType (Proxy Natural -> DType) -> Proxy Natural -> DType
forall a b. (a -> b) -> a -> b
$ Proxy Natural
forall k (t :: k). Proxy t
Proxy @Natural)]
  errorDocHaskellRep :: Markdown
errorDocHaskellRep =
    "Numeric code for an error message, see also " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    Markdown -> Anchor -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef "error tags mapping" Anchor
dDescribeErrorTagMapAnchor Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "."

-- | 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 :: Text
errorDocName = ErrorHasDoc err => Text
forall e. ErrorHasDoc e => Text
errorDocName @err
  errorDocMdCause :: Markdown
errorDocMdCause = ErrorHasDoc err => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCause @err
  errorDocMdCauseInEntrypoint :: Markdown
errorDocMdCauseInEntrypoint = ErrorHasDoc err => Markdown
forall e. ErrorHasDoc e => Markdown
errorDocMdCauseInEntrypoint @err
  errorDocClass :: ErrorClass
errorDocClass = ErrorHasDoc err => ErrorClass
forall e. ErrorHasDoc e => ErrorClass
errorDocClass @err
  errorDocDependencies :: [SomeDocDefinitionItem]
errorDocDependencies = ErrorHasDoc err => [SomeDocDefinitionItem]
forall e. ErrorHasDoc e => [SomeDocDefinitionItem]
errorDocDependencies @err
  errorDocHaskellRep :: Markdown
errorDocHaskellRep =
    case ErrorHasDoc err => Dict (ErrorRequirements err)
forall e. ErrorHasDoc e => Dict (ErrorRequirements e)
errorDocRequirements @err of
      Dict -> [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
        [ let numTag :: Text
numTag = Natural -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Proxy numTag -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy numTag -> Natural) -> Proxy numTag -> Natural
forall a b. (a -> b) -> a -> b
$ Proxy numTag
forall k (t :: k). Proxy t
Proxy @numTag) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " :: nat"
          in Text -> Markdown
forall err.
(ErrorHasNumericDoc err, ErrorRequirements err) =>
Text -> Markdown
numericErrorDocHaskellRep @err Text
numTag
        , "\n\n"
        , Markdown -> Markdown -> Markdown
mdSubsection "Respective textual tag" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$
            Markdown -> Markdown
mdTicked (Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ (ErrorHasNumericDoc err, ErrorRequirements err) => Text
forall err. (ErrorHasNumericDoc err, ErrorRequirements err) => Text
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 :: Text -> Markdown
numericErrorDocHaskellRep numTag :: Text
numTag =
    Text -> Proxy tag -> Markdown
forall (tag :: Symbol).
(SingI (ToT (ErrorArg tag)), IsError (CustomError tag),
 TypeHasDoc (ErrorArg tag), CustomErrorHasDoc tag) =>
Text -> Proxy tag -> Markdown
customErrorDocHaskellRepGeneral Text
numTag (Proxy tag
forall k (t :: k). Proxy t
Proxy @tag)
  numericErrorDocTextualTag :: Text
numericErrorDocTextualTag = KnownSymbol tag => Text
forall (tag :: Symbol). KnownSymbol tag => Text
errorTagToText @tag

instance ErrorHasDoc (VoidResult res) =>
         ErrorHasNumericDoc (VoidResult res) where
  numericErrorDocHaskellRep :: Text -> Markdown
numericErrorDocHaskellRep numTag :: Text
numTag =
    case ErrorHasDoc (VoidResult res) =>
Dict (ErrorRequirements (VoidResult res))
forall e. ErrorHasDoc e => Dict (ErrorRequirements e)
errorDocRequirements @(VoidResult res) of
      Dict -> Markdown -> Markdown
mdTicked (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ "(" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
numTag Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ", " Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "<return value>" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ")"
  numericErrorDocTextualTag :: Text
numericErrorDocTextualTag = MText -> Text
forall a. ToText a => a -> Text
toText MText
voidResultTag