Doc.hs

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

{-# OPTIONS_GHC -Wno-orphans #-}

module Lorentz.Doc
  ( doc
  , docGroup
  , dStorage
  , 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.Typeable (typeRep)
import Fmt (Buildable(..), Builder, pretty)

import Lorentz.Base
import Lorentz.Constraints
import Lorentz.Value
import Lorentz.ViewBase
import Morley.Michelson.Doc
import Morley.Michelson.Optimizer
import Morley.Michelson.Printer
import Morley.Michelson.Typed hiding (Contract, ContractCode, ContractCode'(..))
import Morley.Util.Generic
import Morley.Util.Markdown
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)

-- | 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. 'attachDocCommons'.
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 (ContractCode i o) where
  buildDocUnfinalized = buildDocUnfinalized . iAnyCode . unContractCode
instance ContainsUpdateableDoc (ContractCode i o) where
  modifyDocEntirely how (ContractCode x) = ContractCode $
    iMapAnyCode (modifyDocEntirely how) x

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

-- | 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 (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 = 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
    ]