{-# LANGUAGE TypeFamilyDependencies, UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Michelson.Doc
( DocItem (..)
, docItemPosition
, DocItemId (..)
, DocItemPlacementKind (..)
, DocItemRef (..)
, DocSectionNameStyle (..)
, SomeDocItem (..)
, SomeDocDefinitionItem (..)
, DocElem (..)
, DocSection (..)
, DocBlock
, SubDoc (..)
, ContractDoc (..)
, DocGrouping
, cdContentsL
, cdDefinitionsL
, cdDefinitionsSetL
, cdDefinitionIdsL
, deIsAtomic
, subDocToMarkdown
, docItemToBlock
, lookupDocBlockSection
, contractDocToMarkdown
, docGroupContent
, docDefinitionRef
, DName (..)
, DDescription (..)
, 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 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
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)
data DocElem d = DocElem
{ deItem :: d
, deSub :: Maybe SubDoc
}
deIsAtomic :: DocElem d -> Bool
deIsAtomic = isNothing . deSub
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) ||+ ""
type DocBlock = Map DocItemPos DocSection
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"
content =
mconcat $ docItemsOrder (map deItem $ toList items) <&> \di ->
docItemToMarkdownFull (headerLevelDelta hl) di
in sectionNameFull <> sectionDescFull <> content
docItemToBlockGeneral :: forall di. DocItem di => di -> Maybe SubDoc -> DocBlock
docItemToBlockGeneral di msub =
one ( docItemPosition @di
, DocSection $ one (DocElem di msub)
)
docItemToBlock :: forall di. DocItem di => di -> DocBlock
docItemToBlock di = docItemToBlockGeneral di Nothing
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
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 -> 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
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 =
let sub = SubDoc (cdContents doc)
in case grouping sub of
SomeDocItem d -> docItemToBlockGeneral d (Just sub)
}
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 DGitRevisionInfo = DGitRevisionInfo
{ dgrRepoSettings :: GitRepoSettings
, dgrCommitSha :: Text
, dgrCommitDate :: Text
}
data DGitRevision
= DGitRevisionKnown DGitRevisionInfo
| DGitRevisionUnknown
newtype GitRepoSettings = GitRepoSettings
{ grsMkGitRevision :: Text -> Text
}
morleyRepoSettings :: GitRepoSettings
morleyRepoSettings = GitRepoSettings $ \commit ->
"https://gitlab.com/morley-framework/morley/blob/" <> commit
mkDGitRevision :: TH.ExpQ
mkDGitRevision = [e| \dgrRepoSettings ->
maybe DGitRevisionUnknown DGitRevisionKnown $
$(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
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
type DocItemPosition DGitRevision = 7
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 = ""
data DComment = DComment Text
instance DocItem DComment where
type DocItemPosition DComment = 0
docItemSectionName = Nothing
docItemToMarkdown _ (DComment commentText) =
"<!---\n" +| commentText |+ "\n-->"