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

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

-- | Renderable documentation injected to contract code.
module Michelson.Doc
  ( DocItem (..)
  , docItemPosition
  , DocItemId (..)
  , DocItemPlacementKind (..)
  , DocItemPos (..)
  , DocItemRef (..)
  , DocItemReferencedKind
  , DocSectionNameStyle (..)
  , SomeDocItem (..)
  , SomeDocDefinitionItem (..)
  , DocElem (..)
  , DocSection (..)
  , DocBlock
  , SubDoc (..)
  , ContractDoc (..)
  , DocGrouping
  , cdContentsL
  , cdDefinitionsL
  , cdDefinitionsSetL
  , cdDefinitionIdsL
  , deIsAtomic
  , subDocToMarkdown
  , docItemToBlock
  , docItemSectionRef
  , lookupDocBlockSection
  , contractDocToMarkdown
  , contractDocToToc
  , docGroupContent
  , docDefinitionRef
  , mdTocFromRef
  , WithFinalizedDoc (..)
  , finalizedAsIs
  , ContainsDoc (..)
  , ContainsUpdateableDoc (..)
  , buildDoc
  , buildMarkdownDoc
  , modifyDoc

  , DGeneralInfoSection (..)
  , DName (..)
  , DDescription (..)
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  , DAnchor (..)
  , DToc (..)
  , DConversionInfo (..)
  , attachGitInfo
  , attachToc
  , attachDocCommons
  ) 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 qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Lift as TH
import System.Environment (lookupEnv)
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) => 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. If the position is the same as other doc items,
  -- they will be placed base on their name, alphabetically.
  --
  -- 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.
  docItemPos :: Natural

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

  type DocItemReferenced d :: DocItemReferencedKind
  type DocItemReferenced d = 'False

  -- | 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) (DocItemReferenced d)
  default docItemRef
    :: ( DocItemPlacement d ~ 'DocItemInlined
       , DocItemReferenced d ~ 'False
       )
    => d -> DocItemRef (DocItemPlacement d) (DocItemReferenced 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

  -- | Render table of contents entry for given doc item to Markdown.
  docItemToToc :: HeaderLevel -> d -> Markdown
  docItemToToc _ _ = ""

  -- | 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
      DocItemRefInlined _ ->
        docItems

-- | Generate 'DToc' entry anchor from 'docItemRef'.
mdTocFromRef :: (DocItem d, DocItemReferenced d ~ 'True) => HeaderLevel -> Markdown -> d -> Markdown
mdTocFromRef lvl text d =
  mdToc lvl text (toAnchor $ docItemRef d)

-- | Get doc item position at term-level.
docItemPosition :: forall d. DocItem d => DocItemPos
docItemPosition = DocItemPos (docItemPos @d, show (typeRep $ Proxy @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 -> mdAnchor docItemId
      DocItemRefInlined 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 -> 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)
  deriving newtype (ToAnchor)

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

instance Buildable DocItemPos where
  build (DocItemPos (a, _)) = build a

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

-- | Type-level check whether or not a doc item can be referenced.
type DocItemReferencedKind = Bool

data DocItemRef (p :: DocItemPlacementKind) (r :: DocItemReferencedKind) where
  DocItemRef        :: DocItemId -> DocItemRef 'DocItemInDefinitions 'True
  DocItemRefInlined :: DocItemId -> DocItemRef 'DocItemInlined 'True
  DocItemNoRef      :: DocItemRef 'DocItemInlined 'False

instance ToAnchor (DocItemRef d 'True) where
  toAnchor (DocItemRef ref) = toAnchor ref
  toAnchor (DocItemRefInlined ref) = toAnchor ref

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

-- NFData instance is needed for benchmarks and we want to avoid requiring users
-- to implement NFData instance for every single DocItem and they should not
-- affect the performance anyway.
instance NFData SomeDocItem where
  rnf (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 doc item which we store, along with related information.
data DocElem d = DocElem
  { deItem :: d
    -- ^ Doc item itself.
  , deSub :: Maybe SubDoc
    -- ^ Subdocumentation, if given item is a group.
  }

-- | Whether given 'DocElem' is atomic.
--
-- Normally, atomic 'DocElem's are ones appearing in @DOC_ITEM@ instruction,
-- and non-atomic ones are put to @DocGroup@.
deIsAtomic :: DocElem d -> Bool
deIsAtomic = isNothing . deSub

-- | Several doc items of the same type.
data DocSection = forall d. DocItem d => DocSection (NonEmpty $ DocElem d)

instance Show DocSection where
  show (DocSection (ds :: NonEmpty (DocElem d))) =
    "Doc items section: " <> show (typeRep $ Proxy @d) <>
    " / " <> show (length ds) <> " item(s)"

appendDocSectionUnsafe
  :: HasCallStack
  => DocSection -> DocSection -> DocSection
appendDocSectionUnsafe (DocSection ls) (DocSection rs) =
  DocSection $ appendDocSectionUnsafeImpl ls (toList rs)

appendDocSectionUnsafeImpl
  :: forall d1 d2.
     (Typeable d1, Typeable d2, HasCallStack)
  => NonEmpty d1 -> [d2] -> NonEmpty d1
appendDocSectionUnsafeImpl (l :| ls) rs =
  let rs' = rs <&> \r -> cast r ?: onTypeMismatch
  in l :| ls <> rs'
  where
    onTypeMismatch =
      error $ "appending doc sections for doc items of different types:"
              +|| typeRep (Proxy @d1) ||+ " and " +|| typeRep (Proxy @d2) ||+ ""

-- | A map from positions to document elements.
--
-- This form effeciently keeps documentation for its incremental building.
-- Doc items here appear close to how they were located in the contract;
-- for instance, 'docItemsOrder' is not yet applied at this stage.
-- You only can be sure that items within each group are splitted across
-- sections correctly.
type DocBlock = Map DocItemPos DocSection

-- | Render a documentation block.
docBlockToMarkdown :: HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown hl block =
  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem 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"
        resItems = docItemsOrder $ map deItem (toList items)
        content =
          mconcat $ resItems <&> \di ->
            docItemToMarkdownFull (headerLevelDelta hl) di
        anchor = maybe "" mdAnchor (docItemSectionAnchor @di)
    in if null resItems
       then ""
       else anchor <> sectionNameFull <> sectionDescFull <> content

-- | Anchor for all the sections (referring them as to headers may cause
-- colissions).
newtype SectionAnchor = SectionAnchor
  { _unSectionAnchor :: Text
    -- ^ Section name
  }

instance ToAnchor SectionAnchor where
  toAnchor (SectionAnchor t) = Anchor ("section-" <> t)

-- | Make an anchor that is to be attached to the given section.
docItemSectionAnchor :: forall di. DocItem di => Maybe SectionAnchor
docItemSectionAnchor = do
  case docItemSectionNameStyle @di of
    DocSectionNameBig -> pass
    DocSectionNameSmall -> mzero
  SectionAnchor <$> docItemSectionName @di

-- | Reference to the given section.
--
-- Will return @Nothing@ if sections of given doc item type are not
-- assumed to be referred outside.
docItemSectionRef :: forall di. DocItem di => Maybe Markdown
docItemSectionRef = do
  name <- docItemSectionName @di
  anchor <- docItemSectionAnchor @di
  return $ mdLocalRef (build name) anchor

-- | Render a part of table of contents from 'DocBlock'.
docBlockToToc :: HeaderLevel -> DocBlock -> Markdown
docBlockToToc hl block =
  mconcat $ M.elems block <&> \(DocSection items@((_ :: DocElem di) :| _)) ->
    let sectionName = docItemSectionName @di
        (sectionNameFull, headerLevelDelta) =
          case (sectionName, docItemSectionAnchor @di) of
            (_, Nothing) -> ("", id)
            (Nothing, _) -> ("", id)
            (Just "Table of contents", _) -> ("", id)
            (Just sn, Just anchor) ->
              (mdToc hl (build sn) anchor, nextHeaderLevel)
        resItems = docItemsOrder $ map deItem (toList items)
        content =
          mconcat $ resItems <&> docItemToToc (headerLevelDelta hl)
    in if null resItems
       then ""
       else sectionNameFull <> content

-- | Lift a doc item to a block, be it atomic doc item or grouping one.
docItemToBlockGeneral :: forall di. DocItem di => di -> Maybe SubDoc -> DocBlock
docItemToBlockGeneral di msub =
  one ( docItemPosition @di
      , DocSection $ one (DocElem di msub)
      )

-- | Lift an atomic doc item to a block.
docItemToBlock :: forall di. DocItem di => di -> DocBlock
docItemToBlock di = docItemToBlockGeneral di Nothing

-- | Find all doc items of the given type.
lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection block = do
  DocSection (ds :: NonEmpty (DocElem d')) <- M.lookup (docItemPosition @d) block
  case eqT @d @d' of
    Nothing -> error $ "Invalid DocBlock: item of type " +|| typeRep (Proxy @d) ||+ " \
                       \under position " +| docItemPosition @d |+ ""
    Just Refl -> pure $ map deItem ds

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

-- | Render documentation for 'SubDoc'.
subDocToToc :: HeaderLevel -> SubDoc -> Markdown
subDocToToc hl (SubDoc d) = docBlockToToc 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 -> appendDocSectionUnsafe l r)
          (cdContents cd1) (cdContents cd2)
    , cdDefinitions =
        M.merge
          M.preserveMissing M.preserveMissing
          (M.zipWithMatched $ \_k (DocSection ls) (DocSection rs) ->
             let removeDups = filter $ not . (`isDefinedIn` cdDefinitionIds cd1) . deItem
             in DocSection $ appendDocSectionUnsafeImpl ls (removeDups $ toList rs)
          )
          (cdDefinitions cd1) (cdDefinitions cd2)
    , cdDefinitionsSet =
        S.union (cdDefinitionsSet cd1) (cdDefinitionsSet cd2)
    , cdDefinitionIds =
        S.union (cdDefinitionIds cd1) (cdDefinitionIds cd2)
    }
    where
      isDefinedIn :: DocItem d => d -> Set DocItemId -> Bool
      isDefinedIn di defs =
        case docItemRef di of
          DocItemNoRef -> False
          DocItemRef docItemId -> docItemId `S.member` defs
          DocItemRefInlined 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"

contractDocToToc :: ContractDoc -> Markdown
contractDocToToc ContractDoc{..} =
  let
    contents =
      docBlockToToc (HeaderLevel 1) cdContents

    definitions
      | null cdDefinitions = ""
      | otherwise = "\n**[Definitions](#definitions)**\n\n"
          +| docBlockToToc (HeaderLevel 2) cdDefinitions
  in contents <> definitions <> "\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 =
      let sub = SubDoc (cdContents doc)
      in case grouping sub of
           SomeDocItem d -> docItemToBlockGeneral d (Just sub)
  }

-- | Everything that contains doc items that can be used to render the
-- documentation.
class ContainsDoc a where
  -- | Gather documentation.
  --
  -- Calling this method directly is discouraged in prod, see 'buildDoc' instead.
  -- Using this method in tests is fine though.
  buildDocUnfinalized :: a -> ContractDoc

-- | Some contract languages may support documentation update.
class ContainsDoc a => ContainsUpdateableDoc a where
  -- | Modify all documentation items recursively.
  modifyDocEntirely :: (SomeDocItem -> SomeDocItem) -> a -> a

-- | Often there is some tuning recommended prior to rendering the contract,
-- like attaching git revision info; this type designates that those last changes
-- were applied.
--
-- For example, at Michelson level you may want to use 'attachDocCommons'.
--
-- If you want no special tuning (e.g. for tests), say that explicitly with
-- 'finalizedAsIs'.
newtype WithFinalizedDoc a = WithFinalizedDoc (Identity a)
  deriving newtype (Functor, Applicative, Monad)

-- | Mark the code with doc as finalized without any changes.
finalizedAsIs :: a -> WithFinalizedDoc a
finalizedAsIs = WithFinalizedDoc . Identity

-- | Gather documenation.
buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc
buildDoc (WithFinalizedDoc (Identity a)) = buildDocUnfinalized a

-- | Construct and format documentation in textual form.
buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText
buildMarkdownDoc = contractDocToMarkdown . buildDoc

-- | Recursevly traverse doc items and modify those that match given type.
--
-- If mapper returns 'Nothing', doc item will remain unmodified.
modifyDoc
  :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2)
  => (i1 -> Maybe i2) -> a -> a
modifyDoc mapper = modifyDocEntirely untypedMapper
  where
  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do
    di' <- cast di
    newDi <- mapper di'
    return (SomeDocItem newDi)

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

-- | General (meta-)information about the contract such as git
-- revision, contract's authors, etc. Should be relatively short (not
-- several pages) because it is put somewhere close to the beginning of
-- documentation.
newtype DGeneralInfoSection = DGeneralInfoSection SubDoc

instance DocItem DGeneralInfoSection where
  docItemPos = 1
  docItemSectionName = Nothing
  docItemToMarkdown lvl (DGeneralInfoSection subDoc) =
    subDocToMarkdown lvl subDoc
  docItemToToc lvl (DGeneralInfoSection subDoc) =
    subDocToToc lvl subDoc

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

instance DocItem DName where
  docItemPos = 3
  docItemSectionName = Nothing
  docItemToMarkdown lvl (DName name doc) =
    mdHeader lvl (build name) <>
    subDocToMarkdown (nextHeaderLevel lvl) doc
  docItemToToc lvl (DName _ doc) =
    subDocToToc (nextHeaderLevel lvl) doc

-- | This instance allows writing something like @docGroup "Title"@,
-- this makes sense as the most primitive and basic use case for doc groups
-- is putting a section under name.
instance (di ~ DName) => IsString (SubDoc -> di) where
  fromString = DName . fromString

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

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

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

data DGitRevision
  = DGitRevisionKnown DGitRevisionInfo
  | DGitRevisionUnknown

-- | 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/-/tree/" <> commit

-- | Make 'DGitRevision'.
--
-- >>> :t $mkDGitRevision
-- GitRepoSettings -> DGitRevision
mkDGitRevision :: TH.ExpQ
mkDGitRevision = [e| \dgrRepoSettings ->
  maybe DGitRevisionUnknown DGitRevisionKnown $
    -- TH does not like do-blocks
    $(pickInfo gitHash "MORLEY_DOC_GIT_COMMIT_SHA") >>= \dgrCommitSha ->
    $(pickInfo gitCommitDate "MORLEY_DOC_GIT_COMMIT_DATE") >>= \dgrCommitDate ->
    return DGitRevisionInfo{..}
  |]
  where
    pickInfo a b = TH.lift =<< pickInfo' a b

    pickInfo' :: TH.ExpQ -> String -> TH.Q (Maybe String)
    pickInfo' askGit envKey =
      liftIO (lookupEnv envKey) >>= \case
        Just "UNSPECIFIED" -> return Nothing
        Just envValue -> return $ Just envValue
        Nothing -> askGit >>= \case
          -- Looks like with GitRev package we can't do anything better
          TH.LitE (TH.StringL "UNKNOWN") -> do
            TH.reportWarning $
              "Contract autodoc: \
              \Not including git repository info because it cannot be deduced. \
              \Either provide repository environment, or pass '" <> envKey <> "' \
              \environmental variable."
            return Nothing
          TH.LitE (TH.StringL str) -> return (Just str)
          value -> error $ "Unknown value returned by git: " <> show value

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

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

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

-- | @Table of contents@ to be inserted into the doc in an ad-hoc way.
--
-- It is not intended to be inserted manually. See 'attachToc' to understand
-- how this works.
--
data DToc = DToc Markdown

instance DocItem DToc where
  docItemPos = 11
  docItemSectionName = Just "Table of contents"
  docItemToMarkdown _ (DToc toc) = toc

-- | A hand-made anchor.
data DAnchor = DAnchor Anchor

instance DocItem DAnchor where
  docItemPos = 4
  docItemSectionName = Nothing
  docItemToMarkdown _ (DAnchor a) = mdAnchor a

data DConversionInfo = DConversionInfo

-- TODO: we should also recommend using morley-client when
-- it'll become good enough
instance DocItem DConversionInfo where
  docItemPos = 15
  docItemSectionName = Just "Haskell ⇄ Michelson conversion"
  docItemToMarkdown _ _ =
    "This smart contract is developed in Haskell using the \
    \[Morley framework](https://gitlab.com/morley-framework/morley). \
    \Documentation mentions Haskell types that can be used for interaction with \
    \this contract from Haskell, but for each Haskell type we also mention its \
    \Michelson representation to make interactions outside of Haskell possible.\n\n\
    \There are multiple ways to interact with this contract:\n\n\
    \* Use this contract in your Haskell application, thus all operation submissions \
    \should be handled separately, e.g. via calling `tezos-client`, which will communicate \
    \with the `tezos-node`. In order to be able to call `tezos-client` you'll need to be able \
    \to construct Michelson values from Haskell.\n\n\
    \  The easiest way to do that is to serialize Haskell value using `lPackValue` function \
    \from [`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs) \
    \module, encode resulting bytestring to hexadecimal representation using `encodeHex` function. \
    \Resulting hexadecimal encoded bytes sequence can be decoded back to Michelson value via \
    \`tezos-client unpack michelson data`.\n\n\
    \  Reverse conversion from Michelson value to the \
    \Haskell value can be done by serializing Michelson value using `tezos-client hash data` command, \
    \resulting `Raw packed data` should be decoded from the hexadecimal representation using `decodeHex` \
    \and deserialized to the Haskell value via `lUnpackValue` function from \
    \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\
    \* Construct values for this contract directly on Michelson level using types provided in the \
    \documentation."

-- | Attach information about git revision.
-- The code must contain git revision placeholder.
--
-- We do this in two stages because we use TH to deduce git revision information
-- at compile time, and this is best to be done in the very end to recompile
-- less modules.
attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a
attachGitInfo gitRev = finalizedAsIs ... modifyDoc $ \case
  DGitRevisionUnknown -> Just gitRev
  _ -> Nothing

attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a
attachToc toc = finalizedAsIs ... modifyDoc $ \case
  DToc "" -> Just toc
  _ -> Nothing

-- | Attach common information that is available only in the end.
attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a
attachDocCommons gitRev code = do
  let toc = DToc $ contractDocToToc (buildDocUnfinalized code)
  pure code
    >>= attachGitInfo gitRev
    >>= attachToc toc