{-# LANGUAGE DerivingStrategies, TypeFamilyDependencies, UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
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
class (Typeable d, DOrd d, KnownNat (DocItemPosition d)) => DocItem d where
type DocItemPosition d = (pos :: Nat) | pos -> d
docItemSectionName :: Maybe Text
docItemSectionDescription :: Maybe Markdown
docItemSectionDescription = Nothing
docItemSectionNameStyle :: DocSectionNameStyle
docItemSectionNameStyle = DocSectionNameBig
type DocItemPlacement d :: DocItemPlacementKind
type DocItemPlacement d = 'DocItemInlined
docItemRef :: d -> DocItemRef (DocItemPlacement d)
default docItemRef
:: (DocItemPlacement d ~ 'DocItemInlined)
=> d -> DocItemRef (DocItemPlacement d)
docItemRef _ = DocItemNoRef
docItemToMarkdown :: HeaderLevel -> d -> Markdown
docItemDependencies :: d -> [SomeDocDefinitionItem]
docItemDependencies _ = []
docItemsOrder :: [d] -> [d]
docItemsOrder = \case
[] -> []
docItems@(someDocItem : _) -> case docItemRef someDocItem of
DocItemNoRef -> docItems
DocItemRef _ -> docItemsOrderById docItems
docItemPosition :: forall d. DocItem d => DocItemPos
docItemPosition = DocItemPos $ natVal (Proxy @(DocItemPosition d))
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 -> ""
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
docDefinitionRef
:: (DocItem d, DocItemPlacement d ~ 'DocItemInDefinitions)
=> Markdown -> d -> Markdown
docDefinitionRef refText d = case docItemRef d of
DocItemRef (DocItemId docItemId) -> mdLocalRef refText docItemId
newtype DocItemId = DocItemId Text
deriving stock (Eq, Ord, Show)
newtype DocItemPos = DocItemPos Natural
deriving stock (Eq, Ord, Show)
deriving newtype (Buildable)
data DocItemPlacementKind
= DocItemInlined
| DocItemInDefinitions
data DocItemRef (p :: DocItemPlacementKind) where
DocItemRef :: DocItemId -> DocItemRef 'DocItemInDefinitions
DocItemNoRef :: DocItemRef 'DocItemInlined
data DocSectionNameStyle
= DocSectionNameBig
| DocSectionNameSmall
data SomeDocItem where
SomeDocItem :: DocItem d => d -> SomeDocItem
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
instance Show SomeDocItem where
show _ = "<doc item>"
type family DOrd d :: Constraint where
DOrd d = If (DocItemPlacement d == 'DocItemInDefinitions)
(Ord d) (() :: Constraint)
type DocBlock = Map DocItemPos (NonEmpty SomeDocItem)
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') ||+ ""
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)
newtype SubDoc = SubDoc DocBlock
subDocToMarkdown :: HeaderLevel -> SubDoc -> Markdown
subDocToMarkdown hl (SubDoc d) = docBlockToMarkdown hl d
data ContractDoc = ContractDoc
{ cdContents :: DocBlock
, cdDefinitions :: DocBlock
, cdDefinitionsSet :: Set SomeDocDefinitionItem
, cdDefinitionIds :: Set DocItemId
}
makeLensesWith postfixLFields ''ContractDoc
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
}
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"
type DocGrouping = SubDoc -> SomeDocItem
instance Show DocGrouping where
show _ = "<doc grouping>"
docGroupContent :: DocGrouping -> ContractDoc -> ContractDoc
docGroupContent grouping doc =
doc
{ cdContents = someDocItemToBlock . grouping $ SubDoc (cdContents doc)
}
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
data DDescription = DDescription Markdown
instance DocItem DDescription where
type DocItemPosition DDescription = 10
docItemSectionName = Nothing
docItemToMarkdown _ (DDescription txt) = build txt
data DVersion = DVersion Natural
instance DocItem DVersion where
type DocItemPosition DVersion = 3
docItemSectionName = Nothing
docItemToMarkdown _ (DVersion ver) =
mdSubsection "Version" (build ver)
data DGitRevision = DGitRevision
{ dgrRepoSettings :: GitRepoSettings
, dgrCommitSha :: Text
, dgrCommitDate :: Text
}
newtype GitRepoSettings = GitRepoSettings
{ grsMkGitRevision :: Text -> Text
}
morleyRepoSettings :: GitRepoSettings
morleyRepoSettings = GitRepoSettings $ \commit ->
"https://gitlab.com/morley-framework/morley/blob/" <> commit
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 <> ")"
]
]
data DComment = DComment Text
instance DocItem DComment where
type DocItemPosition DComment = 0
docItemSectionName = Nothing
docItemToMarkdown _ (DComment commentText) =
"<!---\n" +| commentText |+ "\n-->"