digital-asset/daml
1
1
Fork 0
mirror of https://github.com/digital-asset/daml.git synced 2024-09-20 09:17:43 +03:00
Code Issues Projects Releases Wiki Activity

damldoc: Derive missing type signatures and add links in type signatures. (#2132)

Browse Source 
* Use type information in function docs

* idpToText -> packRdrName

* Use tycon to get superclasses

* Make anchors from tycons

* Generate all type anchors with tyConAnchor

* Type information is everywhere

* Render links.

* s/missing/available/

* Update golden tests

* Hlint / refactor

* Clean up import list

* Banish evil

* Catch lint

* Use mapMaybe

* Use list comprehensions instead

* packModule -> getModulename, dc_mod -> dc_modname

* Deal with tuple constructors properly

* Update the test case

* Better docs in Rst renderer

* Add test that uses type sig links

* Update release notes
This commit is contained in:
Fran 2019-07-15 12:06:01 +01:00 committed by mergify[bot]
parent a85fee85b3
commit e30955963b
11 changed files with 481 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs
View File

@ -72,7 +72,7 @@ damlDocDriver cInputFormat ideOpts output cFormat prefixFile options files = do
case cFormat of
Json -> write output $ T.decodeUtf8 . BS.toStrict $ AP.encodePretty' jsonConf docData
Rst -> write output $ T.concat $ map renderSimpleRst docData
Rst -> write output $ renderFinish $ mconcat $ map renderSimpleRst docData
Hoogle -> write output $ T.concat $ map renderSimpleHoogle docData
Markdown -> write output $ T.concat $ map renderSimpleMD docData
Html -> sequence_

306
compiler/damlc/daml-doc/src/DA/Daml/Doc/HaddockParse.hs
View File

@ -18,6 +18,13 @@ import Development.IDE.Types.Logger
import Development.IDE.Types.Location
import "ghc-lib" GHC
import "ghc-lib-parser" TyCoRep
import "ghc-lib-parser" TyCon
import "ghc-lib-parser" ConLike
import "ghc-lib-parser" DataCon
import "ghc-lib-parser" Id
import "ghc-lib-parser" Name
import "ghc-lib-parser" RdrName
import qualified "ghc-lib-parser" Outputable as Out
import qualified "ghc-lib-parser" DynFlags as DF
import "ghc-lib-parser" Bag (bagToList)
@ -59,8 +66,8 @@ mkDocs opts fp = do
= MS.elems . MS.withoutKeys typeMap . Set.unions
$ dc_templates : MS.elems dc_choices
in ModuleDoc
{ md_anchor = Just (moduleAnchor dc_mod)
, md_name = dc_mod
{ md_anchor = Just (moduleAnchor dc_modname)
, md_name = dc_modname
, md_descr = modDoc dc_tcmod
, md_adts = adtDocs
, md_templates = tmplDocs
@ -120,9 +127,14 @@ collectDocs = go Nothing []
-- | Context in which to extract a module's docs. This is created from
-- 'TypecheckedModule' by 'buildDocCtx'.
data DocCtx = DocCtx
{ dc_mod :: Modulename
{ dc_modname :: Modulename
, dc_tcmod :: TypecheckedModule
, dc_decls :: [DeclData]
, dc_tycons :: MS.Map Typename TyCon
, dc_datacons :: MS.Map Typename DataCon
, dc_ids :: MS.Map Fieldname Id
, dc_templates :: Set.Set Typename
, dc_choices :: MS.Map Typename (Set.Set Typename)
-- ^ choices per template
@ -136,15 +148,33 @@ data DeclData = DeclData
buildDocCtx :: TypecheckedModule -> DocCtx
buildDocCtx dc_tcmod =
let dc_mod
= Modulename . T.pack . moduleNameString . moduleName
. ms_mod . pm_mod_summary . tm_parsed_module $ dc_tcmod
let dc_modname = getModulename . ms_mod . pm_mod_summary . tm_parsed_module $ dc_tcmod
dc_decls
= map (uncurry DeclData) . collectDocs . hsmodDecls . unLoc
. pm_parsed_source . tm_parsed_module $ dc_tcmod
(dc_templates, dc_choices)
= getTemplateData . tm_parsed_module $ dc_tcmod
tythings = modInfoTyThings . tm_checked_module_info $ dc_tcmod
dc_tycons = MS.fromList
[ (typename, tycon)
| ATyCon tycon <- tythings
, let typename = Typename . packName . tyConName $ tycon
]
dc_datacons = MS.fromList
[ (conname, datacon)
| AConLike (RealDataCon datacon) <- tythings
, let conname = Typename . packName . dataConName $ datacon
]
dc_ids = MS.fromList
[ (fieldname, id)
| AnId id <- tythings
, let fieldname = Fieldname . packId $ id
]
in DocCtx {..}
-- | Parse and typecheck a module and its dependencies in Haddock mode
@ -183,35 +213,42 @@ toDocText docs =
-- neither a comment nor a function type is in the source, we omit the
-- function.
getFctDocs :: DocCtx -> DeclData -> Maybe FunctionDoc
getFctDocs DocCtx{..} (DeclData decl docs) = do
(name, mbType) <- case unLoc decl of
SigD _ (TypeSig _ (L _ n :_) t) ->
Just (n, Just . hsib_body . hswc_body $ t)
SigD _ (ClassOpSig _ _ (L _ n :_) t) ->
Just (n, Just . hsib_body $ t)
getFctDocs ctx@DocCtx{..} (DeclData decl docs) = do
(name, keepContext) <- case unLoc decl of
SigD _ (TypeSig _ (L _ n :_) _) ->
Just (n, True)
SigD _ (ClassOpSig _ _ (L _ n :_) _) ->
Just (n, False)
ValD _ FunBind{..} | not (null docs) ->
Just (unLoc fun_id, Nothing)
Just (unLoc fun_id, True)
-- NB assuming we do _not_ have a type signature for the function in the
-- pairs (otherwise we'll get a duplicate)
_ ->
Nothing
let fct_name = Fieldname (idpToText name)
fct_context = hsTypeToContext =<< mbType
fct_type = fmap hsTypeToType mbType
fct_anchor = Just $ functionAnchor dc_mod fct_name
let fct_name = Fieldname (packRdrName name)
mbId = MS.lookup fct_name dc_ids
mbType = idType <$> mbId
fct_context = guard keepContext >> mbType >>= typeToContext ctx
fct_type = typeToType ctx <$> mbType
fct_anchor = Just $ functionAnchor dc_modname fct_name
fct_descr = docs
Just FunctionDoc {..}
getClsDocs :: DocCtx -> DeclData -> Maybe ClassDoc
getClsDocs ctx@DocCtx{..} (DeclData (L _ (TyClD _ c@ClassDecl{..})) docs) = do
let cl_name = Typename . idpToText $ unLoc tcdLName
let cl_name = Typename . packRdrName $ unLoc tcdLName
tyconMb = MS.lookup cl_name dc_tycons
cl_anchor = tyConAnchor ctx =<< tyconMb
cl_descr = docs
cl_super = case unLoc tcdCtxt of
[] -> Nothing
xs -> Just $ TypeTuple $ map hsTypeToType xs
cl_functions = concatMap f tcdSigs
cl_args = map (tyVarText . unLoc) $ hsq_explicit tcdTyVars
cl_anchor = Just $ classAnchor dc_mod cl_name
cl_super = do
tycon <- tyconMb
cls <- tyConClass_maybe tycon
let theta = classSCTheta cls
guard (notNull theta)
Just (TypeTuple $ map (typeToType ctx) theta)
Just ClassDoc {..}
where
f :: LSig GhcPs -> [FunctionDoc]
@ -224,7 +261,7 @@ getClsDocs ctx@DocCtx{..} (DeclData (L _ (TyClD _ c@ClassDecl{..})) docs) = do
getClsDocs _ _ = Nothing
getTypeDocs :: DocCtx -> DeclData -> Maybe (Typename, ADTDoc)
getTypeDocs DocCtx{..} (DeclData (L _ (TyClD _ decl)) doc)
getTypeDocs ctx@DocCtx{..} (DeclData (L _ (TyClD _ decl)) doc)
| XTyClDecl{} <- decl =
Nothing
| ClassDecl{} <- decl =
@ -232,52 +269,47 @@ getTypeDocs DocCtx{..} (DeclData (L _ (TyClD _ decl)) doc)
| FamDecl{} <- decl =
Nothing
| SynDecl{..} <- decl =
let name = typenameFromRdrName $ unLoc tcdLName
in Just . (name,) $ TypeSynDoc
{ ad_anchor = Just $ typeAnchor dc_mod name
, ad_name = name
, ad_descr = doc
, ad_args = map (tyVarText . unLoc) $ hsq_explicit tcdTyVars
, ad_rhs = hsTypeToType tcdRhs
}
| SynDecl{..} <- decl = do
let ad_name = Typename . packRdrName $ unLoc tcdLName
ad_descr = doc
ad_args = map (tyVarText . unLoc) $ hsq_explicit tcdTyVars
tycon <- MS.lookup ad_name dc_tycons
ad_rhs <- typeToType ctx <$> synTyConRhs_maybe tycon
let ad_anchor = tyConAnchor ctx tycon
Just (ad_name, TypeSynDoc {..})
| DataDecl{..} <- decl =
let name = typenameFromRdrName $ unLoc tcdLName
in Just . (name,) $ ADTDoc
{ ad_anchor = Just $ typeAnchor dc_mod name
, ad_name = name
, ad_args = map (tyVarText . unLoc) $ hsq_explicit tcdTyVars
, ad_descr = doc
, ad_constrs = map constrDoc . dd_cons $ tcdDataDefn
}
| DataDecl{..} <- decl = do
let ad_name = Typename . packRdrName $ unLoc tcdLName
ad_descr = doc
ad_args = map (tyVarText . unLoc) $ hsq_explicit tcdTyVars
tycon <- MS.lookup ad_name dc_tycons
let ad_anchor = tyConAnchor ctx tycon
ad_constrs = mapMaybe constrDoc . dd_cons $ tcdDataDefn
Just (ad_name, ADTDoc {..})
where
constrDoc :: LConDecl GhcPs -> ADTConstr
constrDoc (L _ con) =
let ac_name = Typename . idpToText . unLoc $ con_name con
ac_anchor = Just $ constrAnchor dc_mod ac_name
constrDoc :: LConDecl GhcPs -> Maybe ADTConstr
constrDoc (L _ con) = do
let ac_name = Typename . packRdrName . unLoc $ con_name con
ac_anchor = Just $ constrAnchor dc_modname ac_name
ac_descr = fmap (docToText . unLoc) $ con_doc con
in case con_args con of
PrefixCon args ->
let ac_args = map hsTypeToType args
in PrefixC {..}
InfixCon l r ->
let ac_args = map hsTypeToType [l, r]
in PrefixC {..}
datacon <- MS.lookup ac_name dc_datacons
let ac_args = map (typeToType ctx) (dataConOrigArgTys datacon)
Just $ case con_args con of
PrefixCon _ -> PrefixC {..}
InfixCon _ _ -> PrefixC {..} -- FIXME: should probably change this!
RecCon (L _ fs) ->
let ac_fields = mapMaybe (fieldDoc . unLoc) fs
let ac_fields = mapMaybe fieldDoc (zip ac_args fs)
in RecordC {..}
fieldDoc :: ConDeclField GhcPs -> Maybe FieldDoc
fieldDoc ConDeclField{..} = do
fieldDoc :: (DDoc.Type, LConDeclField GhcPs) -> Maybe FieldDoc
fieldDoc (fd_type, L _ ConDeclField{..}) = do
let fd_name = Fieldname . T.concat . map (toText . unLoc) $ cd_fld_names
fd_type = hsTypeToType cd_fld_type
fd_anchor = Just $ functionAnchor dc_mod fd_name
fd_anchor = Just $ functionAnchor dc_modname fd_name
fd_descr = fmap (docToText . unLoc) cd_fld_doc
Just FieldDoc{..}
fieldDoc XConDeclField{} = Nothing
fieldDoc (_, L _ XConDeclField{}) = Nothing
getTypeDocs _ _other = Nothing
getTemplateDocs :: DocCtx -> MS.Map Typename ADTDoc -> [TemplateDoc]
@ -287,7 +319,7 @@ getTemplateDocs DocCtx{..} typeMap = map mkTemplateDoc $ Set.toList dc_templates
-- defined internally, and not expected to fail on consistent arguments.
mkTemplateDoc :: Typename -> TemplateDoc
mkTemplateDoc name = TemplateDoc
{ td_anchor = Just $ templateAnchor dc_mod (ad_name tmplADT)
{ td_anchor = Just $ templateAnchor dc_modname (ad_name tmplADT)
, td_name = ad_name tmplADT
, td_descr = ad_descr tmplADT
, td_payload = getFields tmplADT
@ -361,7 +393,7 @@ isTemplate ClsInstDecl{..}
, HsTyVar _ _ (L _ tmplClass) <- t1
, HsTyVar _ _ (L _ tmplName) <- t2
, toText tmplClass == "DA.Internal.Desugar.Template"
= Just (typenameFromRdrName tmplName)
= Just (Typename . packRdrName $ tmplName)
| otherwise = Nothing
@ -379,7 +411,7 @@ isChoice ClsInstDecl{..}
, HsTyVar _ _ (L _ choiceName) <- cName
, HsTyVar _ _ (L _ tmplName) <- cTmpl
, toText choiceClass == "DA.Internal.Desugar.Choice"
= Just (typenameFromRdrName tmplName, typenameFromRdrName choiceName)
= Just (Typename . packRdrName $ tmplName, Typename . packRdrName $ choiceName)
| otherwise = Nothing
@ -387,11 +419,12 @@ isChoice ClsInstDecl{..}
------------------------------------------------------------
-- Generating doc.s from parsed modules
-- render type variables as text (ignore kind information)
tyVarText :: HsTyVarBndr GhcPs -> T.Text
tyVarText arg = case arg of
UserTyVar _ (L _ idp) -> idpToText idp
KindedTyVar _ (L _ idp) _kind -> idpToText idp
UserTyVar _ (L _ idp) -> packRdrName idp
KindedTyVar _ (L _ idp) _kind -> packRdrName idp
XTyVarBndr _
-> error "unexpected X thing"
@ -422,84 +455,105 @@ docToText = DocText . T.strip . T.unlines . go . T.lines . T.pack . unpackHDS
stripLine limit = T.stripEnd . stripLeading limit
stripLeading limit = T.pack . map snd . dropWhile (\(i, c) -> i < limit && isSpace c) . zip [0..] . T.unpack
-- | show a parsed ID (IdP GhcPs == RdrName) as a string
idpToText :: IdP GhcPs -> T.Text
idpToText = T.pack . Out.showSDocUnsafe . Out.ppr
-- | Turn an Id into Text by taking the unqualified name it represents.
packId :: Id -> T.Text
packId = packName . idName
typenameFromRdrName :: RdrName -> Typename
typenameFromRdrName = Typename . idpToText
-- | Turn a Name into Text by taking the unqualified name it represents.
packName :: Name -> T.Text
packName = packOccName . nameOccName
-- | Turn an OccName into Text by taking the unqualified name it represents.
packOccName :: OccName -> T.Text
packOccName = T.pack . occNameString
-- | Turn a RdrName into Text by taking the unqualified name it represents.
packRdrName :: RdrName -> T.Text
packRdrName = packOccName . rdrNameOcc
-- | Turn a GHC Module into a Modulename. (Unlike the above functions,
-- we only ever want this to be a Modulename, so no reason to return
-- Text.)
getModulename :: Module -> Modulename
getModulename = Modulename . T.pack . moduleNameString . moduleName
---------------------------------------------------------------------
hsTypeToContext :: LHsType GhcPs -> Maybe DDoc.Type
hsTypeToContext (L _ HsQualTy{..}) = case unLoc hst_ctxt of
[] -> Nothing
xs -> Just $ TypeTuple $ map hsTypeToType xs
hsTypeToContext _ = Nothing
-- | Create an anchor from a TyCon. Don't make anchors for wired in names.
tyConAnchor :: DocCtx -> TyCon -> Maybe Anchor
tyConAnchor DocCtx{..} tycon = do
let ghcName = tyConName tycon
name = Typename . packName $ ghcName
mod = maybe dc_modname getModulename (nameModule_maybe ghcName)
anchorFn
| isClassTyCon tycon = classAnchor
| isDataTyCon tycon = dataAnchor
| otherwise = typeAnchor
guard (not (isWiredInName ghcName))
Just (anchorFn mod name)
---------------------------------------------------------------------
-- | Extract context from GHC type. Returns Nothing if there are no constraints.
typeToContext :: DocCtx -> TyCoRep.Type -> Maybe DDoc.Type
typeToContext dc ty =
let ctx = typeToConstraints dc ty
in guard (notNull ctx) >> Just (TypeTuple ctx)
-- | Extract constraints from GHC type, returning list of constraints.
typeToConstraints :: DocCtx -> TyCoRep.Type -> [DDoc.Type]
typeToConstraints dc = \case
FunTy a@(TyConApp tycon _) b | isClassTyCon tycon ->
typeToType dc a : typeToConstraints dc b
FunTy _ b ->
typeToConstraints dc b
ForAllTy _ b -> -- TODO: I think forall can introduce constraints?
typeToConstraints dc b
_ -> []
hsTypeToType :: LHsType GhcPs -> DDoc.Type
hsTypeToType (L _ t) = hsTypeToType_ t
-- | Convert GHC Type into a damldoc type, ignoring constraints.
typeToType :: DocCtx -> TyCoRep.Type -> DDoc.Type
typeToType ctx = \case
TyVarTy var -> TypeApp Nothing (Typename $ packId var) []
hsTypeToType_ :: HsType GhcPs -> DDoc.Type
hsTypeToType_ t = case t of
TyConApp tycon bs | isTupleTyCon tycon ->
TypeTuple (map (typeToType ctx) bs)
-- drop context things
HsForAllTy{..} -> hsTypeToType hst_body
HsQualTy {..} -> hsTypeToType hst_body
HsBangTy _ _b ty -> hsTypeToType ty
TyConApp tycon [b] | "[]" == packName (tyConName tycon) ->
TypeList (typeToType ctx b)
-- drop comments (we might want to re-add those at some point)
HsDocTy _ ty _doc -> hsTypeToType ty
TyConApp tycon bs ->
TypeApp
(tyConAnchor ctx tycon)
(Typename . packName . tyConName $ tycon)
(map (typeToType ctx) bs)
-- special tuple syntax
HsTupleTy _ _con tys -> TypeTuple $ map hsTypeToType tys
AppTy a b ->
case typeToType ctx a of
TypeApp m f bs -> TypeApp m f (bs <> [typeToType ctx b]) -- flatten app chains
TypeFun _ -> unexpected "function type in a type app"
TypeList _ -> unexpected "list type in a type app"
TypeTuple _ -> unexpected "tuple type in a type app"
-- GHC specials. FIXME deal with them specially
HsRecTy _ _flds -> TypeApp Nothing (Typename $ toText t) [] -- FIXME pprConDeclFields flds
-- ignore context
ForAllTy _ b -> typeToType ctx b
FunTy (TyConApp tycon _) b | isClassTyCon tycon ->
typeToType ctx b
HsSumTy _ _tys -> undefined -- FIXME tupleParens UnboxedTuple (pprWithBars ppr tys)
FunTy a b ->
case typeToType ctx b of
TypeFun bs -> TypeFun (typeToType ctx a : bs) -- flatten function types
b' -> TypeFun [typeToType ctx a, b']
CastTy a _ -> typeToType ctx a
LitTy x -> TypeApp Nothing (Typename $ toText x) []
CoercionTy _ -> unexpected "coercion" -- TODO?
-- straightforward base case
HsTyVar _ _ (L _ name) -> TypeApp Nothing (Typename $ idpToText name) []
where
-- | Unhandled case.
unexpected x = error $ "typeToType: found an unexpected " <> x
HsFunTy _ ty1 ty2 -> case hsTypeToType ty2 of
TypeFun as -> TypeFun $ hsTypeToType ty1 : as
ty22 -> TypeFun [hsTypeToType ty1, ty22]
HsKindSig _ ty _kind -> hsTypeToType ty
HsListTy _ ty -> TypeList (hsTypeToType ty)
HsIParamTy _ _n ty -> hsTypeToType ty
-- currently bailing out when we meet promoted structures
HsSpliceTy _ _s -> unexpected "splice"
HsExplicitListTy _ _ _tys -> unexpected "explicit list"
HsExplicitTupleTy _ _tys -> unexpected "explicit tuple"
HsTyLit _ ty -> TypeApp Nothing (Typename $ toText ty) []
-- kind things. Can be printed, not sure why we would
HsWildCardTy {} -> TypeApp Nothing (Typename "_") []
HsStarTy _ _ -> TypeApp Nothing (Typename "*") []
HsAppTy _ fun_ty arg_ty ->
case hsTypeToType fun_ty of
TypeApp m f as -> TypeApp m f $ as <> [hsTypeToType arg_ty] -- flattens app chains
TypeFun _ -> unexpected "function type in a type app"
TypeList _ -> unexpected "list type in a type app"
TypeTuple _ -> unexpected "tuple type in a type app"
HsAppKindTy _ _ _ -> unexpected "kind application"
HsOpTy _ ty1 (L _ op) ty2 ->
TypeApp Nothing (Typename $ toText op) [ hsTypeToType ty1, hsTypeToType ty2 ]
HsParTy _ ty -> hsTypeToType ty
XHsType _t -> unexpected "XHsType"
where unexpected x = error $ "hsTypeToType: found an unexpected " <> x
---- HACK ZONE --------------------------------------------------------

1
compiler/damlc/daml-doc/src/DA/Daml/Doc/Render.hs
View File

@ -5,6 +5,7 @@
module DA.Daml.Doc.Render
( DocFormat(..)
, renderFinish
, renderSimpleRst
, renderSimpleMD
, renderSimpleHtml

272
compiler/damlc/daml-doc/src/DA/Daml/Doc/Render/Rst.hs
View File

@ -1,10 +1,11 @@
-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings, DerivingStrategies #-}
module DA.Daml.Doc.Render.Rst
( renderSimpleRst
, renderFinish
) where
import DA.Daml.Doc.Types
@ -17,110 +18,177 @@ import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
import Data.Char
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Set as Set
import CMarkGFM
renderAnchor :: Maybe Anchor -> T.Text
renderAnchor Nothing = ""
renderAnchor (Just anchor) = "\n.. _" <> unAnchor anchor <> ":\n"
-- | Renderer output. This is the set of anchors that were generated, and a
-- list of output functions that depend on that set. The goal is to prevent
-- the creation of spurious anchors links (i.e. links to anchors that don't
-- exist).
--
-- (In theory this could be done in two steps, but that seems more error prone
-- than building up both steps at the same time, and combining them at the
-- end, as is done here.)
--
-- Using a newtype here so we can derive the semigroup / monoid instances we
-- want automatically. :-)
newtype RenderOut = RenderOut (RenderEnv, [RenderEnv -> [T.Text]])
deriving newtype (Semigroup, Monoid)
renderSimpleRst :: ModuleDoc -> T.Text
newtype RenderEnv = RenderEnv (Set.Set Anchor)
deriving newtype (Semigroup, Monoid)
-- | Is the anchor available in the render environment? Renderers should avoid
-- generating links to anchors that don't actually exist.
--
-- One reason an anchor may be unavailable is because of a @-- | HIDE@ directive.
-- Another possibly reason is that the anchor refers to a definition in another
-- package (and at the moment it's not possible to link accross packages).
renderAnchorAvailable :: RenderEnv -> Anchor -> Bool
renderAnchorAvailable (RenderEnv anchors) anchor = Set.member anchor anchors
renderFinish :: RenderOut -> T.Text
renderFinish (RenderOut (xs, fs)) = T.unlines (concatMap ($ xs) fs)
renderAnchor :: Maybe Anchor -> RenderOut
renderAnchor Nothing = mempty
renderAnchor (Just anchor) = RenderOut
( RenderEnv (Set.singleton anchor)
, [const ["", ".. _" <> unAnchor anchor <> ":", ""]]
)
renderLine :: T.Text -> RenderOut
renderLine l = renderLines [l]
renderLines :: [T.Text] -> RenderOut
renderLines ls = renderLinesDep (const ls)
renderLineDep :: (RenderEnv -> T.Text) -> RenderOut
renderLineDep f = renderLinesDep (pure . f)
renderLinesDep :: (RenderEnv -> [T.Text]) -> RenderOut
renderLinesDep f = RenderOut (mempty, [f])
renderIndent :: Int -> RenderOut -> RenderOut
renderIndent n (RenderOut (env, fs)) =
RenderOut (env, map (map (T.replicate n " " <>) .) fs)
renderDocText :: DocText -> RenderOut
renderDocText = renderLines . T.lines . docTextToRst
renderSimpleRst :: ModuleDoc -> RenderOut
renderSimpleRst ModuleDoc{..}
| null md_templates && null md_classes &&
null md_adts && null md_functions &&
isNothing md_descr = T.empty
renderSimpleRst ModuleDoc{..} = T.unlines $
isNothing md_descr = mempty
renderSimpleRst ModuleDoc{..} = mconcat $
[ renderAnchor md_anchor
, title
, T.replicate (T.length title) "-"
, maybe "" docTextToRst md_descr
, renderLines
[ title
, T.replicate (T.length title) "-"
, maybe "" docTextToRst md_descr
]
]
<> concat
[ if null md_templates
then []
else [""
, "Templates"
, "^^^^^^^^^"
, T.unlines $ map tmpl2rst md_templates
else [ renderLines
[ ""
, "Templates"
, "^^^^^^^^^" ]
, mconcat $ map tmpl2rst md_templates
]
, if null md_classes
then []
else [ ""
, "Typeclasses"
, "^^^^^^^^^^^"
, T.unlines $ map cls2rst md_classes
else [ renderLines
[ ""
, "Typeclasses"
, "^^^^^^^^^^^" ]
, mconcat $ map cls2rst md_classes
]
, if null md_adts
then []
else [ ""
, "Data types"
, "^^^^^^^^^^"
, T.unlines $ map adt2rst md_adts
else [ renderLines
[ ""
, "Data types"
, "^^^^^^^^^^"]
, mconcat $ map adt2rst md_adts
]
, if null md_functions
then []
else [ ""
, "Functions"
, "^^^^^^^^^"
, T.unlines $ map fct2rst md_functions
else [ renderLines
[ ""
, "Functions"
, "^^^^^^^^^" ]
, mconcat $ map fct2rst md_functions
]
]
where title = "Module " <> unModulename md_name
tmpl2rst :: TemplateDoc -> T.Text
tmpl2rst TemplateDoc{..} = T.unlines $
renderAnchor td_anchor :
("template " <> enclosedIn "**" (unTypename td_name)) :
maybe "" (T.cons '\n' . indent 2 . docTextToRst) td_descr :
"" :
indent 2 (fieldTable td_payload) :
"" :
map (indent 2 . choiceBullet) td_choices -- ends by "\n" because of unlines above
tmpl2rst :: TemplateDoc -> RenderOut
tmpl2rst TemplateDoc{..} = mconcat $
[ renderAnchor td_anchor
, renderLine $ "template " <> enclosedIn "**" (unTypename td_name)
, maybe mempty ((renderLine "" <>) . renderIndent 2 . renderDocText) td_descr
, renderLine ""
, renderIndent 2 (fieldTable td_payload)
, renderLine ""
] ++ map (renderIndent 2 . choiceBullet) td_choices
choiceBullet :: ChoiceDoc -> T.Text
choiceBullet ChoiceDoc{..} = T.unlines
[ prefix "+ " $ enclosedIn "**" $ "Choice " <> unTypename cd_name
, maybe "" (flip T.snoc '\n' . indent 2 . docTextToRst) cd_descr
, indent 2 (fieldTable cd_fields)
choiceBullet :: ChoiceDoc -> RenderOut
choiceBullet ChoiceDoc{..} = mconcat
[ renderLine $ prefix "+ " $ enclosedIn "**" $ "Choice " <> unTypename cd_name
, maybe mempty ((renderLine "" <>) . renderIndent 2 . renderDocText) cd_descr
, renderIndent 2 (fieldTable cd_fields)
]
cls2rst :: ClassDoc -> T.Text
cls2rst ClassDoc{..} = T.unlines $
renderAnchor cl_anchor :
"**class " <> maybe "" (\x -> type2rst x <> " => ") cl_super <> T.unwords (unTypename cl_name : cl_args) <> " where**" :
maybe [] ((:[""]) . indent 2 . docTextToRst) cl_descr ++
map (indent 2 . fct2rst) cl_functions
cls2rst :: ClassDoc -> RenderOut
cls2rst ClassDoc{..} = mconcat
[ renderAnchor cl_anchor
, renderLineDep $ \env ->
"**class " <> maybe "" (\x -> type2rst env x <> " => ") cl_super <> T.unwords (unTypename cl_name : cl_args) <> " where**"
, maybe mempty ((renderLine "" <>) . renderIndent 2 . renderDocText) cl_descr
, mconcat $ map (renderIndent 2 . fct2rst) cl_functions
]
adt2rst :: ADTDoc -> T.Text
adt2rst TypeSynDoc{..} = T.unlines $
adt2rst :: ADTDoc -> RenderOut
adt2rst TypeSynDoc{..} = mconcat
[ renderAnchor ad_anchor
, "type " <> enclosedIn "**"
(T.unwords (unTypename ad_name : ad_args))
, " = " <> type2rst ad_rhs
] ++ maybe [] ((:[]) . T.cons '\n' . indent 2 . docTextToRst) ad_descr
adt2rst ADTDoc{..} = T.unlines $
, renderLinesDep $ \env ->
[ "type " <> enclosedIn "**"
(T.unwords (unTypename ad_name : ad_args))
, " = " <> type2rst env ad_rhs
, ""
]
, maybe mempty ((<> renderLine "") . renderIndent 2 . renderDocText) ad_descr
]
adt2rst ADTDoc{..} = mconcat $
[ renderAnchor ad_anchor
, "data " <> enclosedIn "**"
(T.unwords (unTypename ad_name : ad_args))
, maybe "" (T.cons '\n' . indent 2 . docTextToRst) ad_descr
] ++ map (indent 2 . T.cons '\n' . constr2rst) ad_constrs
, renderLines
[ "data " <> enclosedIn "**" (T.unwords (unTypename ad_name : ad_args))
, "" ]
, maybe mempty ((<> renderLine "") . renderIndent 2 . renderDocText) ad_descr
] ++ map (renderIndent 2 . (renderLine "" <>) . constr2rst) ad_constrs
constr2rst :: ADTConstr -> T.Text
constr2rst PrefixC{..} = T.unlines $
constr2rst :: ADTConstr -> RenderOut
constr2rst PrefixC{..} = mconcat
[ renderAnchor ac_anchor
, T.unwords (enclosedIn "**" (unTypename ac_name) : map type2rst ac_args)
-- FIXME: Parentheses around args seems necessary here
-- if they are type application or function (see type2rst).
] ++ maybe [] ((:[]) . T.cons '\n' . docTextToRst) ac_descr
, renderLineDep $ \env ->
T.unwords (enclosedIn "**" (unTypename ac_name) : map (type2rst env) ac_args)
-- FIXME: Parentheses around args seems necessary here
-- if they are type application or function (see type2rst).
, maybe mempty ((renderLine "" <>) . renderDocText) ac_descr
]
constr2rst RecordC{..} = T.unlines
constr2rst RecordC{..} = mconcat
[ renderAnchor ac_anchor
, enclosedIn "**" (unTypename ac_name)
, maybe "" (T.cons '\n' . docTextToRst) ac_descr
, ""
, renderLine $ enclosedIn "**" (unTypename ac_name)
, renderLine ""
, maybe mempty renderDocText ac_descr
, renderLine ""
, fieldTable ac_fields
]
@ -144,45 +212,61 @@ constr2rst RecordC{..} = T.unlines
> - `Text`
> - and text
-}
fieldTable :: [FieldDoc] -> T.Text
fieldTable [] = ""
fieldTable fds = T.unlines $ -- NB final empty line is essential and intended
[ ".. list-table::", " :widths: 15 10 30", " :header-rows: 1", ""]
<> map (indent 3) (headerRow <> fieldRows)
fieldTable :: [FieldDoc] -> RenderOut
fieldTable [] = mempty
fieldTable fds = mconcat -- NB final empty line is essential and intended
[ renderLines
[ ".. list-table::"
, " :widths: 15 10 30"
, " :header-rows: 1"
, ""
, " * - Field"
, " - Type"
, " - Description" ]
, fieldRows
]
where
headerRow = [ "* - Field"
, " - Type"
, " - Description" ]
fieldRows = concat
[ [ prefix "* - " $ escapeTr_ (unFieldname fd_name)
, prefix " - " $ type2rst fd_type
, prefix " - " $ maybe " " (docTextToRst . DocText . T.unwords . T.lines . unDocText) fd_descr ] -- FIXME: this makes no sense
fieldRows = renderLinesDep $ \env -> concat
[ [ prefix " * - " $ escapeTr_ (unFieldname fd_name)
, prefix " - " $ type2rst env fd_type
, prefix " - " $ maybe " " (docTextToRst . DocText . T.unwords . T.lines . unDocText) fd_descr ] -- FIXME: indent properly instead of this
| FieldDoc{..} <- fds ]
-- | Render a type. Nested type applications are put in parentheses.
type2rst :: Type -> T.Text
type2rst = f (0 :: Int)
type2rst :: RenderEnv -> Type -> T.Text
type2rst env = f 0
where
-- 0 = no brackets
-- 1 = brackets around function
-- 2 = brackets around function AND application
f _ (TypeApp _ n []) = unTypename n
f i (TypeApp _ n as) = (if i >= 2 then inParens else id) $ T.unwords (unTypename n : map (f 2) as)
f i (TypeFun ts) = (if i >= 1 then inParens else id) $ T.intercalate " -> " $ map (f 1) ts
f :: Int -> Type -> T.Text
f _ (TypeApp a n []) = link a n
f i (TypeApp a n as) = (if i >= 2 then inParens else id) $
T.unwords (link a n : map (f 2) as)
f i (TypeFun ts) = (if i >= 1 then inParens else id) $
T.intercalate " -> " $ map (f 1) ts
f _ (TypeList t1) = "[" <> f 0 t1 <> "]"
f _ (TypeTuple ts) = "(" <> T.intercalate ", " (map (f 0) ts) <> ")"
link :: Maybe Anchor -> Typename -> T.Text
link Nothing n = unTypename n
link (Just anchor) n =
if renderAnchorAvailable env anchor
then T.concat ["`", unTypename n, " <", unAnchor anchor, "_>`_"]
else unTypename n
fct2rst :: FunctionDoc -> T.Text
fct2rst FunctionDoc{..} = T.unlines
fct2rst :: FunctionDoc -> RenderOut
fct2rst FunctionDoc{..} = mconcat
[ renderAnchor fct_anchor
, enclosedIn "**" (wrapOp (unFieldname fct_name))
, T.concat
[ " : "
, maybe "" ((<> " => ") . type2rst) fct_context
, maybe "" ((<> "\n\n") . type2rst) fct_type
-- FIXME: when would a function not have a type?
, maybe "" (indent 2 . docTextToRst) fct_descr
, renderLinesDep $ \ env ->
[ enclosedIn "**" (wrapOp (unFieldname fct_name))
, T.concat
[ " : "
, maybe "" ((<> " => ") . type2rst env) fct_context
, maybe "" ((<> "\n\n") . type2rst env) fct_type
-- FIXME: when would a function not have a type?
, maybe "" (indent 2 . docTextToRst) fct_descr
]
]
]

2
compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Render/Tests.hs
View File

@ -219,7 +219,7 @@ renderTest format (name, input) expected =
let
renderer = case format of
Json -> error "Json encoder testing not done here"
Rst -> renderSimpleRst
Rst -> renderFinish . renderSimpleRst
Markdown -> renderSimpleMD
Html -> error "HTML testing not supported (use Markdown)"
Hoogle -> error "Hoogle doc testing not yet supported."

2
compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
View File

@ -267,7 +267,7 @@ fileTest damlFile = do
let extension = takeExtension expectation
ref <- T.readFileUtf8 expectation
case extension of
".rst" -> expectEqual extension ref $ renderSimpleRst docs
".rst" -> expectEqual extension ref $ renderFinish $ renderSimpleRst docs
".md" -> expectEqual extension ref $ renderSimpleMD docs
".json" -> expectEqual extension ref
(T.decodeUtf8 . BS.toStrict $

2
compiler/damlc/tests/daml-test-files/Iou_template.EXPECTED.md
View File

@ -51,7 +51,7 @@
## Functions
* `main`
* `main` : `Scenario` `(` `)`
A single test scenario covering all functionality that `Iou` implements.
This description contains [a link](http://example.com), some bogus <inline html>,
and words_ with_ underscore, to test damldoc capabilities.

15
compiler/damlc/tests/daml-test-files/Iou_template.EXPECTED.rst
View File

@ -12,7 +12,6 @@ Templates
template **Iou**
.. list-table::
:widths: 15 10 30
:header-rows: 1
@ -37,8 +36,8 @@ template **Iou**
- ``regulators`` may observe any use of the ``Iou``
+ **Choice Merge**
merges two "compatible" ``Iou``s
merges two "compatible" ``Iou``s
.. list-table::
:widths: 15 10 30
:header-rows: 1
@ -50,9 +49,9 @@ template **Iou**
- ContractId Iou
- Must have same owner, issuer, and currency. The regulators may differ, and are taken from the original ``Iou``.
+ **Choice Split**
splits into two ``Iou``s with
smaller amounts
.. list-table::
:widths: 15 10 30
:header-rows: 1
@ -64,8 +63,8 @@ template **Iou**
- Decimal
- must be between zero and original amount
+ **Choice Transfer**
changes the owner
changes the owner
.. list-table::
:widths: 15 10 30
:header-rows: 1
@ -77,16 +76,14 @@ template **Iou**
- Party
-
Functions
^^^^^^^^^
.. _function-ioutemplate-main-13221:
**main**
: A single test scenario covering all functionality that ``Iou`` implements.
: Scenario ()
A single test scenario covering all functionality that ``Iou`` implements.
This description contains a link(http://example.com), some bogus <inline html>,
and words\_ with\_ underscore, to test damldoc capabilities.

26
compiler/damlc/tests/daml-test-files/Newtype.EXPECTED.md Normal file
View File

@ -0,0 +1,26 @@
# Module Newtype
## Data types
### `data` `Nat`
* `Nat`
| Field | Type/Description |
| :------ | :----------------
| `unNat` | `Int` |
## Functions
* `mkNat` : `Int` `->` `Nat`
* `unsafeMkNat` : `Int` `->` `Nat`
* `zero0` : `Nat`
* `one1` : `Nat`
* `unNat1` : `Nat` `->` `Int`
* `unNat2` : `Nat` `->` `Int`
* `unNat3` : `Nat` `->` `Int`

83
compiler/damlc/tests/daml-test-files/Newtype.EXPECTED.rst Normal file
View File

@ -0,0 +1,83 @@
.. _module-newtype-36781:
Module Newtype
--------------
Data types
^^^^^^^^^^
.. _type-newtype-nat-61947:
data **Nat**
.. _constr-newtype-nat-99832:
**Nat**
.. list-table::
:widths: 15 10 30
:header-rows: 1
* - Field
- Type
- Description
* - unNat
- Int
-
Functions
^^^^^^^^^
.. _function-newtype-mknat-8513:
**mkNat**
: Int -> `Nat <type-newtype-nat-61947_>`_
.. _function-newtype-unsafemknat-96593:
**unsafeMkNat**
: Int -> `Nat <type-newtype-nat-61947_>`_
.. _function-newtype-zero0-10450:
**zero0**
: `Nat <type-newtype-nat-61947_>`_
.. _function-newtype-one1-53872:
**one1**
: `Nat <type-newtype-nat-61947_>`_
.. _function-newtype-unnat1-26452:
**unNat1**
: `Nat <type-newtype-nat-61947_>`_ -> Int
.. _function-newtype-unnat2-96339:
**unNat2**
: `Nat <type-newtype-nat-61947_>`_ -> Int
.. _function-newtype-unnat3-97654:
**unNat3**
: `Nat <type-newtype-nat-61947_>`_ -> Int

3
unreleased.rst
View File

@ -80,3 +80,6 @@ HEAD — ongoing
`restriction about contract key lookup
<https://github.com/digital-asset/daml/issues/1866>`__ described in the
DAML-LF section
- [DAML Docs]: Added links to type signatures in generated docs. Check out the updated
`the standard library docs <https://docs.daml.com/daml/reference/base.html>`__.