-- 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
  , lookupDocBlockSection
  , contractDocToMarkdown
  , contractDocToToc
  , docGroupContent
  , docDefinitionRef
  , mdTocFromRef

  , DGeneralInfoSection (..)
  , DName (..)
  , DDescription (..)
  , DGitRevision (..)
  , GitRepoSettings (..)
  , mkDGitRevision
  , morleyRepoSettings
  , DComment (..)
  , DAnchor (..)
  , DToc (..)
  ) where

import Control.Lens.Cons (_head)
import Data.Char (toLower)
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 = Maybe Markdown
forall a. Maybe a
Nothing

  -- | How to render section name.
  --
  -- Takes effect only if section name is set.
  docItemSectionNameStyle :: DocSectionNameStyle
  docItemSectionNameStyle = DocSectionNameStyle
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 _ = DocItemRef 'DocItemInlined 'False
DocItemRef (DocItemPlacement d) (DocItemReferenced d)
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 :: [d]
docItems@(someDocItem :: d
someDocItem : _) -> case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
someDocItem of
      DocItemNoRef -> [d]
docItems
      DocItemRef _ ->
        [d] -> [d]
forall d.
(DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions) =>
[d] -> [d]
docItemsOrderById [d]
docItems
      DocItemRefInlined _ ->
        [d]
docItems

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

-- | Get doc item position at term-level.
docItemPosition :: forall d. DocItem d => DocItemPos
docItemPosition :: DocItemPos
docItemPosition = (Natural, Text) -> DocItemPos
DocItemPos (DocItem d => Natural
forall d. DocItem d => Natural
docItemPos @d, TypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show (Proxy d -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d -> TypeRep) -> Proxy d -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy d
forall k (t :: k). Proxy t
Proxy @d))

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

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

-- | Make a reference to doc item in definitions.
docDefinitionRef
  :: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)
  => Markdown -> d -> Markdown
docDefinitionRef :: Markdown -> d -> Markdown
docDefinitionRef refText :: Markdown
refText d :: d
d = case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
d of
  DocItemRef docItemId :: DocItemId
docItemId -> Markdown -> DocItemId -> Markdown
forall anchor. ToAnchor anchor => Markdown -> anchor -> Markdown
mdLocalRef Markdown
refText DocItemId
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 (DocItemId -> DocItemId -> Bool
(DocItemId -> DocItemId -> Bool)
-> (DocItemId -> DocItemId -> Bool) -> Eq DocItemId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocItemId -> DocItemId -> Bool
$c/= :: DocItemId -> DocItemId -> Bool
== :: DocItemId -> DocItemId -> Bool
$c== :: DocItemId -> DocItemId -> Bool
Eq, Eq DocItemId
Eq DocItemId =>
(DocItemId -> DocItemId -> Ordering)
-> (DocItemId -> DocItemId -> Bool)
-> (DocItemId -> DocItemId -> Bool)
-> (DocItemId -> DocItemId -> Bool)
-> (DocItemId -> DocItemId -> Bool)
-> (DocItemId -> DocItemId -> DocItemId)
-> (DocItemId -> DocItemId -> DocItemId)
-> Ord DocItemId
DocItemId -> DocItemId -> Bool
DocItemId -> DocItemId -> Ordering
DocItemId -> DocItemId -> DocItemId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DocItemId -> DocItemId -> DocItemId
$cmin :: DocItemId -> DocItemId -> DocItemId
max :: DocItemId -> DocItemId -> DocItemId
$cmax :: DocItemId -> DocItemId -> DocItemId
>= :: DocItemId -> DocItemId -> Bool
$c>= :: DocItemId -> DocItemId -> Bool
> :: DocItemId -> DocItemId -> Bool
$c> :: DocItemId -> DocItemId -> Bool
<= :: DocItemId -> DocItemId -> Bool
$c<= :: DocItemId -> DocItemId -> Bool
< :: DocItemId -> DocItemId -> Bool
$c< :: DocItemId -> DocItemId -> Bool
compare :: DocItemId -> DocItemId -> Ordering
$ccompare :: DocItemId -> DocItemId -> Ordering
$cp1Ord :: Eq DocItemId
Ord, Int -> DocItemId -> ShowS
[DocItemId] -> ShowS
DocItemId -> String
(Int -> DocItemId -> ShowS)
-> (DocItemId -> String)
-> ([DocItemId] -> ShowS)
-> Show DocItemId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocItemId] -> ShowS
$cshowList :: [DocItemId] -> ShowS
show :: DocItemId -> String
$cshow :: DocItemId -> String
showsPrec :: Int -> DocItemId -> ShowS
$cshowsPrec :: Int -> DocItemId -> ShowS
Show)
  deriving newtype (DocItemId -> Anchor
(DocItemId -> Anchor) -> ToAnchor DocItemId
forall anchor. (anchor -> Anchor) -> ToAnchor anchor
toAnchor :: DocItemId -> Anchor
$ctoAnchor :: DocItemId -> Anchor
ToAnchor)

-- | Position of all doc items of some type.
newtype DocItemPos = DocItemPos (Natural, Text)
  deriving stock (DocItemPos -> DocItemPos -> Bool
(DocItemPos -> DocItemPos -> Bool)
-> (DocItemPos -> DocItemPos -> Bool) -> Eq DocItemPos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocItemPos -> DocItemPos -> Bool
$c/= :: DocItemPos -> DocItemPos -> Bool
== :: DocItemPos -> DocItemPos -> Bool
$c== :: DocItemPos -> DocItemPos -> Bool
Eq, Eq DocItemPos
Eq DocItemPos =>
(DocItemPos -> DocItemPos -> Ordering)
-> (DocItemPos -> DocItemPos -> Bool)
-> (DocItemPos -> DocItemPos -> Bool)
-> (DocItemPos -> DocItemPos -> Bool)
-> (DocItemPos -> DocItemPos -> Bool)
-> (DocItemPos -> DocItemPos -> DocItemPos)
-> (DocItemPos -> DocItemPos -> DocItemPos)
-> Ord DocItemPos
DocItemPos -> DocItemPos -> Bool
DocItemPos -> DocItemPos -> Ordering
DocItemPos -> DocItemPos -> DocItemPos
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DocItemPos -> DocItemPos -> DocItemPos
$cmin :: DocItemPos -> DocItemPos -> DocItemPos
max :: DocItemPos -> DocItemPos -> DocItemPos
$cmax :: DocItemPos -> DocItemPos -> DocItemPos
>= :: DocItemPos -> DocItemPos -> Bool
$c>= :: DocItemPos -> DocItemPos -> Bool
> :: DocItemPos -> DocItemPos -> Bool
$c> :: DocItemPos -> DocItemPos -> Bool
<= :: DocItemPos -> DocItemPos -> Bool
$c<= :: DocItemPos -> DocItemPos -> Bool
< :: DocItemPos -> DocItemPos -> Bool
$c< :: DocItemPos -> DocItemPos -> Bool
compare :: DocItemPos -> DocItemPos -> Ordering
$ccompare :: DocItemPos -> DocItemPos -> Ordering
$cp1Ord :: Eq DocItemPos
Ord, Int -> DocItemPos -> ShowS
[DocItemPos] -> ShowS
DocItemPos -> String
(Int -> DocItemPos -> ShowS)
-> (DocItemPos -> String)
-> ([DocItemPos] -> ShowS)
-> Show DocItemPos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocItemPos] -> ShowS
$cshowList :: [DocItemPos] -> ShowS
show :: DocItemPos -> String
$cshow :: DocItemPos -> String
showsPrec :: Int -> DocItemPos -> ShowS
$cshowsPrec :: Int -> DocItemPos -> ShowS
Show)

instance Buildable DocItemPos where
  build :: DocItemPos -> Markdown
build (DocItemPos (a :: Natural
a, _)) = Natural -> Markdown
forall p. Buildable p => p -> Markdown
build Natural
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 d 'True -> Anchor
toAnchor (DocItemRef ref :: DocItemId
ref) = DocItemId -> Anchor
forall anchor. ToAnchor anchor => anchor -> Anchor
toAnchor DocItemId
ref
  toAnchor (DocItemRefInlined ref :: DocItemId
ref) = DocItemId -> Anchor
forall anchor. ToAnchor anchor => anchor -> Anchor
toAnchor DocItemId
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 -> ()
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 :: d
d1 == :: SomeDocDefinitionItem -> SomeDocDefinitionItem -> Bool
== SomeDocDefinitionItem d2 :: d
d2 =
    d
d1 d -> d -> Bool
forall a1 a2. (Typeable a1, Typeable a2, Eq a1) => a1 -> a2 -> Bool
`eqExt` d
d2
instance Ord SomeDocDefinitionItem where
  SomeDocDefinitionItem d1 :: d
d1 compare :: SomeDocDefinitionItem -> SomeDocDefinitionItem -> Ordering
`compare` SomeDocDefinitionItem d2 :: d
d2 =
    d
d1 d -> d -> Ordering
forall a1 a2.
(Typeable a1, Typeable a2, Ord a1) =>
a1 -> a2 -> Ordering
`compareExt` d
d2

-- | To automatically derive @instance Show Michelson.Typed.Instr@ later.
instance Show SomeDocItem where
  show :: SomeDocItem -> String
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
  { DocElem d -> d
deItem :: d
    -- ^ Doc item itself.
  , DocElem d -> Maybe SubDoc
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 :: DocElem d -> Bool
deIsAtomic = Maybe SubDoc -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe SubDoc -> Bool)
-> (DocElem d -> Maybe SubDoc) -> DocElem d -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocElem d -> Maybe SubDoc
forall d. DocElem d -> Maybe SubDoc
deSub

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

instance Show DocSection where
  show :: DocSection -> String
show (DocSection (NonEmpty (DocElem d)
ds :: NonEmpty (DocElem d))) =
    "Doc items section: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall b a. (Show a, IsString b) => a -> b
show (Proxy d -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d -> TypeRep) -> Proxy d -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy d
forall k (t :: k). Proxy t
Proxy @d) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    " / " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (NonEmpty (DocElem d) -> Int
forall t. Container t => t -> Int
length NonEmpty (DocElem d)
ds) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " item(s)"

appendDocSectionUnsafe
  :: HasCallStack
  => DocSection -> DocSection -> DocSection
appendDocSectionUnsafe :: DocSection -> DocSection -> DocSection
appendDocSectionUnsafe (DocSection ls :: NonEmpty $ DocElem d
ls) (DocSection rs :: NonEmpty $ DocElem d
rs) =
  (NonEmpty $ DocElem d) -> DocSection
forall d. DocItem d => (NonEmpty $ DocElem d) -> DocSection
DocSection ((NonEmpty $ DocElem d) -> DocSection)
-> (NonEmpty $ DocElem d) -> DocSection
forall a b. (a -> b) -> a -> b
$ (NonEmpty $ DocElem d) -> [DocElem d] -> NonEmpty $ DocElem d
forall d1 d2.
(Typeable d1, Typeable d2, HasCallStack) =>
NonEmpty d1 -> [d2] -> NonEmpty d1
appendDocSectionUnsafeImpl NonEmpty $ DocElem d
ls ((NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
rs)

appendDocSectionUnsafeImpl
  :: forall d1 d2.
     (Typeable d1, Typeable d2, HasCallStack)
  => NonEmpty d1 -> [d2] -> NonEmpty d1
appendDocSectionUnsafeImpl :: NonEmpty d1 -> [d2] -> NonEmpty d1
appendDocSectionUnsafeImpl (l :: d1
l :| ls :: [d1]
ls) rs :: [d2]
rs =
  let rs' :: [d1]
rs' = [d2]
rs [d2] -> (d2 -> d1) -> [d1]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \r :: d2
r -> d2 -> Maybe d1
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast d2
r Maybe d1 -> d1 -> d1
forall a. Maybe a -> a -> a
?: d1
onTypeMismatch
  in d1
l d1 -> [d1] -> NonEmpty d1
forall a. a -> [a] -> NonEmpty a
:| [d1]
ls [d1] -> [d1] -> [d1]
forall a. Semigroup a => a -> a -> a
<> [d1]
rs'
  where
    onTypeMismatch :: d1
onTypeMismatch =
      Text -> d1
forall a. HasCallStack => Text -> a
error (Text -> d1) -> Text -> d1
forall a b. (a -> b) -> a -> b
$ "appending doc sections for doc items of different types:"
              Markdown -> Markdown -> Text
forall b. FromBuilder b => Markdown -> Markdown -> b
+|| Proxy d1 -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d1
forall k (t :: k). Proxy t
Proxy @d1) TypeRep -> Markdown -> Markdown
forall a b. (Show a, FromBuilder b) => a -> Markdown -> b
||+ " and " Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+|| Proxy d2 -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d2
forall k (t :: k). Proxy t
Proxy @d2) TypeRep -> Markdown -> Markdown
forall a b. (Show a, FromBuilder b) => a -> Markdown -> b
||+ ""

-- | 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 :: HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown hl :: HeaderLevel
hl block :: DocBlock
block =
  [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ DocBlock -> [DocSection]
forall k a. Map k a -> [a]
M.elems DocBlock
block [DocSection] -> (DocSection -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(DocSection items :: NonEmpty $ DocElem d
items@((DocElem d
_ :: DocElem di) :| _)) ->
    let sectionName :: Maybe Text
sectionName = DocItem d => Maybe Text
forall d. DocItem d => Maybe Text
docItemSectionName @di
        sectionNameStyle :: DocSectionNameStyle
sectionNameStyle = DocItem d => DocSectionNameStyle
forall d. DocItem d => DocSectionNameStyle
docItemSectionNameStyle @di
        (sectionNameFull :: Markdown
sectionNameFull, headerLevelDelta :: HeaderLevel -> HeaderLevel
headerLevelDelta) =
          case Maybe Text
sectionName of
            Nothing -> ("", HeaderLevel -> HeaderLevel
forall a. a -> a
id)
            Just sn :: Text
sn ->
              let sn' :: Markdown
sn' = Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
sn
              in case DocSectionNameStyle
sectionNameStyle of
                  DocSectionNameBig ->
                    (HeaderLevel -> Markdown -> Markdown
mdHeader HeaderLevel
hl Markdown
sn', HeaderLevel -> HeaderLevel
nextHeaderLevel)
                  DocSectionNameSmall ->
                    ( Markdown -> Markdown
mdSubsectionTitle Markdown
sn' Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "\n"
                    , Text -> HeaderLevel -> HeaderLevel
forall a. HasCallStack => Text -> a
error (Text -> HeaderLevel -> HeaderLevel)
-> Text -> HeaderLevel -> HeaderLevel
forall a b. (a -> b) -> a -> b
$ "Using headers is not allowed when section name is set small\n\
                              \Make sure docItemToMarkdown @" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall b a. (Show a, IsString b) => a -> b
show (Proxy d -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d -> TypeRep) -> Proxy d -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy d
forall k (t :: k). Proxy t
Proxy @di) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                              "does not use its 'header level' argument"
                    )
        sectionDesc :: Maybe Markdown
sectionDesc = DocItem d => Maybe Markdown
forall d. DocItem d => Maybe Markdown
docItemSectionDescription @di
        sectionDescFull :: Markdown
sectionDescFull =
          case Maybe Markdown
sectionDesc of
            Nothing -> ""
            Just sd :: Markdown
sd -> Markdown
sd Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "\n\n"
        resItems :: [d]
resItems = [d] -> [d]
forall d. DocItem d => [d] -> [d]
docItemsOrder ([d] -> [d]) -> [d] -> [d]
forall a b. (a -> b) -> a -> b
$ (DocElem d -> d) -> [DocElem d] -> [d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map DocElem d -> d
forall d. DocElem d -> d
deItem ((NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
items)
        content :: Markdown
content =
          [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ [d]
resItems [d] -> (d -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \di :: d
di ->
            HeaderLevel -> d -> Markdown
forall d. DocItem d => HeaderLevel -> d -> Markdown
docItemToMarkdownFull (HeaderLevel -> HeaderLevel
headerLevelDelta HeaderLevel
hl) d
di
    in if [d] -> Bool
forall t. Container t => t -> Bool
null [d]
resItems
       then ""
       else Markdown
sectionNameFull Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
sectionDescFull Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
content

-- | Render a part of table of contents from 'DocBlock'.
docBlockToToc :: HeaderLevel -> DocBlock -> Markdown
docBlockToToc :: HeaderLevel -> DocBlock -> Markdown
docBlockToToc hl :: HeaderLevel
hl block :: DocBlock
block =
  [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ DocBlock -> [DocSection]
forall k a. Map k a -> [a]
M.elems DocBlock
block [DocSection] -> (DocSection -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(DocSection items :: NonEmpty $ DocElem d
items@((DocElem d
_ :: DocElem di) :| _)) ->
    let sectionName :: Maybe Text
sectionName = DocItem d => Maybe Text
forall d. DocItem d => Maybe Text
docItemSectionName @di
        (sectionNameFull :: Markdown
sectionNameFull, headerLevelDelta :: HeaderLevel -> HeaderLevel
headerLevelDelta) =
          case Maybe Text
sectionName of
            Nothing -> ("", HeaderLevel -> HeaderLevel
forall a. a -> a
id)
            Just "Table of contents" -> ("", HeaderLevel -> HeaderLevel
forall a. a -> a
id)
            Just sn :: Text
sn ->
              (HeaderLevel -> Markdown -> Text -> Markdown
forall anchor.
ToAnchor anchor =>
HeaderLevel -> Markdown -> anchor -> Markdown
mdToc HeaderLevel
hl (Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
sn) (ASetter Text Text Char Char -> (Char -> Char) -> Text -> Text
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Text Text Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
sn), HeaderLevel -> HeaderLevel
nextHeaderLevel)
        resItems :: [d]
resItems = [d] -> [d]
forall d. DocItem d => [d] -> [d]
docItemsOrder ([d] -> [d]) -> [d] -> [d]
forall a b. (a -> b) -> a -> b
$ (DocElem d -> d) -> [DocElem d] -> [d]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map DocElem d -> d
forall d. DocElem d -> d
deItem ((NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
items)
        content :: Markdown
content =
          [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat ([Markdown] -> Markdown) -> [Markdown] -> Markdown
forall a b. (a -> b) -> a -> b
$ [d]
resItems [d] -> (d -> Markdown) -> [Markdown]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> HeaderLevel -> d -> Markdown
forall d. DocItem d => HeaderLevel -> d -> Markdown
docItemToToc (HeaderLevel -> HeaderLevel
headerLevelDelta HeaderLevel
hl)
    in if [d] -> Bool
forall t. Container t => t -> Bool
null [d]
resItems
       then ""
       else Markdown
sectionNameFull Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
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 -> Maybe SubDoc -> DocBlock
docItemToBlockGeneral di :: di
di msub :: Maybe SubDoc
msub =
  OneItem DocBlock -> DocBlock
forall x. One x => OneItem x -> x
one ( DocItem di => DocItemPos
forall d. DocItem d => DocItemPos
docItemPosition @di
      , (NonEmpty $ DocElem di) -> DocSection
forall d. DocItem d => (NonEmpty $ DocElem d) -> DocSection
DocSection ((NonEmpty $ DocElem di) -> DocSection)
-> (NonEmpty $ DocElem di) -> DocSection
forall a b. (a -> b) -> a -> b
$ OneItem (NonEmpty $ DocElem di) -> NonEmpty $ DocElem di
forall x. One x => OneItem x -> x
one (di -> Maybe SubDoc -> DocElem di
forall d. d -> Maybe SubDoc -> DocElem d
DocElem di
di Maybe SubDoc
msub)
      )

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

-- | Find all doc items of the given type.
lookupDocBlockSection :: forall d. DocItem d => DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection :: DocBlock -> Maybe (NonEmpty d)
lookupDocBlockSection block :: DocBlock
block = do
  DocSection (NonEmpty (DocElem d)
ds :: NonEmpty (DocElem d')) <- DocItemPos -> DocBlock -> Maybe DocSection
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (DocItem d => DocItemPos
forall d. DocItem d => DocItemPos
docItemPosition @d) DocBlock
block
  case (Typeable d, Typeable d) => Maybe (d :~: d)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @d @d' of
    Nothing -> Text -> Maybe (NonEmpty d)
forall a. HasCallStack => Text -> a
error (Text -> Maybe (NonEmpty d)) -> Text -> Maybe (NonEmpty d)
forall a b. (a -> b) -> a -> b
$ "Invalid DocBlock: item of type " Markdown -> Markdown -> Text
forall b. FromBuilder b => Markdown -> Markdown -> b
+|| Proxy d -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy d
forall k (t :: k). Proxy t
Proxy @d) TypeRep -> Markdown -> Markdown
forall a b. (Show a, FromBuilder b) => a -> Markdown -> b
||+ " \
                       \under position " Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| DocItem d => DocItemPos
forall d. DocItem d => DocItemPos
docItemPosition @d DocItemPos -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ ""
    Just Refl -> NonEmpty d -> Maybe (NonEmpty d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty d -> Maybe (NonEmpty d))
-> NonEmpty d -> Maybe (NonEmpty d)
forall a b. (a -> b) -> a -> b
$ (DocElem d -> d) -> NonEmpty (DocElem d) -> NonEmpty d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map DocElem d -> d
forall d. DocElem d -> d
deItem NonEmpty (DocElem d)
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 :: HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown hl :: HeaderLevel
hl (SubDoc d :: DocBlock
d) = HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown HeaderLevel
hl DocBlock
d

-- | Render documentation for 'SubDoc'.
subDocToToc :: HeaderLevel -> SubDoc -> Markdown
subDocToToc :: HeaderLevel -> SubDoc -> Markdown
subDocToToc hl :: HeaderLevel
hl (SubDoc d :: DocBlock
d) = HeaderLevel -> DocBlock -> Markdown
docBlockToToc HeaderLevel
hl DocBlock
d

-- | Keeps documentation gathered for some piece of contract code.
--
-- Used for building documentation of a contract.
data ContractDoc = ContractDoc
  { ContractDoc -> DocBlock
cdContents :: DocBlock
    -- ^ All inlined doc items.
  , ContractDoc -> DocBlock
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.
  , ContractDoc -> Set SomeDocDefinitionItem
cdDefinitionsSet :: Set SomeDocDefinitionItem
    -- ^ We remember all already declared entries to avoid cyclic dependencies
    -- in documentation items discovery.
  , ContractDoc -> Set DocItemId
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 :: ContractDoc
cd1 <> :: ContractDoc -> ContractDoc -> ContractDoc
<> cd2 :: ContractDoc
cd2 = $WContractDoc :: DocBlock
-> DocBlock
-> Set SomeDocDefinitionItem
-> Set DocItemId
-> ContractDoc
ContractDoc
    { cdContents :: DocBlock
cdContents =
        SimpleWhenMissing DocItemPos DocSection DocSection
-> SimpleWhenMissing DocItemPos DocSection DocSection
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
-> DocBlock
-> DocBlock
-> DocBlock
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
M.merge
          SimpleWhenMissing DocItemPos DocSection DocSection
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing SimpleWhenMissing DocItemPos DocSection DocSection
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
          ((DocItemPos -> DocSection -> DocSection -> DocSection)
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
M.zipWithMatched ((DocItemPos -> DocSection -> DocSection -> DocSection)
 -> SimpleWhenMatched DocItemPos DocSection DocSection DocSection)
-> (DocItemPos -> DocSection -> DocSection -> DocSection)
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
forall a b. (a -> b) -> a -> b
$ \_k :: DocItemPos
_k l :: DocSection
l r :: DocSection
r -> HasCallStack => DocSection -> DocSection -> DocSection
DocSection -> DocSection -> DocSection
appendDocSectionUnsafe DocSection
l DocSection
r)
          (ContractDoc -> DocBlock
cdContents ContractDoc
cd1) (ContractDoc -> DocBlock
cdContents ContractDoc
cd2)
    , cdDefinitions :: DocBlock
cdDefinitions =
        SimpleWhenMissing DocItemPos DocSection DocSection
-> SimpleWhenMissing DocItemPos DocSection DocSection
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
-> DocBlock
-> DocBlock
-> DocBlock
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
M.merge
          SimpleWhenMissing DocItemPos DocSection DocSection
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing SimpleWhenMissing DocItemPos DocSection DocSection
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
M.preserveMissing
          ((DocItemPos -> DocSection -> DocSection -> DocSection)
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
M.zipWithMatched ((DocItemPos -> DocSection -> DocSection -> DocSection)
 -> SimpleWhenMatched DocItemPos DocSection DocSection DocSection)
-> (DocItemPos -> DocSection -> DocSection -> DocSection)
-> SimpleWhenMatched DocItemPos DocSection DocSection DocSection
forall a b. (a -> b) -> a -> b
$ \_k :: DocItemPos
_k (DocSection ls :: NonEmpty $ DocElem d
ls) (DocSection rs) ->
             let removeDups :: [DocElem d] -> [DocElem d]
removeDups = (DocElem d -> Bool) -> [DocElem d] -> [DocElem d]
forall a. (a -> Bool) -> [a] -> [a]
filter ((DocElem d -> Bool) -> [DocElem d] -> [DocElem d])
-> (DocElem d -> Bool) -> [DocElem d] -> [DocElem d]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (DocElem d -> Bool) -> DocElem d -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (d -> Set DocItemId -> Bool
forall d. DocItem d => d -> Set DocItemId -> Bool
`isDefinedIn` ContractDoc -> Set DocItemId
cdDefinitionIds ContractDoc
cd1) (d -> Bool) -> (DocElem d -> d) -> DocElem d -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocElem d -> d
forall d. DocElem d -> d
deItem
             in (NonEmpty $ DocElem d) -> DocSection
forall d. DocItem d => (NonEmpty $ DocElem d) -> DocSection
DocSection ((NonEmpty $ DocElem d) -> DocSection)
-> (NonEmpty $ DocElem d) -> DocSection
forall a b. (a -> b) -> a -> b
$ (NonEmpty $ DocElem d) -> [DocElem d] -> NonEmpty $ DocElem d
forall d1 d2.
(Typeable d1, Typeable d2, HasCallStack) =>
NonEmpty d1 -> [d2] -> NonEmpty d1
appendDocSectionUnsafeImpl NonEmpty $ DocElem d
ls ([DocElem d] -> [DocElem d]
removeDups ([DocElem d] -> [DocElem d]) -> [DocElem d] -> [DocElem d]
forall a b. (a -> b) -> a -> b
$ (NonEmpty $ DocElem d) -> [Element (NonEmpty $ DocElem d)]
forall t. Container t => t -> [Element t]
toList NonEmpty $ DocElem d
rs)
          )
          (ContractDoc -> DocBlock
cdDefinitions ContractDoc
cd1) (ContractDoc -> DocBlock
cdDefinitions ContractDoc
cd2)
    , cdDefinitionsSet :: Set SomeDocDefinitionItem
cdDefinitionsSet =
        Set SomeDocDefinitionItem
-> Set SomeDocDefinitionItem -> Set SomeDocDefinitionItem
forall a. Ord a => Set a -> Set a -> Set a
S.union (ContractDoc -> Set SomeDocDefinitionItem
cdDefinitionsSet ContractDoc
cd1) (ContractDoc -> Set SomeDocDefinitionItem
cdDefinitionsSet ContractDoc
cd2)
    , cdDefinitionIds :: Set DocItemId
cdDefinitionIds =
        Set DocItemId -> Set DocItemId -> Set DocItemId
forall a. Ord a => Set a -> Set a -> Set a
S.union (ContractDoc -> Set DocItemId
cdDefinitionIds ContractDoc
cd1) (ContractDoc -> Set DocItemId
cdDefinitionIds ContractDoc
cd2)
    }
    where
      isDefinedIn :: DocItem d => d -> Set DocItemId -> Bool
      isDefinedIn :: d -> Set DocItemId -> Bool
isDefinedIn di :: d
di defs :: Set DocItemId
defs =
        case d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
forall d.
DocItem d =>
d -> DocItemRef (DocItemPlacement d) (DocItemReferenced d)
docItemRef d
di of
          DocItemNoRef -> Bool
False
          DocItemRef docItemId :: DocItemId
docItemId -> DocItemId
docItemId DocItemId -> Set DocItemId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set DocItemId
defs
          DocItemRefInlined docItemId :: DocItemId
docItemId -> DocItemId
docItemId DocItemId -> Set DocItemId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set DocItemId
defs

instance Monoid ContractDoc where
  mempty :: ContractDoc
mempty = $WContractDoc :: DocBlock
-> DocBlock
-> Set SomeDocDefinitionItem
-> Set DocItemId
-> ContractDoc
ContractDoc
    { cdContents :: DocBlock
cdContents = DocBlock
forall k a. Map k a
M.empty
    , cdDefinitions :: DocBlock
cdDefinitions = DocBlock
forall k a. Map k a
M.empty
    , cdDefinitionsSet :: Set SomeDocDefinitionItem
cdDefinitionsSet = Set SomeDocDefinitionItem
forall a. Set a
S.empty
    , cdDefinitionIds :: Set DocItemId
cdDefinitionIds = Set DocItemId
forall a. Set a
S.empty
    }

-- | Render given contract documentation to markdown document.
contractDocToMarkdown :: ContractDoc -> LText
contractDocToMarkdown :: ContractDoc -> LText
contractDocToMarkdown ContractDoc{..} =
  let
    contents :: Markdown
contents =
      HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown (Int -> HeaderLevel
HeaderLevel 1) DocBlock
cdContents Markdown -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "\n\n"
    definitions :: Markdown
definitions
      | DocBlock -> Bool
forall t. Container t => t -> Bool
null DocBlock
cdDefinitions = ""
      | Bool
otherwise =
        "# Definitions\n\n" Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| HeaderLevel -> DocBlock -> Markdown
docBlockToMarkdown (Int -> HeaderLevel
HeaderLevel 2) DocBlock
cdDefinitions
    total :: LText
total = Markdown -> LText
forall b. FromBuilder b => Markdown -> b
fmt (Markdown
contents Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
definitions)
  in LText -> LText
LT.strip LText
total LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> "\n"

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

    definitions :: Markdown
definitions
      | DocBlock -> Bool
forall t. Container t => t -> Bool
null DocBlock
cdDefinitions = ""
      | Bool
otherwise = "\n**[Definitions](#definitions)**\n\n"
          Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| HeaderLevel -> DocBlock -> Markdown
docBlockToToc (Int -> HeaderLevel
HeaderLevel 2) DocBlock
cdDefinitions
  in Markdown
contents Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Markdown
definitions Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> "\n"

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

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

-- | Apply given grouping to documentation being built.
docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc
docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc
docGroupContent grouping :: DocGrouping
grouping doc :: ContractDoc
doc =
  ContractDoc
doc
  { cdContents :: DocBlock
cdContents =
      let sub :: SubDoc
sub = DocBlock -> SubDoc
SubDoc (ContractDoc -> DocBlock
cdContents ContractDoc
doc)
      in case DocGrouping
grouping SubDoc
sub of
           SomeDocItem d :: d
d -> d -> Maybe SubDoc -> DocBlock
forall di. DocItem di => di -> Maybe SubDoc -> DocBlock
docItemToBlockGeneral d
d (SubDoc -> Maybe SubDoc
forall a. a -> Maybe a
Just SubDoc
sub)
  }

----------------------------------------------------------------------------
-- 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 :: Natural
docItemPos = 1
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DGeneralInfoSection -> Markdown
docItemToMarkdown lvl :: HeaderLevel
lvl (DGeneralInfoSection subDoc :: SubDoc
subDoc) =
    HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown HeaderLevel
lvl SubDoc
subDoc
  docItemToToc :: HeaderLevel -> DGeneralInfoSection -> Markdown
docItemToToc lvl :: HeaderLevel
lvl (DGeneralInfoSection subDoc :: SubDoc
subDoc) =
    HeaderLevel -> SubDoc -> Markdown
subDocToToc HeaderLevel
lvl SubDoc
subDoc

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

instance DocItem DName where
  docItemPos :: Natural
docItemPos = 3
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DName -> Markdown
docItemToMarkdown lvl :: HeaderLevel
lvl (DName name :: Text
name doc :: SubDoc
doc) =
    HeaderLevel -> Markdown -> Markdown
mdHeader HeaderLevel
lvl (Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
name) Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<>
    HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown (HeaderLevel -> HeaderLevel
nextHeaderLevel HeaderLevel
lvl) SubDoc
doc
  docItemToToc :: HeaderLevel -> DName -> Markdown
docItemToToc lvl :: HeaderLevel
lvl (DName _ doc :: SubDoc
doc) =
    HeaderLevel -> SubDoc -> Markdown
subDocToToc (HeaderLevel -> HeaderLevel
nextHeaderLevel HeaderLevel
lvl) SubDoc
doc

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

instance DocItem DDescription where
  docItemPos :: Natural
docItemPos = 10
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DDescription -> Markdown
docItemToMarkdown _ (DDescription txt :: Markdown
txt) = Markdown -> Markdown
forall p. Buildable p => p -> Markdown
build Markdown
txt

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

data DGitRevision
  = DGitRevisionKnown DGitRevisionInfo
  | DGitRevisionUnknown

-- | Repository settings for 'DGitRevision'.
newtype GitRepoSettings = GitRepoSettings
  { GitRepoSettings -> Text -> Text
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
morleyRepoSettings = (Text -> Text) -> GitRepoSettings
GitRepoSettings ((Text -> Text) -> GitRepoSettings)
-> (Text -> Text) -> GitRepoSettings
forall a b. (a -> b) -> a -> b
$ \commit :: Text
commit ->
  "https://gitlab.com/morley-framework/morley/-/tree/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
commit

-- | Make 'DGitRevision'.
--
-- >>> :t $mkDGitRevision
-- GitRepoSettings -> DGitRevision
mkDGitRevision :: TH.ExpQ
mkDGitRevision :: 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 :: ExpQ -> String -> ExpQ
pickInfo a :: ExpQ
a b :: String
b = Maybe String -> ExpQ
forall t. Lift t => t -> ExpQ
TH.lift (Maybe String -> ExpQ) -> Q (Maybe String) -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExpQ -> String -> Q (Maybe String)
pickInfo' ExpQ
a String
b

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

instance DocItem DGitRevision where
  docItemPos :: Natural
docItemPos = 2
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DGitRevision -> Markdown
docItemToMarkdown _ (DGitRevisionKnown DGitRevisionInfo{..}) =
    [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
    [ Markdown -> Markdown -> Markdown
mdSubsection "Code revision" (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$
        let link :: Text
link = GitRepoSettings -> Text -> Text
grsMkGitRevision GitRepoSettings
dgrRepoSettings Text
dgrCommitSha
        in [Markdown] -> Markdown
forall a. Monoid a => [a] -> a
mconcat
           [ Markdown -> Markdown -> Markdown
mdRef (Text -> Markdown
forall p. Buildable p => p -> Markdown
build (Text -> Markdown) -> Text -> Markdown
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take 7 Text
dgrCommitSha) (Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
link)
           , " "
           , Markdown -> Markdown
mdItalic (Markdown -> Markdown) -> Markdown -> Markdown
forall a b. (a -> b) -> a -> b
$ "(" Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> Text -> Markdown
forall p. Buildable p => p -> Markdown
build Text
dgrCommitDate Markdown -> Markdown -> Markdown
forall a. Semigroup a => a -> a -> a
<> ")"
           ]
    ]
  docItemToMarkdown _ DGitRevisionUnknown = ""

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

instance DocItem DComment where
  docItemPos :: Natural
docItemPos = 0
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DComment -> Markdown
docItemToMarkdown _ (DComment commentText :: Text
commentText) =
    "<!---\n" Markdown -> Markdown -> Markdown
forall b. FromBuilder b => Markdown -> Markdown -> b
+| Text
commentText Text -> Markdown -> Markdown
forall a b. (Buildable a, FromBuilder b) => a -> Markdown -> b
|+ "\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 :: Natural
docItemPos = 11
  docItemSectionName :: Maybe Text
docItemSectionName = Text -> Maybe Text
forall a. a -> Maybe a
Just "Table of contents"
  docItemToMarkdown :: HeaderLevel -> DToc -> Markdown
docItemToMarkdown _ (DToc toc :: Markdown
toc) = Markdown
toc

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

instance DocItem DAnchor where
  docItemPos :: Natural
docItemPos = 4
  docItemSectionName :: Maybe Text
docItemSectionName = Maybe Text
forall a. Maybe a
Nothing
  docItemToMarkdown :: HeaderLevel -> DAnchor -> Markdown
docItemToMarkdown _ (DAnchor a :: Anchor
a) = Anchor -> Markdown
forall anchor. ToAnchor anchor => anchor -> Markdown
mdAnchor Anchor
a