Doc.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_GHC -Wno-orphans #-}

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

    -- * Views
  , DView (..)
  , DViewArg (..)
  , DViewRet (..)
  , DViewDesc (..)
  , ViewsDescriptorHasDoc (..)

    -- * 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 (..)
  , typeDocBuiltMichelsonRep

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

import Data.Singletons (demote)
import Data.Typeable (typeRep)
import Fmt (Buildable(..), Builder, pretty)

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

-- | 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 vd) where
  buildDocUnfinalized =
    buildDocUnfinalized . cDocumentedCode
instance ContainsUpdateableDoc (Contract cp st vd) 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, ViewsDescriptorHasDoc vd) => TypeHasDoc (TAddress p vd) 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 pa =
    customTypeDocMdReference' ("TAddress", DType pa)
      [ typeDocMdReference (Proxy @p)
      , \_wp -> docDefinitionRef
          (mdTicked . pretty $ viewsDescriptorName (Proxy @vd))
          (DViewDesc (Proxy @vd))
      ]
  typeDocDependencies _ =
    [ dTypeDep @()
    , SomeDocDefinitionItem $ DViewDesc (Proxy @vd)
    ]
  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

----------------------------------------------------------------------------
-- Views documentation
----------------------------------------------------------------------------

-- View doc items
----------------------------------------------------------------------------

-- | Renders to a view section.
data DView = DView
  { dvName :: ViewName
  , dvSub :: SubDoc
  }

-- | Renders to a line mentioning the view's argument.
data DViewArg =
  forall a. (NiceViewable a, TypeHasDoc a) => DViewArg (Proxy a)

-- | Renders to a line mentioning the view's argument.
data DViewRet =
  forall a. (NiceViewable a, TypeHasDoc a) => DViewRet (Proxy a)

instance DocItem DViewArg where
  docItemPos = 20
  docItemSectionName = Nothing
  docItemDependencies (DViewArg p) =
    [ SomeDocDefinitionItem (DType p) ]
  docItemToMarkdown _ (DViewArg p) =
    "Argument type: " <> typeDocMdReference p (WithinParens False) <> "\n\n"

instance DocItem DViewRet where
  docItemPos = 21
  docItemSectionName = Nothing
  docItemDependencies (DViewRet p) =
    [ SomeDocDefinitionItem (DType p) ]
  docItemToMarkdown _ (DViewRet p) =
    "Return type: " <> typeDocMdReference p (WithinParens False) <> "\n\n"

instance DocItem DView where
  type DocItemPlacement DView = 'DocItemInlined
  type DocItemReferenced DView = 'True
  docItemRef (DView name _) = DocItemRefInlined $
    DocItemId ("views-" <> pretty name)
  docItemPos = 12000
  docItemSectionName = Just "Contract views"
  docItemSectionDescription = Just
    "On-chain views of the contract."
  docItemToMarkdown lvl (DView name block) = mconcat
    [ mdHeader lvl $ mdTicked (build name)
    , subDocToMarkdown (nextHeaderLevel lvl) block
    ]

-- View list
----------------------------------------------------------------------------

-- | Helper typeclass to renders information about view interface.
class RenderViewsImpl (vs :: [ViewTyInfo]) where
  renderViewsDocImpl :: Proxy vs -> Builder

instance RenderViewsImpl '[] where
  renderViewsDocImpl _ = mempty

instance ( KnownSymbol name, TypeHasDoc arg, TypeHasDoc ret
         , RenderViewsImpl vs
         ) =>
         RenderViewsImpl ('ViewTyInfo name arg ret ': vs) where
  renderViewsDocImpl _ = mconcat
    [ mconcat $ map (<> "\n")
      [ "* " <> mdTicked (pretty $ demoteViewName @name)
      , "  + Parameter type: "
      , "    * Haskell representation: " <> typeDocMdReference (Proxy @arg) (WithinParens False)
      , "    * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @arg)
      , "  + Return type: "
      , "    * Haskell representation: " <> typeDocMdReference (Proxy @ret) (WithinParens False)
      , "    * Michelson: " <> typeDocBuiltMichelsonRep (Proxy @ret)
      , ""
      ]
    , renderViewsDocImpl (Proxy @vs)
    ]

-- | Provides documentation for views descriptor.
--
-- Note that views descriptors may describe views that do not belong to the
-- current contract, e.g. @TAddress@ may refer to an external contract provided
-- by the user in which we want to call a view.
class (Typeable vd, RenderViewsImpl (RevealViews vd)) =>
      ViewsDescriptorHasDoc (vd :: Type) where

  viewsDescriptorName :: Proxy vd -> Text
  default viewsDescriptorName
    :: (Generic vd, KnownSymbol (GenericTypeName vd))
    => Proxy vd -> Text
  viewsDescriptorName _ = toText $ symbolVal (Proxy @(GenericTypeName vd))
    where _reallyNeedGenerics = Dict @(Generic vd)

  renderViewsDescriptorDoc :: Proxy vd -> Builder
  renderViewsDescriptorDoc _ =
    "Contract having this type must contain the following views:\n"
    <> renderViewsDocImpl (Proxy @(RevealViews vd))

-- | Renders to documentation of view descriptor.
data DViewDesc = forall vd. ViewsDescriptorHasDoc vd => DViewDesc (Proxy vd)

instance Eq DViewDesc where
  (==) = (== Prelude.EQ) ... compare
instance Ord DViewDesc where
  compare = compare `on` (\(DViewDesc p) -> typeRep p)

instance DocItem DViewDesc where
  type DocItemPlacement DViewDesc = 'DocItemInDefinitions
  type DocItemReferenced DViewDesc = 'True
  docItemRef (DViewDesc p) = DocItemRef $
    DocItemId ("views-descs-" <> show (typeRep p))
  docItemPos = 18010
  docItemSectionName = Just "Referenced views descriptors"
  docItemSectionDescription = Just
    "All the mentioned views descriptors.\n\
    \Each descriptor stands for a set of views"
  docItemToMarkdown lvl (DViewDesc p) =
    mconcat
    [ mdSeparator
    , mdHeader lvl $ mdTicked $ build (viewsDescriptorName p)
    , "\n\n"
    , renderViewsDescriptorDoc p
    ]