Doc.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Doc
  ( doc
  , docGroup
  , dStorage
  , docStorage
  , buildLorentzDoc
  , buildLorentzDocWithGitRev
  , renderLorentzDoc
  , renderLorentzDocWithGitRev
  , contractName
  , contractGeneral
  , contractGeneralDefault
  , cutLorentzNonDoc

    -- * Re-exports
  , Markdown
  , DocElem(..)
  , DocItem (..)
  , docItemPosition
  , DocItemId (..)
  , DocItemPlacementKind (..)
  , DocItemPos(..)
  , DocItemRef (..)
  , DocSection(..)
  , DocSectionNameStyle (..)
  , SomeDocItem (..)
  , SomeDocDefinitionItem (..)
  , SubDoc (..)
  , DocGrouping
  , ContractDoc (..)
  , DGeneralInfoSection (..)
  , DName (..)
  , DDescription (..)
  , DEntrypointExample (..)
  , mkDEntrypointExample
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  , DAnchor (..)
  , DType (..)
  , dTypeDep
  , docDefinitionRef
  , contractDocToMarkdown
  , subDocToMarkdown
  , docItemSectionRef
  , ContainsDoc (..)
  , ContainsUpdateableDoc (..)
  , WithFinalizedDoc
  , finalizedAsIs
  , buildDoc
  , buildMarkdownDoc
  , modifyDoc
  , attachDocCommons

  , TypeHasDoc (..)
  , SomeTypeWithDoc (..)

  , HaveCommonTypeCtor
  , IsHomomorphic
  , genericTypeDocDependencies
  , customTypeDocMdReference
  , homomorphicTypeDocMdReference
  , poly1TypeDocMdReference
  , poly2TypeDocMdReference
  , homomorphicTypeDocHaskellRep
  , concreteTypeDocHaskellRep
  , unsafeConcreteTypeDocHaskellRep
  , haskellAddNewtypeField
  , haskellRepNoFields
  , haskellRepStripFieldPrefix
  , homomorphicTypeDocMichelsonRep
  , concreteTypeDocMichelsonRep
  , unsafeConcreteTypeDocMichelsonRep
  , mdTocFromRef
  ) where

import Data.Singletons (demote)
import Fmt (build)

import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Value
import Lorentz.Zip ()
import Michelson.Doc
import Michelson.Optimizer
import Michelson.Printer
import Michelson.Typed hiding (Contract)
import Util.Markdown
import Util.Type

-- | Put a document item.
doc :: DocItem di => di -> s :-> s
doc = I . docInstr

-- | Group documentation built in the given piece of code
-- into block dedicated to one thing, e.g. to one entrypoint.
--
-- Examples of doc items you can pass here: 'DName', 'DGeneralInfoSection'.
docGroup :: DocItem di => (SubDoc -> di) -> (inp :-> out) -> (inp :-> out)
docGroup gr = iMapAnyCode (DocGroup $ SomeDocItem . gr)

-- | Insert documentation of the contract storage type. The type
-- should be passed using type applications.
{-# DEPRECATED docStorage "Use `doc (dStorage @storage)` instead." #-}
docStorage :: forall storage s. TypeHasDoc storage => s :-> s
docStorage = doc $ DStorageType $ DType $ Proxy @storage

-- | Give a name to given contract. Apply it to the whole contract code.
{-# DEPRECATED contractName "Use `docGroup name` instead." #-}
contractName :: Text -> (inp :-> out) -> (inp :-> out)
contractName name = docGroup (DName name)

{-# DEPRECATED buildLorentzDoc "Use 'buildDoc' instead." #-}
buildLorentzDoc :: inp :-> out -> ContractDoc
buildLorentzDoc = buildDocUnfinalized

-- | Takes an instruction that inserts documentation items with
-- general information about the contract. Inserts it into general
-- section. See 'DGeneralInfoSection'.
{-# DEPRECATED contractGeneral "Use `docGroup DGeneralInfoSection` instead." #-}
contractGeneral :: (inp :-> out) -> (inp :-> out)
contractGeneral = docGroup DGeneralInfoSection

-- | Inserts general information about the contract using the default format.
--
-- This includes git revision and some other information common
-- for all contracts.
-- Git revision is left unknown in the library code and is supposed
-- to be updated in an executable using e.g. 'buildLorentzDocWithGitRev'.
contractGeneralDefault :: s :-> s
contractGeneralDefault =
  (docGroup DGeneralInfoSection $
     doc DGitRevisionUnknown
  ) #
  doc (DToc "") #
  doc DConversionInfo

instance ContainsDoc (i :-> o) where
  buildDocUnfinalized = buildDocUnfinalized . iAnyCode
instance ContainsUpdateableDoc (i :-> o) where
  modifyDocEntirely how = iMapAnyCode $ modifyDocEntirely how

instance ContainsDoc (Contract cp st) where
  buildDocUnfinalized =
    buildDocUnfinalized . cDocumentedCode
instance ContainsUpdateableDoc (Contract cp st) where
  modifyDocEntirely how c =
    c{ cDocumentedCode = modifyDocEntirely how (cDocumentedCode c) }

{-# DEPRECATED buildLorentzDocWithGitRev
    "Use `buildDoc . attachDocCommons gitRev` instead."
#-}
buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc
buildLorentzDocWithGitRev gitRev = buildDoc . attachDocCommons gitRev

{-# DEPRECATED renderLorentzDoc "Use 'buildMarkdownDoc' instead." #-}
renderLorentzDoc :: inp :-> out -> LText
renderLorentzDoc = buildMarkdownDoc . finalizedAsIs

{-# DEPRECATED renderLorentzDocWithGitRev
    "Use `buildMarkdownDoc . attachDocCommons gitRev` instead."
#-}
renderLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> LText
renderLorentzDocWithGitRev gitRev = contractDocToMarkdown . buildLorentzDocWithGitRev gitRev

-- | Leave only instructions related to documentation.
--
-- This function is useful when your method executes a lambda coming from outside,
-- but you know its properties and want to propagate its documentation to your
-- contract code.
cutLorentzNonDoc :: (inp :-> out) -> (s :-> s)
cutLorentzNonDoc (iAnyCode -> code) = I $ cutInstrNonDoc optimize code

instance Each [Typeable, ReifyList TypeHasDoc] [i, o] =>
         TypeHasDoc (i :-> o) where
  typeDocName _ = "Code (extended lambda)"
  typeDocMdReference tp wp =
    let DocItemRef ctorDocItemId = docItemRef (DType tp)
        refToThis = mdLocalRef (mdTicked "Code") ctorDocItemId
    in applyWithinParens wp $
      mconcat $ intersperse " " [refToThis, refToStack @i, refToStack @o]
    where
    refToStack :: forall s. ReifyList TypeHasDoc s => Markdown
    refToStack =
      let stack = reifyList @_ @TypeHasDoc @s (\p -> typeDocMdReference p (WithinParens False))
      in mconcat
          [ mdBold "["
          , case stack of
              [] -> " "
              st -> mconcat $ intersperse (mdBold "," <> " ") st
          , mdBold "]"
          ]

  typeDocMdDescription =
    "`Code i o` stands for a sequence of instructions which accepts stack \
    \of type `i` and returns stack of type `o`.\n\n\
    \When both `i` and `o` are of length 1, this primitive corresponds to \
    \the Michelson lambda. In more complex cases code is surrounded with `pair`\
    \and `unpair` instructions until fits into mentioned restriction.\
    \"
  typeDocDependencies _ = mconcat
    [ reifyList @_ @TypeHasDoc @i dTypeDepP
    , reifyList @_ @TypeHasDoc @o dTypeDepP
    , [ dTypeDep @Integer
      , dTypeDep @Natural
      , dTypeDep @MText
      ]
    ]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep _ =
    ( Just "Code [Integer, Natural, MText, ()] [ByteString]"
    , demote @(ToT ([Integer, Natural, MText, ()] :-> '[ByteString]))
    )

instance TypeHasDoc p => TypeHasDoc (TAddress p) where
  typeDocMdDescription = [md|
    A typed version of address primitive.

    Type in `TAddress` denotes parameter type of the target contract.

    This is not assumed to carry an entrypoint name.
    |]
  typeDocMdReference = poly1TypeDocMdReference
  typeDocDependencies _ = [dTypeDep @()]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(TAddress ())

instance TypeHasDoc p => TypeHasDoc (FutureContract p) where
  typeDocName _ = "FutureContract"
  typeDocMdDescription = [md|
    A typed version of address primitive.

    Type in `FutureContract` denotes argument type of the target _entrypoint_.
    This address can carry an entrypoint name.

    We use `FutureContract` as a replacement for Michelson's `contract`, since
    places where the latter can appear are severely restricted.
    |]
  typeDocMdReference = poly1TypeDocMdReference
  typeDocDependencies _ = [dTypeDep @()]
  typeDocHaskellRep _ _ = Nothing
  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(FutureContract ())

-- | Modify the example value of an entrypoint
data DEntrypointExample = forall t . ParameterScope t => DEntrypointExample (Value t)

instance DocItem DEntrypointExample where
  docItemPos = 10000
  docItemSectionName = Nothing
  docItemToMarkdown _ (DEntrypointExample val) =
    build $ printUntypedValue True $ untypeValue val

mkDEntrypointExample :: forall a. NiceParameter a => a -> DEntrypointExample
mkDEntrypointExample v =
  withDict (niceParameterEvi @a) $
    DEntrypointExample $ toVal v