Doc.hs

-- | 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 Data.Constraint (Dict(..))
import qualified Data.Kind as Kind
import Data.Typeable ((:~:)(..), eqT)
import Data.Typeable (typeRep)
import Fmt (build, pretty)
import GHC.TypeNats (KnownNat, Nat, natVal, someNatVal)

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 (Eq, Ord)

instance DocItem DDescribeErrorTagMap where
  type DocItemPosition DDescribeErrorTagMap = 4090
  type DocItemPlacement DDescribeErrorTagMap = 'DocItemInDefinitions
  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 <> ", " <> "<return value>" <> ")"
  numericErrorDocTextualTag = toText voidResultTag