From 9042d14cb141cc52af3708de1df47ab3657c87eb Mon Sep 17 00:00:00 2001 From: associahedron <231829+associahedron@users.noreply.github.com> Date: Mon, 5 Aug 2019 14:23:58 +0100 Subject: [PATCH] Damldocs qualified flag (#2394) * Rename HaddockParse -> Extract * Add --qualify-types option. * More qualified type options * Update help text * Update compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs Co-Authored-By: Jost Berthold * Accidentally left in a testing change. * Documenting DocCtx fields * Mark new options internal --- .../damlc/daml-doc/src/DA/Daml/Doc/Driver.hs | 5 +- .../Daml/Doc/{HaddockParse.hs => Extract.hs} | 111 +++++++++++++++--- .../test/DA/Daml/GHC/Damldoc/Tests.hs | 7 +- .../damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs | 36 ++++++ 4 files changed, 138 insertions(+), 21 deletions(-) rename compiler/damlc/daml-doc/src/DA/Daml/Doc/{HaddockParse.hs => Extract.hs} (86%) diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs index 3750cdf667..5ca93f3330 100644 --- a/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs +++ b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Driver.hs @@ -13,7 +13,7 @@ module DA.Daml.Doc.Driver import DA.Daml.Doc.Types import DA.Daml.Doc.Render -import DA.Daml.Doc.HaddockParse +import DA.Daml.Doc.Extract import DA.Daml.Doc.Transform import Development.IDE.Types.Location @@ -45,6 +45,7 @@ data DamldocOptions = DamldocOptions , do_inputFiles :: [NormalizedFilePath] , do_docTitle :: Maybe T.Text , do_combine :: Bool + , do_extractOptions :: ExtractOptions } data InputFormat = InputJson | InputDaml @@ -82,7 +83,7 @@ inputDocData DamldocOptions{..} = do concatMapM (either printAndExit pure) mbData InputDaml -> onErrorExit . runExceptT $ - mkDocs do_ideOptions do_inputFiles + extractDocs do_extractOptions do_ideOptions do_inputFiles -- | Output doc data. renderDocData :: DamldocOptions -> [ModuleDoc] -> IO () diff --git a/compiler/damlc/daml-doc/src/DA/Daml/Doc/HaddockParse.hs b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs similarity index 86% rename from compiler/damlc/daml-doc/src/DA/Daml/Doc/HaddockParse.hs rename to compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs index ff7fc18734..12756cf88e 100644 --- a/compiler/damlc/daml-doc/src/DA/Daml/Doc/HaddockParse.hs +++ b/compiler/damlc/daml-doc/src/DA/Daml/Doc/Extract.hs @@ -1,8 +1,16 @@ -- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 - -module DA.Daml.Doc.HaddockParse(mkDocs) where +-- | This module extracts docs from DAML modules. It does so by reading +-- haddock-style comments from the parsed syntax tree and correlating them +-- with definitions in the typechecked module in order to obtain accurate +-- type information. +module DA.Daml.Doc.Extract + ( ExtractOptions (..) + , QualifyTypes (..) + , defaultExtractOptions + , extractDocs + ) where import DA.Daml.Doc.Types as DDoc import DA.Daml.Doc.Anchor as DDoc @@ -39,13 +47,35 @@ import qualified Data.Text as T import Data.Tuple.Extra (second) import Data.Either --- | Parse, and process documentation in, a dependency graph of modules. -mkDocs - :: IdeOptions +-- | Options that affect doc extraction. +data ExtractOptions = ExtractOptions + { eo_qualifyTypes :: QualifyTypes + -- ^ qualify non-local types + , eo_simplifyQualifiedTypes :: Bool + -- ^ drop common module prefix when qualifying types + } deriving (Eq, Show, Read) + +data QualifyTypes + = QualifyTypesAlways + | QualifyTypesInPackage + | QualifyTypesNever + deriving (Eq, Show, Read) + +-- | Default options for doc extraction. +defaultExtractOptions :: ExtractOptions +defaultExtractOptions = ExtractOptions + { eo_qualifyTypes = QualifyTypesNever + , eo_simplifyQualifiedTypes = False + } + +-- | Extract documentation in a dependency graph of modules. +extractDocs :: + ExtractOptions + -> IdeOptions -> [NormalizedFilePath] -> Ex.ExceptT [FileDiagnostic] IO [ModuleDoc] -mkDocs opts fp = do - modules <- haddockParse opts fp +extractDocs extractOpts ideOpts fp = do + modules <- haddockParse ideOpts fp pure $ map mkModuleDocs modules where @@ -57,7 +87,7 @@ mkDocs opts fp = do mkModuleDocs :: Service.TcModuleResult -> ModuleDoc mkModuleDocs tmr = - let ctx@DocCtx{..} = buildDocCtx (Service.tmrModule tmr) + let ctx@DocCtx{..} = buildDocCtx extractOpts (Service.tmrModule tmr) typeMap = MS.fromList $ mapMaybe (getTypeDocs ctx) dc_decls classDocs = mapMaybe (getClsDocs ctx) dc_decls @@ -138,17 +168,26 @@ collectDocs = go Nothing [] -- | Context in which to extract a module's docs. This is created from -- 'TypecheckedModule' by 'buildDocCtx'. data DocCtx = DocCtx - { dc_modname :: Modulename + { dc_ghcMod :: GHC.Module + -- ^ ghc name for current module + , dc_modname :: Modulename + -- ^ name of the current module , dc_tcmod :: TypecheckedModule + -- ^ typechecked module , dc_decls :: [DeclData] - + -- ^ module declarations , dc_tycons :: MS.Map Typename TyCon + -- ^ types defined in this module , dc_datacons :: MS.Map Typename DataCon + -- ^ constructors defined in this module , dc_ids :: MS.Map Fieldname Id - + -- ^ values defined in this module , dc_templates :: Set.Set Typename + -- ^ DAML templates defined in this module , dc_choices :: MS.Map Typename (Set.Set Typename) - -- ^ choices per template + -- ^ choices per DAML template defined in this module + , dc_extractOptions :: ExtractOptions + -- ^ command line options that affect the doc extractor } -- | Parsed declaration with associated docs. @@ -157,9 +196,10 @@ data DeclData = DeclData , _dd_docs :: Maybe DocText } -buildDocCtx :: TypecheckedModule -> DocCtx -buildDocCtx dc_tcmod = - let dc_modname = getModulename . ms_mod . pm_mod_summary . tm_parsed_module $ dc_tcmod +buildDocCtx :: ExtractOptions -> TypecheckedModule -> DocCtx +buildDocCtx dc_extractOptions dc_tcmod = + let dc_ghcMod = ms_mod . pm_mod_summary . tm_parsed_module $ dc_tcmod + dc_modname = getModulename dc_ghcMod dc_decls = map (uncurry DeclData) . collectDocs . hsmodDecls . unLoc . pm_parsed_source . tm_parsed_module $ dc_tcmod @@ -546,7 +586,7 @@ getModulename = Modulename . T.pack . moduleNameString . moduleName --------------------------------------------------------------------- --- | Create an anchor from a TyCon. Don't make anchors for wired in names. +-- | Create an anchor from a TyCon. tyConAnchor :: DocCtx -> TyCon -> Maybe Anchor tyConAnchor DocCtx{..} tycon = do let ghcName = tyConName tycon @@ -557,6 +597,43 @@ tyConAnchor DocCtx{..} tycon = do | otherwise = typeAnchor Just (anchorFn mod name) +-- | Extract a potentially qualified typename from a TyCon. +tyConTypename :: DocCtx -> TyCon -> Typename +tyConTypename DocCtx{..} tycon = + let ExtractOptions{..} = dc_extractOptions + ghcName = tyConName tycon + qualify = + case eo_qualifyTypes of + QualifyTypesAlways -> True + QualifyTypesInPackage -> nameIsHomePackageImport dc_ghcMod ghcName + QualifyTypesNever -> False + + moduleM = guard qualify >> nameModule_maybe ghcName + modNameM = getModulename <$> moduleM + simplifyModName + | eo_simplifyQualifiedTypes = dropCommonModulePrefix dc_modname + | otherwise = id + prefix = maybe "" ((<> ".") . unModulename . simplifyModName) modNameM + in Typename (prefix <> packName ghcName) + +-- | Drop common module name prefix, returning the second module name +-- sans the module prefix it has in common with the first module name. +-- This will not return an empty module name however (unless given an +-- empty module name to start). +-- +-- This function respects the atomicity of the module names between +-- periods. For instance @dropCommonModulePrefix "Foo.BarBaz" "Foo.BarSpam"@ +-- will evaluate to @"BarSpam"@, not @"Spam"@. +dropCommonModulePrefix :: Modulename -> Modulename -> Modulename +dropCommonModulePrefix (Modulename baseMod) (Modulename targetMod) = + Modulename . T.intercalate "." $ + aux (T.splitOn "." baseMod) (T.splitOn "." targetMod) + where + aux :: [T.Text] -> [T.Text] -> [T.Text] + aux _ [x] = [x] + aux (x:xs) (y:ys) | x == y = aux xs ys + aux _ p = p + --------------------------------------------------------------------- -- | Extract context from GHC type. Returns Nothing if there are no constraints. @@ -591,7 +668,7 @@ typeToType ctx = \case TyConApp tycon bs -> TypeApp (tyConAnchor ctx tycon) - (Typename . packName . tyConName $ tycon) + (tyConTypename ctx tycon) (map (typeToType ctx) bs) AppTy a b -> diff --git a/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs b/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs index a9fd8198d1..c77109d842 100644 --- a/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs +++ b/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs @@ -9,7 +9,7 @@ import DA.Bazel.Runfiles import DA.Daml.Options import DA.Daml.Options.Types -import DA.Daml.Doc.HaddockParse +import DA.Daml.Doc.Extract import DA.Daml.Doc.Render import DA.Daml.Doc.Types import DA.Daml.Doc.Anchor @@ -252,7 +252,10 @@ damldocExpect importPathM testname input check = } -- run the doc generator on that file - mbResult <- runExceptT $ mkDocs (toCompileOpts opts') [toNormalizedFilePath testfile] + mbResult <- runExceptT $ extractDocs + defaultExtractOptions + (toCompileOpts opts') + [toNormalizedFilePath testfile] case mbResult of Left err -> assertFailure $ unlines diff --git a/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs b/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs index 6765c26382..c5bf543c56 100644 --- a/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs +++ b/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs @@ -6,6 +6,7 @@ module DA.Cli.Damlc.Command.Damldoc(cmdDamlDoc) where import DA.Cli.Options import DA.Daml.Doc.Driver +import DA.Daml.Doc.Extract import DA.Daml.Options import DA.Daml.Options.Types import Development.IDE.Types.Location @@ -35,6 +36,7 @@ documentation = Damldoc <*> optInclude <*> optExclude <*> optCombine + <*> optExtractOptions <*> argMainFiles where optInputFormat :: Parser InputFormat @@ -136,6 +138,38 @@ documentation = Damldoc long "combine" <> help "Combine all generated docs into a single output file (always on for json and hoogle output)." + optExtractOptions :: Parser ExtractOptions + optExtractOptions = ExtractOptions + <$> optQualifyTypes + <*> optSimplifyQualifiedTypes + + optQualifyTypes :: Parser QualifyTypes + optQualifyTypes = option readQualifyTypes $ + long "qualify-types" + <> metavar "MODE" + <> help + ("Qualify any non-local types in generated docs. " + <> "Can be set to \"always\" (always qualify non-local types), " + <> "\"never\" (never qualify non-local types), " + <> "and \"inpackage\" (qualify non-local types defined in the " + <> "same package). Defaults to \"never\".") + <> value QualifyTypesNever + <> internal + + readQualifyTypes = + eitherReader $ \arg -> + case lower arg of + "always" -> Right QualifyTypesAlways + "inpackage" -> Right QualifyTypesInPackage + "never" -> Right QualifyTypesNever + _ -> Left "Unknown mode for --qualify-types. Expected \"always\", \"never\", or \"inpackage\"." + + optSimplifyQualifiedTypes :: Parser Bool + optSimplifyQualifiedTypes = switch $ + long "simplify-qualified-types" + <> help "Simplify qualified types by dropping the common module prefix. See --qualify-types option." + <> internal + ------------------------------------------------------------ -- Command Execution @@ -151,6 +185,7 @@ data CmdArgs = Damldoc { cInputFormat :: InputFormat , cIncludeMods :: [String] , cExcludeMods :: [String] , cCombine :: Bool + , cExtractOptions :: ExtractOptions , cMainFiles :: [FilePath] } deriving (Eq, Show, Read) @@ -168,6 +203,7 @@ exec Damldoc{..} = do , do_transformOptions = transformOptions , do_docTitle = T.pack <$> cPkgName , do_combine = cCombine + , do_extractOptions = cExtractOptions } where