Doc.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Utilities for declaring and documenting entry points.
module Lorentz.Entrypoints.Doc
  ( DEntrypoint (..)
  , DEntrypointReference (..)
  , EntryArrow (..)
  , PlainEntrypointsKind
  , diEntrypointToMarkdown
  , DEntrypointArg (..)
  , DType (..)
  , DeriveCtorFieldDoc (..)
  , ParamBuilder (..)
  , ParamBuildingDesc (..)
  , ParamBuildingStep (..)
  , mkPbsWrapIn
  , clarifyParamBuildingSteps
  , constructDEpArg
  , emptyDEpArg
  , mkUType
  , mkDEpUType
  , mkDEntrypointArgSimple
  , DocumentEntrypoints
  , documentEntrypoint
  , entryCase
  , entryCase_
  , finalizeParamCallingDoc
  , areFinalizedParamBuildingSteps
  , entryCaseSimple_
  , entryCaseSimple
  , RequireFlatParamEps
  , RequireFlatEpDerivation
  ) where

import Control.Lens.Cons (_head)
import Data.Char (toLower)
import Data.Constraint (Dict(..))
import qualified Data.Kind as Kind
import Data.Vinyl.Core (RMap, rappend)
import Fmt (Buildable(..), listF)
import GHC.Generics ((:+:))
import qualified GHC.Generics as G
import qualified Text.Show

import Lorentz.ADT
import Lorentz.Annotation
import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Entrypoints.Core
import Lorentz.Entrypoints.Helpers
import Lorentz.Entrypoints.Impl
import Michelson.Printer.Util (RenderDoc(..), needsParens, printDocB)
import Michelson.Typed (pattern DefEpName, EpName, mkUType)
import Michelson.Typed.Doc
import Michelson.Typed.Haskell.Doc
import Michelson.Typed.Haskell.Instr
import qualified Michelson.Untyped as Untyped
import Util.Label (Label)
import Util.Markdown
import Util.Type
import Util.TypeLits
import Util.TypeTuple

-- | Gathers information about single entrypoint.
--
-- We assume that entry points might be of different kinds,
-- which is designated by phantom type parameter.
-- For instance, you may want to have several groups of entry points
-- corresponding to various parts of a contract - specifying different @kind@
-- type argument for each of those groups will allow you defining different
-- 'DocItem' instances with appropriate custom descriptions for them.
data DEntrypoint (kind :: Kind.Type) = DEntrypoint
  { depName :: Text
  , depSub :: SubDoc
  }

-- | Default implementation of 'docItemToMarkdown' for entry points.
diEntrypointToMarkdown :: HeaderLevel -> DEntrypoint level -> Markdown
diEntrypointToMarkdown lvl (DEntrypoint name block) =
  mdSeparator <>
  mdHeader lvl (mdTicked . build . over _head toLower $ name) <>
  subDocToMarkdown (nextHeaderLevel lvl) block

-- | Default value for 'DEntrypoint' type argument.
data PlainEntrypointsKind

instance DocItem (DEntrypoint PlainEntrypointsKind) where
  docItemPos = 1000
  docItemSectionName = Just "Entrypoints"
  docItemToMarkdown = diEntrypointToMarkdown

data DEntrypointReference = DEntrypointReference Text Anchor

instance DocItem DEntrypointReference where
  docItemPos = 13
  docItemSectionName = Nothing
  docItemToMarkdown _ (DEntrypointReference name anchor) =
    "Copies behaviour of " <>
    mdLocalRef (mdTicked $ build name) anchor <>
    " entrypoint."

-- | When describing the way of parameter construction - piece of incremental
-- builder for this description.
newtype ParamBuilder = ParamBuilder
  { unParamBuilder :: Markdown -> Markdown
    -- ^ Argument stands for previously constructed parameter piece, and
    -- returned value - a piece constructed after our step.
  }

-- | Show what given 'ParamBuilder' does on a sample.
pbSample :: ParamBuilder -> Markdown
pbSample (ParamBuilder b) = b "·"

instance Buildable ParamBuilder where
  build = pbSample

instance Show ParamBuilder where
  show (ParamBuilder pb) =
    -- Using @'x'@ symbol here because unicode does not render well in 'show'
    "ParamBuilder " <> show (pb "x")

instance Eq ParamBuilder where
  (==) = (==) `on` pbSample

data ParamBuildingDesc = ParamBuildingDesc
  { pbdEnglish :: Markdown
    -- ^ Plain english description of this step.
  , pbdHaskell :: ParamBuilder
    -- ^ How to construct parameter in Haskell code.
  , pbdMichelson :: ParamBuilder
    -- ^ How to construct parameter working on raw Michelson.
  } deriving stock (Show, Eq)

-- | Describes a parameter building step.
--
-- This can be wrapping into (Haskell) constructor, or a more complex
-- transformation.
data ParamBuildingStep
    -- | Wraps something into constructor with given name.
    -- Constructor should be the one which corresponds to an entrypoint
    -- defined via field annotation, for more complex cases use 'PbsCustom'.
  = PbsWrapIn Text ParamBuildingDesc
    -- | Directly call an entrypoint marked with a field annotation.
  | PbsCallEntrypoint EpName
    -- | Other action.
  | PbsCustom ParamBuildingDesc
    -- | This entrypoint cannot be called, which is possible when an explicit
    -- default entrypoint is present. This is not a true entrypoint but just some
    -- intermediate node in @or@ tree and neither it nor any of its parents
    -- are marked with a field annotation.
    --
    -- It contains dummy 'ParamBuildingStep's which were assigned before
    -- entrypoints were taken into account.
  | PbsUncallable [ParamBuildingStep]
  deriving stock (Show, Eq)

instance Buildable ParamBuildingStep where
  build = \case
    PbsWrapIn ctor _desc -> "Wrap in `" <> build ctor <> "`"
    PbsCallEntrypoint ep -> "Call entrypoint " <> build ep
    PbsCustom desc -> "Custom: \"" <> pbdEnglish desc <> "\""
    PbsUncallable steps -> "Uncallable; dummy steps: " <> listF steps

-- | Make a 'ParamBuildingStep' that tells about wrapping an argument into
-- a constructor with given name and uses given 'ParamBuilder' as description of
-- Michelson part.
mkPbsWrapIn :: Text -> ParamBuilder -> ParamBuildingStep
mkPbsWrapIn ctorName michDesc =
  PbsWrapIn ctorName ParamBuildingDesc
    { pbdEnglish = "Wrap into " <> mdTicked (build ctorName) <> " constructor."
    , pbdHaskell = ParamBuilder $ \p -> build ctorName <> " (" <> p <> ")"
    , pbdMichelson = michDesc
    }

-- | Describes argument of an entrypoint.
data DEntrypointArg =
  DEntrypointArg
  { epaArg :: Maybe DType
    -- ^ Argument of the entrypoint. Pass 'Nothing' if no argument is required.
  , epaBuilding :: [ParamBuildingStep]
    -- ^ Describes a way to lift an entrypoint argument into full parameter
    -- which can be passed to the contract.
    --
    -- Steps are supposed to be applied in the order opposite to one in which
    -- they are given.
    -- E.g. suppose that an entrypoint is called as @Run (Service1 arg)@;
    -- then the first step (actual last) should describe wrapping into @Run@
    -- constructor, and the second step (actual first) should be about wrapping
    -- into @Service1@ constructor.
  , epaType :: Untyped.Type
    -- ^ Untyped representation of entrypoint, used for printing its michelson
    -- type representation.
  }

constructDEpArg
  :: forall arg.
     ( TypeHasDoc arg
     , HasAnnotation arg
     , KnownValue arg
     )
  => DEntrypointArg
constructDEpArg = DEntrypointArg
  { epaArg = Just $ DType (Proxy @arg)
  , epaBuilding = []
  , epaType = mkDEpUType @arg
  }

emptyDEpArg :: DEntrypointArg
emptyDEpArg = DEntrypointArg
  { epaArg = Nothing
  , epaBuilding = []
  , epaType = Untyped.Type Untyped.TUnit Untyped.noAnn
  }

mkDEpUType :: forall t. (KnownValue t, HasAnnotation t) => Untyped.Type
mkDEpUType = mkUType (getAnnotation @t)

mkDEntrypointArgSimple
  :: forall t.
     ( KnownValue t
     , HasAnnotation t
     , TypeHasDoc t
     )
  => DEntrypointArg
mkDEntrypointArgSimple = DEntrypointArg
  { epaArg = Just $ DType (Proxy @t)
  , epaBuilding = []
  , epaType = mkDEpUType @t
  }

-- | Go over contract code and update every occurrence of 'DEntrypointArg'
-- documentation item, modifying param building steps.
modifyParamBuildingSteps
  :: ([ParamBuildingStep] -> [ParamBuildingStep])
  -> (inp :-> out)
  -> (inp :-> out)
modifyParamBuildingSteps f =
  iMapAnyCode $
  modifyInstrDoc (\di -> Just di{ epaBuilding = f (epaBuilding di) })

-- | Go over contract code and update every occurrence of 'DEntrypointArg'
-- documentation item, adding the given step to its "how to build parameter"
-- description.
clarifyParamBuildingSteps :: ParamBuildingStep -> (inp :-> out) -> (inp :-> out)
clarifyParamBuildingSteps pbs =
  modifyParamBuildingSteps (pbs :)

instance DocItem DEntrypointArg where
  docItemPos = 20
  docItemSectionName = Nothing
  docItemDependencies (DEntrypointArg mdty _ _) =
    [SomeDocDefinitionItem dty | Just dty <- pure mdty]
  docItemToMarkdown _ (DEntrypointArg mdty psteps et) =
    mconcat . Prelude.map (<> "\n\n") $
      [ mdSubsection "Argument" $
          case mdty of
            Nothing -> "none (pass unit)"
            Just (DType (dty :: Proxy ep)) -> mconcat . Prelude.intersperse "\n" $
              [ mempty
              , "  + " <>
                mdSubsection "In Haskell"
                  (typeDocMdReference dty (WithinParens False))
              , "  + " <>
                mdSubsection "In Michelson"
                  (mdTicked $ printDocB False . renderDoc needsParens $ et)
              ],
          mdSpoiler "How to call this entrypoint" $
            "\n0. Construct an argument for the entrypoint.\n" <>
            howToCall
      ]
    where
      howToCall =
        mconcat . Prelude.intersperse "\n" $
        -- Markdown re-enumerates enumerated lists automatically
        Prelude.map ("1. " <>) $
          reverse psteps <&> \case
            PbsWrapIn _ pbd ->
              renderPbDesc pbd
            PbsCallEntrypoint ep -> case ep of
              DefEpName ->
                "Call the contract (default entrypoint) with the constructed \
                \argument."
              _ ->
                "Call contract's " <> mdTicked (build ep) <> " entrypoint \
                \passing the constructed argument."
            PbsCustom pbd ->
              renderPbDesc pbd
            PbsUncallable _ ->
              "Feel sad: this entrypoint *cannot* be called and is enlisted \
              \here only to describe the parameter structure."
              -- We could hide such entrypoints, but then in case of incorrect
              -- use of 'entryCase's or a bug in documentation, understanding
              -- what's going on would be hard

      renderPbDesc ParamBuildingDesc{..} =
        mconcat . Prelude.intersperse "\n" $
        [ pbdEnglish
        , "    + " <>
          mdSubsection "In Haskell" (mdTicked $ pbSample pbdHaskell)
        , "    + " <>
          mdSubsection "In Michelson" (mdTicked $ pbSample pbdMichelson)
        ]

-- | Pick a type documentation from 'CtorField'.
class (KnownSymbol con) => DeriveCtorFieldDoc con (cf :: CtorField) where
  deriveCtorFieldDoc :: DEntrypointArg

instance
    (KnownSymbol con)
  =>
    DeriveCtorFieldDoc con 'NoFields
  where
  deriveCtorFieldDoc = emptyDEpArg

instance
    (TypeHasDoc ty, HasAnnotation ty, KnownValue ty, KnownSymbol con)
  =>
    DeriveCtorFieldDoc con ('OneField ty)
  where
  deriveCtorFieldDoc = constructDEpArg @ty

-- | Add necessary documentation to entry points.
documentEntrypoints
  :: forall a kind inp out.
     DocumentEntrypoints kind a
  => Rec (CaseClauseL inp out) (CaseClauses a)
  -> Rec (CaseClauseL inp out) (CaseClauses a)
documentEntrypoints = gDocumentEntrypoints @kind @(G.Rep a) (ParamBuilder id)

-- | Constraint for 'documentEntrypoints'.
type DocumentEntrypoints kind a =
  (Generic a, GDocumentEntrypoints kind (G.Rep a))

-- | Traverse entry points and add parameter building step (which describes
-- necessity to wrap parameter into some constructor of the given datatype)
-- to all parameters described within given code.
class GDocumentEntrypoints (kind :: Kind.Type) (x :: Kind.Type -> Kind.Type) where
  -- | Add corresponding parameter building step.
  --
  -- First argument is accumulator for Michelson description of the building step.
  gDocumentEntrypoints
    :: ParamBuilder
    -> Rec (CaseClauseL inp out) (GCaseClauses x)
    -> Rec (CaseClauseL inp out) (GCaseClauses x)

instance GDocumentEntrypoints kind x => GDocumentEntrypoints kind (G.D1 i x) where
  gDocumentEntrypoints = gDocumentEntrypoints @kind @x

instance ( GDocumentEntrypoints kind x, GDocumentEntrypoints kind y
         , RSplit (GCaseClauses x) (GCaseClauses y)
         ) =>
         GDocumentEntrypoints kind (x :+: y) where
  gDocumentEntrypoints (ParamBuilder michDesc) clauses =
    let (lclauses, rclauses) = rsplit @CaseClauseParam @(GCaseClauses x) clauses
    in gDocumentEntrypoints @kind @x
         (ParamBuilder $ \a -> michDesc $ "Left (" <> a <> ")")
         lclauses
       `rappend`
       gDocumentEntrypoints @kind @y
         (ParamBuilder $ \a -> michDesc $ "Right (" <> a <> ")")
         rclauses

instance ( 'CaseClauseParam ctor cf ~ GCaseBranchInput ctor x
         , KnownSymbol ctor
         , DocItem (DEntrypoint kind)
         , DeriveCtorFieldDoc ctor cf
         ) =>
         GDocumentEntrypoints kind (G.C1 ('G.MetaCons ctor _1 _2) x) where
  gDocumentEntrypoints michDesc (CaseClauseL clause :& RNil) =
    let entrypointName = toText $ symbolVal (Proxy @ctor)
        psteps = mkPbsWrapIn entrypointName michDesc
        addDoc instr =
          clarifyParamBuildingSteps psteps $
          docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $
          doc (deriveCtorFieldDoc @ctor @cf) # instr
    in CaseClauseL (addDoc clause) :& RNil

-- | Like 'case_', to be used for pattern-matching on a parameter
-- or its part.
--
-- Modifies documentation accordingly. Including description of
-- entrypoints' arguments, thus for them you will need to supply
-- 'TypeHasDoc' instance.
entryCase_
  :: forall dt entrypointKind out inp.
     ( InstrCaseC dt
     , RMap (CaseClauses dt)
     , DocumentEntrypoints entrypointKind dt
     )
  => Proxy entrypointKind
  -> Rec (CaseClauseL inp out) (CaseClauses dt)
  -> dt & inp :-> out
entryCase_ _ = case_ . documentEntrypoints @dt @entrypointKind

-- | Version of 'entryCase_' for tuples.
entryCase
  :: forall dt entrypointKind out inp clauses.
     ( CaseTC dt out inp clauses
     , DocumentEntrypoints entrypointKind dt
     )
  => Proxy entrypointKind -> IsoRecTuple clauses -> dt & inp :-> out
entryCase p = entryCase_ p . recFromTuple

-- | Wrapper for documenting single entrypoint which parameter
-- isn't going to be unwrapped from some datatype.
--
-- @entryCase@ unwraps a datatype, however, sometimes we want to
-- have entrypoint parameter to be not wrapped into some datatype.
documentEntrypoint
  :: forall kind epName param s out.
     ( KnownSymbol epName
     , DocItem (DEntrypoint kind)
     , TypeHasDoc param
     , HasAnnotation param
     , KnownValue param
     )
  => param & s :-> out -> param & s :-> out
documentEntrypoint instr =
  let entrypointName = toText $ symbolVal (Proxy @epName) in
    docGroup (SomeDocItem . DEntrypoint @kind entrypointName) $
    doc (constructDEpArg @param) # instr

-- | Provides arror for convenient entrypoint documentation
class EntryArrow kind name body where
  -- | Lift entrypoint implementation.
  --
  -- Entrypoint names should go with "e" prefix.
  (#->) :: (Label name, Proxy kind) -> body -> body

instance ( name ~ ("e" `AppendSymbol` epName)
         , body ~ (param & s :-> out)
         , KnownSymbol epName
         , DocItem (DEntrypoint kind)
         , TypeHasDoc param
         , HasAnnotation param
         , KnownValue param
         ) => EntryArrow kind name body where
  (#->) _ = documentEntrypoint @kind @epName

-- | Modify param building steps with respect to entrypoints that given
-- parameter declares.
--
-- Each contract with entrypoints should eventually call this function,
-- otherwise, in case if contract uses built-in entrypoints feature,
-- the resulting parameter building steps in the generated documentation
-- will not consider entrypoints and thus may be incorrect.
--
-- Calling this twice over the same code is also prohibited.
finalizeParamCallingDoc
  :: forall cp inp out.
     (NiceParameterFull cp, RequireSumType cp, HasCallStack)
  => (cp : inp :-> out) -> (cp : inp :-> out)
finalizeParamCallingDoc = modifyParamBuildingSteps modifySteps
  where
    -- We do not actually need it, requiring this constraint only to avoid
    -- misapplication of our function.
    _needSumType :: Dict (RequireSumType cp)
    _needSumType = Dict

    epDescs :: [Some1 EpCallingDesc]
    epDescs =
      -- Reversing the list because if element @e1@ of this list is prefix of
      -- another element @e2@, we want @e2@ to appear eariler than @e1@ to
      -- match against it first. But without reverse exactly the opposite
      -- holds due to [order of entrypoints children] property.
      reverse $ pepDescsWithDef @cp

    modifySteps :: [ParamBuildingStep] -> [ParamBuildingStep]
    modifySteps pbs
      | areFinalizedParamBuildingSteps pbs =
          error "Applying finalization second time"
      | otherwise =
          fromMaybe [PbsUncallable pbs] . listToMaybe . catMaybes $
          epDescs <&> \epDesc -> tryShortcut epDesc pbs

    -- Further we check whether given 'EpCallingStep's form prefix of
    -- 'ParamBuildingStep's; if so, we can apply only part of building
    -- steps and then call the entrypoint directly

    match :: [EpCallingStep] -> [ParamBuildingStep] -> Bool
    match cSteps pbSteps =
      and $ zip cSteps (prolong pbSteps) <&> \case
        (EpsWrapIn ctor, Just (PbsWrapIn ctor2 _)) | ctor == ctor2 -> True
        _ -> False
      where
        prolong :: [a] -> [Maybe a]
        prolong l = map Just l ++ repeat Nothing

    tryShortcut
      :: Some1 EpCallingDesc
      -> [ParamBuildingStep]
      -> Maybe [ParamBuildingStep]
    tryShortcut (Some1 EpCallingDesc{ epcdSteps = cSteps, epcdEntrypoint = ep })
                pbSteps
      | match cSteps pbSteps =
          let truncated = drop (length cSteps) pbSteps
              callEpStep = PbsCallEntrypoint ep
          in Just $ callEpStep : truncated
      | otherwise = Nothing

-- | Whether 'finalizeParamCallingDoc' has already been applied to these steps.
areFinalizedParamBuildingSteps :: [ParamBuildingStep] -> Bool
areFinalizedParamBuildingSteps =
  -- Currently, 'finalizeParamCallingDoc' puts either 'PbsCallEntrypoint' or
  -- 'PbsUncallable' to list, and only it, and we rely on this behaviour here.
  -- If something changes so that these heuristics do not work, we can always
  -- insert special markers which would tell us whether finalization has been
  -- applied.
  let
    hasFinalizationTraces = \case
      PbsWrapIn{} -> False
      PbsCallEntrypoint{} -> True
      PbsCustom{} -> False
      PbsUncallable{} -> True
  in any hasFinalizationTraces

entryCaseSimple_
  :: forall cp out inp.
     ( InstrCaseC cp
     , RMap (CaseClauses cp)
     , DocumentEntrypoints PlainEntrypointsKind cp
     , NiceParameterFull cp
     , RequireFlatParamEps cp
     )
  => Rec (CaseClauseL inp out) (CaseClauses cp)
  -> cp & inp :-> out
entryCaseSimple_ =
  finalizeParamCallingDoc . entryCase_ (Proxy @PlainEntrypointsKind)
  where
    _reqFlat = Dict @(RequireFlatEpDerivation cp (GetParameterEpDerivation cp))

-- | Version of 'entryCase' for contracts with flat parameter, use it when you
-- need only one 'entryCase' all over the contract implementation.
--
-- This method calls 'finalizeParamCallingDoc' inside.
entryCaseSimple
  :: forall cp out inp clauses.
     ( CaseTC cp out inp clauses
     , DocumentEntrypoints PlainEntrypointsKind cp
     , NiceParameterFull cp
     , RequireFlatParamEps cp
     )
  => IsoRecTuple clauses -> cp & inp :-> out
entryCaseSimple = entryCaseSimple_ . recFromTuple

type family RequireFlatParamEps cp :: Constraint where
  RequireFlatParamEps cp =
    ( RequireFlatEpDerivation cp (GetParameterEpDerivation cp)
    , RequireSumType cp
    )

-- Checking this is not strictly necessary, but let's try it
type family RequireFlatEpDerivation cp deriv :: Constraint where
  RequireFlatEpDerivation _ EpdNone = ()
  RequireFlatEpDerivation _ EpdPlain = ()
  RequireFlatEpDerivation cp deriv = TypeError
    ( 'Text "Parameter is not flat" ':$$:
      'Text "For parameter `" ':<>: 'ShowType cp ':<>: 'Text "`" ':$$:
      'Text "With entrypoints derivation way `" ':<>: 'ShowType deriv ':<>: 'Text "`"
    )