Doc.hs

{-# LANGUAGE DerivingStrategies, TypeFamilyDependencies, UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Renderable documentation injected to contract code.
module Michelson.Doc
  ( DocItem (..)
  , docItemPosition
  , DocItemId (..)
  , DocItemPlacementKind (..)
  , DocItemRef (..)
  , DocSectionNameStyle (..)
  , SomeDocItem (..)
  , SomeDocDefinitionItem (..)
  , DocBlock
  , SubDoc (..)
  , ContractDoc (..)
  , DocGrouping
  , cdContentsL
  , cdDefinitionsL
  , cdDefinitionsSetL
  , cdDefinitionIdsL
  , subDocToMarkdown
  , someDocItemToBlock
  , contractDocToMarkdown
  , docGroupContent
  , docDefinitionRef

  , DName (..)
  , DDescription (..)
  , DVersion (..)
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  ) where

import qualified Data.Map as M
import qualified Data.Map.Merge.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Typeable (cast, typeRep)
import Development.GitRev (gitCommitDate, gitHash)
import Fmt (Buildable, build, fmt, (+|), (+||), (|+), (||+))
import GHC.TypeNats (Nat)
import qualified Language.Haskell.TH as TH
import qualified Text.Show

import Util.Instances ()
import Util.Lens
import Util.Markdown
import Util.Type
import Util.Typeable

-- | A piece of documentation describing one property of a thing,
-- be it a name or description of a contract, or an error throwable
-- by given endpoint.
--
-- Items of the same type appear close to each other in a rendered documentation
-- and form a /section/.
--
-- Doc items are later injected into a contract code via a dedicated nop-like
-- instruction. Normally doc items which belong to one section appear in
-- resulting doc in the same order in which they appeared in the contract.
--
-- While documentation framework grows, this typeclass acquires more and more
-- methods for fine tuning of existing rendering logic because we don't want
-- to break backward compatibility, hope one day we will make everything
-- concise :(
-- E.g. all rendering and reording stuff could be merged in one method, and
-- we could have several template implementations for it which would allow
-- user to specify only stuff relevant to his case.
class (Typeable d, DOrd d, KnownNat (DocItemPosition d)) => DocItem d where
  -- | Position of this item in the resulting documentation;
  -- the smaller the value, the higher the section with this element
  -- will be placed.
  --
  -- Documentation structure is not necessarily flat.
  -- If some doc item consolidates a whole documentation block within it,
  -- this block will have its own placement of items independent from outer parts
  -- of the doc.
  type DocItemPosition d = (pos :: Nat) | pos -> d

  -- | When multiple items of the same type belong to one section, how
  -- this section will be called.
  --
  -- If not provided, section will contain just untitled content.
  docItemSectionName :: Maybe Text

  -- | Description of a section.
  --
  -- Can be used to mention some common things about all elements of this section.
  -- Markdown syntax is permitted here.
  docItemSectionDescription :: Maybe Markdown
  docItemSectionDescription = Nothing

  -- | How to render section name.
  --
  -- Takes effect only if section name is set.
  docItemSectionNameStyle :: DocSectionNameStyle
  docItemSectionNameStyle = DocSectionNameBig

  -- | Defines where given doc item should be put. There are two options:
  -- 1. Inline right here (default behaviour);
  -- 2. Put into definitions section.
  --
  -- Note that we require all doc items with "in definitions" placement to
  -- have 'Eq' and 'Ord' instances which comply the following law:
  -- if two documentation items describe the same entity or property, they
  -- should be considered equal.
  type DocItemPlacement d :: DocItemPlacementKind
  type DocItemPlacement d = 'DocItemInlined

  -- | Defines a function which constructs an unique identifier of given doc item,
  -- if it has been decided to put the doc item into definitions section.
  --
  -- Identifier should be unique both among doc items of the same type and items
  -- of other types. Thus, consider using "typeId-contentId" pattern.
  docItemRef :: d -> DocItemRef (DocItemPlacement d)
  default docItemRef
    :: (DocItemPlacement d ~ 'DocItemInlined)
    => d -> DocItemRef (DocItemPlacement d)
  docItemRef _ = DocItemNoRef

  -- | Render given doc item to Markdown, preferably one line,
  -- optionally with header.
  --
  -- Accepts the smallest allowed level of header.
  -- (Using smaller value than provided one will interfere with existing
  -- headers thus delivering mess).
  docItemToMarkdown :: HeaderLevel -> d -> Markdown

  -- | All doc items which this doc item refers to.
  --
  -- They will automatically be put to definitions as soon as given doc item
  -- is detected.
  docItemDependencies :: d -> [SomeDocDefinitionItem]
  docItemDependencies _ = []

  -- | This function accepts doc items put under the same section in the order
  -- in which they appeared in the contract and returns their new desired order.
  -- It's also fine to use this function for filtering or merging doc items.
  --
  -- Default implementation
  -- * leaves inlined items as is;
  -- * for items put to definitions, lexicographically sorts them by their id.
  docItemsOrder :: [d] -> [d]
  docItemsOrder = \case
    [] -> []
    docItems@(someDocItem : _) -> case docItemRef someDocItem of
      DocItemNoRef -> docItems
      DocItemRef _ -> docItemsOrderById docItems

-- | Get doc item position at term-level.
docItemPosition :: forall d. DocItem d => DocItemPos
docItemPosition = DocItemPos $ natVal (Proxy @(DocItemPosition d))

-- | Render an item into Markdown block with all required adjustments.
docItemToMarkdownFull :: DocItem d => HeaderLevel -> d -> Markdown
docItemToMarkdownFull l d =
  manchor <> docItemToMarkdown l d <> "\n\n"
  where
    manchor = case docItemRef d of
      DocItemRef (DocItemId docItemId) -> mdAnchor docItemId
      DocItemNoRef -> ""

-- | Order items by their 'docItemId'.
docItemsOrderById
  :: forall d. (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)
  => [d] -> [d]
docItemsOrderById docItems =
  let getDocItemId :: d -> DocItemId
      getDocItemId d = case docItemRef d of { DocItemRef di -> di }
  in sortOn getDocItemId docItems

-- | Make a reference to doc item in definitions.
docDefinitionRef
  :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)
  => Markdown -> d -> Markdown
docDefinitionRef refText d = case docItemRef d of
  DocItemRef (DocItemId docItemId) -> mdLocalRef refText docItemId

-- | Some unique identifier of a doc item.
--
-- All doc items which should be refer-able need to have this identifier.
newtype DocItemId = DocItemId Text
  deriving stock (Eq, Ord, Show)

-- | Position of all doc items of some type.
newtype DocItemPos = DocItemPos Natural
  deriving stock (Eq, Ord, Show)
  deriving newtype (Buildable)

-- | Where do we place given doc item.
data DocItemPlacementKind
  = DocItemInlined
    -- ^ Placed in the document content itself.
  | DocItemInDefinitions
    -- ^ Placed in dedicated definitions section; can later be referenced.

-- | Defines an identifier which given doc item can be referenced with.
data DocItemRef (p :: DocItemPlacementKind) where
  DocItemRef :: DocItemId -> DocItemRef 'DocItemInDefinitions
  DocItemNoRef :: DocItemRef 'DocItemInlined

-- | How to render section name.
data DocSectionNameStyle
  = DocSectionNameBig
    -- ^ Suitable for block name.
  | DocSectionNameSmall
    -- ^ Suitable for subsection title within block.

-- | Hides some documentation item.
data SomeDocItem where
  SomeDocItem :: DocItem d => d -> SomeDocItem

-- | Hides some documentation item which is put to "definitions" section.
data SomeDocDefinitionItem where
  SomeDocDefinitionItem
    :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)
    => d -> SomeDocDefinitionItem

instance Eq SomeDocDefinitionItem where
  SomeDocDefinitionItem d1 == SomeDocDefinitionItem d2 =
    d1 `eqExt` d2
instance Ord SomeDocDefinitionItem where
  SomeDocDefinitionItem d1 `compare` SomeDocDefinitionItem d2 =
    d1 `compareExt` d2

-- | To automatically derive @instance Show Michelson.Typed.Instr@ later.
instance Show SomeDocItem where
  show _ = "<doc item>"

type family DOrd d :: Constraint where
  DOrd d = If (DocItemPlacement d == 'DocItemInDefinitions)
             (Ord d) (() :: Constraint)

-- | A map from positions to document elements.
--
-- Note that each value in this map keeps a list of doc items, all of which
-- have the same type (since each doc item type is forced to have unique position).
type DocBlock = Map DocItemPos (NonEmpty SomeDocItem)

-- | Make sure several 'SomeDocItem's have the same type inside.
unifyDocItemsUnsafe
  :: HasCallStack
  => NonEmpty SomeDocItem
  -> (forall d. DocItem d => NonEmpty d -> r)
  -> r
unifyDocItemsUnsafe (SomeDocItem (firstDocItem :: d) :| docItems) cont =
  let
    dis = docItems <&> \(SomeDocItem di) ->
      cast di ?: error (castErr di)
  in cont $ firstDocItem :| dis
  where
    castErr :: Typeable d' => d' -> Text
    castErr (_ :: d') =
      "Non-homogenious doc block: found two doc items of different types: "
      +|| typeRep (Proxy @d) ||+ " and " +|| typeRep (Proxy @d') ||+ ""

-- | Render a documentation block.
docBlockToMarkdown :: HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown hl block =
  mconcat $ M.elems block <&> \items@(SomeDocItem (_ :: di) :| _) ->
    let sectionName = docItemSectionName @di
        sectionNameStyle = docItemSectionNameStyle @di
        (sectionNameFull, headerLevelDelta) =
          case sectionName of
            Nothing -> ("", id)
            Just sn ->
              let sn' = build sn
              in case sectionNameStyle of
                  DocSectionNameBig ->
                    (mdHeader hl sn', nextHeaderLevel)
                  DocSectionNameSmall ->
                    ( mdSubsectionTitle sn' <> "\n"
                    , error $ "Using headers is not allowed when section name is set small\n\
                              \Make sure docItemToMarkdown @" <> show (typeRep $ Proxy @di) <>
                              "does not use its 'header level' argument"
                    )
        sectionDesc = docItemSectionDescription @di
        sectionDescFull =
          case sectionDesc of
            Nothing -> ""
            Just sd -> sd <> "\n\n"
        content =
          unifyDocItemsUnsafe items $ \dis ->
            mconcat $ docItemsOrder (toList dis) <&> \di ->
              docItemToMarkdownFull (headerLevelDelta hl) di
    in sectionNameFull <> sectionDescFull <> content

someDocItemToBlock :: SomeDocItem -> DocBlock
someDocItemToBlock sdi@(SomeDocItem (_ :: di)) =
  one (docItemPosition @di, one sdi)

-- | A part of documentation to be grouped. Essentially incapsulates 'DocBlock'.

-- One day we may need to define 'Eq' instance for this thing, and probably
-- we can consider any two entities equal for efficiency.
newtype SubDoc = SubDoc DocBlock

-- | Render documentation for 'SubDoc'.
subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown hl (SubDoc d) = docBlockToMarkdown hl d

-- | Keeps documentation gathered for some piece of contract code.
--
-- Used for building documentation of a contract.
data ContractDoc = ContractDoc
  { cdContents :: DocBlock
    -- ^ All inlined doc items.
  , cdDefinitions :: DocBlock
    -- ^ Definitions used in document.
    --
    -- Usually you put some large and repetitive descriptions here.
    -- This differs from the document content in that
    -- it contains sections which are always at top-level,
    -- disregard the nesting.
    --
    -- All doc items which define 'docItemId' method go here, and only they.
  , cdDefinitionsSet :: Set SomeDocDefinitionItem
    -- ^ We remember all already declared entries to avoid cyclic dependencies
    -- in documentation items discovery.
  , cdDefinitionIds :: Set DocItemId
    -- ^ We remember all already used identifiers.
    -- (Documentation naturally should not declare multiple items with
    -- the same identifier because that would make references to the respective
    -- anchors ambiguous).
  }

makeLensesWith postfixLFields ''ContractDoc

-- | Contract documentation assembly primarily relies on this instance.
instance Semigroup ContractDoc where
  cd1 <> cd2 = ContractDoc
    { cdContents =
        M.merge
          M.preserveMissing M.preserveMissing
          (M.zipWithMatched $ \_k l r -> l <> r)
          (cdContents cd1) (cdContents cd2)
    , cdDefinitions =
        M.merge
          M.preserveMissing M.preserveMissing
          (M.zipWithMatched $ \_k (l :| ls) rs ->
             let removeDups = filter $ not . (`isDefinedIn` cdDefinitionIds cd1)
             in l :| ls <> removeDups (toList rs)
          )
          (cdDefinitions cd1) (cdDefinitions cd2)
    , cdDefinitionsSet =
        S.union (cdDefinitionsSet cd1) (cdDefinitionsSet cd2)
    , cdDefinitionIds =
        S.union (cdDefinitionIds cd1) (cdDefinitionIds cd2)
    }
    where
      isDefinedIn :: SomeDocItem -> Set DocItemId -> Bool
      isDefinedIn (SomeDocItem di) defs =
        case docItemRef di of
          DocItemNoRef -> False
          DocItemRef docItemId -> docItemId `S.member` defs

instance Monoid ContractDoc where
  mempty = ContractDoc
    { cdContents = M.empty
    , cdDefinitions = M.empty
    , cdDefinitionsSet = S.empty
    , cdDefinitionIds = S.empty
    }

-- | Render given contract documentation to markdown document.
contractDocToMarkdown :: ContractDoc -> LText
contractDocToMarkdown ContractDoc{..} =
  let
    contents =
      docBlockToMarkdown (HeaderLevel 1) cdContents |+ "\n\n"
    definitions
      | null cdDefinitions = ""
      | otherwise =
        "# Definitions\n\n" +| docBlockToMarkdown (HeaderLevel 2) cdDefinitions
    total = fmt (contents <> definitions)
  in LT.strip total <> "\n"

-- | A function which groups a piece of doc under one doc item.
type DocGrouping = SubDoc -> SomeDocItem

instance Show DocGrouping where
  show _ = "<doc grouping>"

-- | Apply given grouping to documentation being built.
docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc
docGroupContent grouping doc =
  doc
  { cdContents = someDocItemToBlock . grouping $ SubDoc (cdContents doc)
  }

----------------------------------------------------------------------------
-- Basic doc items
----------------------------------------------------------------------------

-- | Give a name to document block.
data DName = DName Text SubDoc

instance DocItem DName where
  type DocItemPosition DName = 1
  docItemSectionName = Nothing
  docItemToMarkdown lvl (DName name doc) =
    mdHeader lvl (build name) <>
    subDocToMarkdown (nextHeaderLevel lvl) doc

-- | Description of something.
data DDescription = DDescription Markdown

instance DocItem DDescription where
  type DocItemPosition DDescription = 10
  docItemSectionName = Nothing
  docItemToMarkdown _ (DDescription txt) = build txt

-- | Specify version if given contract.
data DVersion = DVersion Natural

instance DocItem DVersion where
  type DocItemPosition DVersion = 3
  docItemSectionName = Nothing
  docItemToMarkdown _ (DVersion ver) =
    mdSubsection "Version" (build ver)

-- | Specify version if given contract.
data DGitRevision = DGitRevision
  { dgrRepoSettings :: GitRepoSettings
  , dgrCommitSha :: Text
  , dgrCommitDate :: Text
  }

-- | Repository settings for 'DGitRevision'.
newtype GitRepoSettings = GitRepoSettings
  { grsMkGitRevision :: Text -> Text
    -- ^ By commit sha make up a url to that commit in remote repository.

    -- @martoon: I tried to get remote URL automatically, but failed to
    -- find a way. Even "git-link" in emacs performs complex parsing.
  }

morleyRepoSettings :: GitRepoSettings
morleyRepoSettings = GitRepoSettings $ \commit ->
  "https://gitlab.com/morley-framework/morley/blob/" <> commit

-- | Make 'DGitRevision'.
--
-- >>> :t $mkDGitRevision
-- GitRepoSettings -> DGitRevision
mkDGitRevision :: TH.Q TH.Exp
mkDGitRevision = [e| \dgrRepoSettings ->
  DGitRevision
  { dgrRepoSettings
  , dgrCommitSha = $gitHash
  , dgrCommitDate = $gitCommitDate
  }
  |]

instance DocItem DGitRevision where
  type DocItemPosition DGitRevision = 7
  docItemSectionName = Nothing
  docItemToMarkdown _ DGitRevision{..} =
    mconcat $
    [ mdSubsection "Code revision" $
        let link = grsMkGitRevision dgrRepoSettings dgrCommitSha
        in mconcat
           [ mdRef (build $ T.take 7 dgrCommitSha) (build link)
           , " "
           , mdItalic $ "(" <> build dgrCommitDate <> ")"
           ]
    ]

--  | Comment in the doc (mostly used for licenses)
data DComment = DComment Text

instance DocItem DComment where
  type DocItemPosition DComment = 0
  docItemSectionName = Nothing
  docItemToMarkdown _ (DComment commentText) =
    "<!---\n" +| commentText |+ "\n-->"