Doc.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Doc
  ( doc
  , docGroup
  , 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 (..)
  , DDescription (..)
  , DEntrypointExample (..)
  , mkDEntrypointExample
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  , DAnchor (..)
  , DType (..)
  , dTypeDep
  , docDefinitionRef
  , contractDocToMarkdown
  , subDocToMarkdown

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

  , HaveCommonTypeCtor
  , IsHomomorphic
  , genericTypeDocDependencies
  , customTypeDocMdReference
  , homomorphicTypeDocMdReference
  , poly1TypeDocMdReference
  , poly2TypeDocMdReference
  , homomorphicTypeDocHaskellRep
  , concreteTypeDocHaskellRep
  , concreteTypeDocHaskellRepUnsafe
  , haskellAddNewtypeField
  , haskellRepNoFields
  , haskellRepStripFieldPrefix
  , homomorphicTypeDocMichelsonRep
  , concreteTypeDocMichelsonRep
  , concreteTypeDocMichelsonRepUnsafe
  , 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
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.
docGroup :: DocGrouping -> (inp :-> out) -> (inp :-> out)
docGroup gr = iMapAnyCode (DocGroup gr)

-- | Insert documentation of the contract storage type. The type
-- should be passed using type applications.
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.
contractName :: Text -> (inp :-> out) -> (inp :-> out)
contractName name = docGroup (SomeDocItem . DName name)

buildLorentzDoc :: inp :-> out -> ContractDoc
buildLorentzDoc (iAnyCode -> code) = buildInstrDoc code

-- | Takes an instruction that inserts documentation items with
-- general information about the contract. Inserts it into general
-- section. See 'DGeneralInfoSection'.
contractGeneral :: (inp :-> out) -> (inp :-> out)
contractGeneral = docGroup (SomeDocItem . DGeneralInfoSection)

-- | Inserts general information about the contract using the default format.
--
-- Currently we only include git revision. It is unknown in the
-- library code and is supposed to be updated in an executable.
contractGeneralDefault :: s :-> s
contractGeneralDefault =
  (contractGeneral $ doc DGitRevisionUnknown) #
  doc (DToc "") #
  doc DConversionInfo

buildLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> ContractDoc
buildLorentzDocWithGitRev gitRev (iAnyCode -> code) =
  buildInstrDocWithGitRev gitRev code

renderLorentzDoc :: inp :-> out -> LText
renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc

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]))
    )

-- | 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