From 4f249c9b64d50d79e7ba703289cd67293a76821a Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Fri, 10 Mar 2017 11:31:33 -0500 Subject: Update Haddock w.r.t. new HsImplicitBndrs --- haddock-api/src/Haddock/Interface/Rename.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index f88d9f4e..b43860fb 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -577,7 +577,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder }) } + , hsib_vars = PlaceHolder + , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs Name in_thing -- cgit v1.2.3 From 68e531baa35e698d947686b83525871eb33c3730 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 02:53:36 -0700 Subject: Correctly handle Backpack identity/semantic modules. Signed-off-by: Edward Z. Yang (cherry picked from commit 26d6c150b31bc4580ab17cfd07b6e7f9afe10737) --- haddock-api/src/Haddock/Interface/Create.hs | 75 +++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 21 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c8e6b982..ff53fd3c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -62,6 +62,7 @@ createInterface tm flags modMap instIfaceMap = do L _ hsm = parsedSource tm !safety = modInfoSafe mi mdl = ms_mod ms + sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md @@ -88,8 +89,9 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances - ++ map getName fam_instances + localInsts = filter (nameIsLocalOrFrom sem_mdl) + $ map getName instances + ++ map getName fam_instances -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] @@ -104,7 +106,7 @@ createInterface tm flags modMap instIfaceMap = do let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -156,6 +158,10 @@ createInterface tm flags modMap instIfaceMap = do , ifaceTokenizedSrc = tokenizedSrc } +-- | Given all of the @import M as N@ declarations in a package, +-- create a mapping from the module identity of M, to an alias N +-- (if there are multiple aliases, we pick the last one.) This +-- will go in 'ifaceModuleAliases'. mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName mkAliasMap dflags mRenamedSource = case mRenamedSource of @@ -166,13 +172,28 @@ mkAliasMap dflags mRenamedSource = SrcLoc.L _ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! (fmap Module.fsToUnitId $ fmap sl_fs $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls --- similar to GHC.lookupModule +-- Similar to GHC.lookupModule +-- ezyang: Not really... lookupModuleDyn :: DynFlags -> Maybe UnitId -> ModuleName -> Module lookupModuleDyn _ (Just pkgId) mdlName = @@ -492,6 +513,7 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) @@ -504,7 +526,7 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod warnings gre exportedNames decls + modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls @@ -515,6 +537,7 @@ mkExportItems lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = + -- Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr @@ -582,6 +605,8 @@ mkExportItems Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. + -- TODO: This needs to be more sophisticated to deal + -- with signature inheritance case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell @@ -597,8 +622,7 @@ mkExportItems mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name mkExportDecl name decl (doc, subs) = decl' where - decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False - mdl = nameModule name + decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False subs' = filter (isExported . fst) subs sub_names = map fst subs' fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] @@ -609,14 +633,20 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n - | m == thisMod, Just ds <- M.lookup n declMap = + | m == semMod, Just ds <- M.lookup n declMap = (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n +-- | Given a 'Module' from a 'Name', convert it into a 'Module' that +-- we can actually find in the 'IfaceMap'. +semToIdMod :: UnitId -> Module -> Module +semToIdMod this_uid m + | Module.isHoleModule m = mkModule this_uid (moduleName m) + | otherwise = m hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) hiDecl dflags t = do @@ -679,7 +709,7 @@ lookupDocs n warnings docMap argMap subMap = -- only return those that are. -- 3) B is visible and all its exports are in scope, in which case we return -- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A +moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A -> WarningMap @@ -693,8 +723,11 @@ moduleExports :: Module -- ^ Module A -> [SrcSpan] -- ^ Locations of all TH splices -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls + | expMod == moduleName thisMod + = fullModuleContents dflags warnings gre maps fixMap splices decls | otherwise = + -- NB: we constructed the identity module when looking up in + -- the IfaceMap. case M.lookup m ifaceMap of Just iface | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) @@ -710,7 +743,7 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa "documentation for exported module: " ++ pretty dflags expMod] return [] where - m = mkModule unitId expMod + m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod @@ -789,8 +822,8 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name -extractDecl name mdl decl +extractDecl :: Name -> LHsDecl Name -> LHsDecl Name +extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of @@ -812,11 +845,11 @@ extractDecl name mdl decl O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) + in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> - SigD <$> extractRecSel name mdl n tys (dd_cons defn) + SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) @@ -826,19 +859,19 @@ extractDecl name mdl decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] +extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name -extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" +extractRecSel _ _ _ [] = error "extractRecSel: selector not found" -extractRecSel nm mdl t tvs (L _ con : rest) = +extractRecSel nm t tvs (L _ con : rest) = case getConDetails con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) - _ -> extractRecSel nm mdl t tvs rest + _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds -- cgit v1.2.3 From 26879d9b4a2aba264a10812f2738d4db685d61d1 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 03:03:20 -0700 Subject: Add a field marking if interface is a signature or not. Signed-off-by: Edward Z. Yang (cherry picked from commit 930cfbe58e2e87f5a4d431d89a3c204934e6e858) --- haddock-api/src/Haddock/Interface/Create.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 6 ++++-- haddock-api/src/Haddock/Types.hs | 7 +++++++ 3 files changed, 12 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ff53fd3c..024cd02d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -132,6 +132,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl + , ifaceIsSig = Module.isHoleModule sem_mdl , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 0d000029..78853a79 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -372,9 +372,10 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap argMap + put_ bh (InstalledInterface modu is_sig info docMap argMap exps visExps opts subMap fixMap) = do put_ bh modu + put_ bh is_sig put_ bh info put_ bh docMap put_ bh argMap @@ -386,6 +387,7 @@ instance Binary InstalledInterface where get bh = do modu <- get bh + is_sig <- get bh info <- get bh docMap <- get bh argMap <- get bh @@ -395,7 +397,7 @@ instance Binary InstalledInterface where subMap <- get bh fixMap <- get bh - return (InstalledInterface modu info docMap argMap + return (InstalledInterface modu is_sig info docMap argMap exps visExps opts subMap fixMap) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 8addfa2f..a6dd6354 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -80,6 +80,9 @@ data Interface = Interface -- | The module behind this interface. ifaceMod :: !Module + -- | Is this a signature? + , ifaceIsSig :: !Bool + -- | Original file name of the module. , ifaceOrigFilename :: !FilePath @@ -157,6 +160,9 @@ data InstalledInterface = InstalledInterface -- | The module represented by this interface. instMod :: Module + -- | Is this a signature? + , instIsSig :: Bool + -- | Textual information about the module. , instInfo :: HaddockModInfo Name @@ -186,6 +192,7 @@ data InstalledInterface = InstalledInterface toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface { instMod = ifaceMod interface + , instIsSig = ifaceIsSig interface , instInfo = ifaceInfo interface , instDocMap = ifaceDocMap interface , instArgMap = ifaceArgMap interface -- cgit v1.2.3 From 4e6f4447caf61b6a91a483f30a15354cbf6cfc31 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:13:27 -0700 Subject: Documentation. Signed-off-by: Edward Z. Yang (cherry picked from commit 0671abfe7e8ceae2269467a30b77ed9d9656e2cc) --- haddock-api/src/Haddock/Interface/Create.hs | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 024cd02d..502d6599 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -11,6 +11,10 @@ -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable +-- +-- This module provides a single function 'createInterface', +-- which creates a Haddock 'Interface' from the typechecking +-- results 'TypecheckedModule' from GHC. ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where @@ -54,7 +58,11 @@ import HsDecls ( getConDetails ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface +createInterface :: TypecheckedModule + -> [Flag] -- Boolean flags + -> IfaceMap -- Locally processed modules + -> InstIfaceMap -- External, already installed interfaces + -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do let ms = pm_mod_summary . tm_parsed_module $ tm @@ -518,7 +526,7 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] + -> [LHsDecl Name] -- renamed source declarations -> Maps -> FixMap -> [SrcSpan] -- splice locations @@ -716,7 +724,7 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the declarations in A + -> [LHsDecl Name] -- ^ All the renamed declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> Maps @@ -765,8 +773,17 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] - -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +-- | Simplified variant of 'mkExportItems', where we can assume that +-- every locally defined declaration is exported; thus, we just +-- zip through the renamed declarations. +fullModuleContents :: DynFlags + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> Maps + -> FixMap + -> [SrcSpan] -- ^ Locations of all TH splices + -> [LHsDecl Name] -- ^ All the renamed declarations + -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where -- cgit v1.2.3 From f65966b2febe36c8aae8ebee13d3f12a63479e65 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:25:09 -0700 Subject: More docs. Signed-off-by: Edward Z. Yang (cherry picked from commit 3d77b373dd5807d5d956719dd7c849a11534fa6a) --- haddock-api/src/Haddock/Interface/Create.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 502d6599..f1043c03 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -92,6 +92,7 @@ createInterface tm flags modMap instIfaceMap = do | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 + -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ @@ -114,6 +115,8 @@ createInterface tm flags modMap instIfaceMap = do let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + -- The MAIN functionality: compute the export items which will + -- each be the actual documentation of this module. exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags @@ -352,6 +355,8 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. +-- A subordinate declaration is something like the associate type or data +-- family of a type class. subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do -- cgit v1.2.3 From 76d0b2b8ac2bfaa7983a9b5ea828f6caf8a6205d Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 15:33:25 -0700 Subject: TODO on moduleExports. Signed-off-by: Edward Z. Yang (cherry picked from commit 94610e9b446324f4231fa6ad4c6ac51e4eba8c0e) --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f1043c03..85401bfa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -551,7 +551,11 @@ mkExportItems lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t lookupExport (IEModuleContents (L _ m)) = - -- Pass in identity module, so we can look it up in index correctly + -- TODO: We could get more accurate reporting here if IEModuleContents + -- also recorded the actual names that are exported here. We CAN + -- compute this info using @gre@ but 'moduleExports does not seem to + -- do so. + -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr -- cgit v1.2.3 From 24694932de26645331eb53b016c84a6a5c171a97 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Tue, 14 Mar 2017 03:53:49 -0700 Subject: Better Backpack support with signature merging. When we merge signatures, we gain exports that don't necessarily have a source-level declaration corresponding to them. This meant Haddock dropped them. There are two big limitations: * If there's no export list, we won't report inherited signatures. * If the type has a subordinate, the current hiDecl implementation doesn't reconstitute them. These are probably worth fixing eventually, but this gets us to minimum viable functionality. Signed-off-by: Edward Z. Yang (cherry picked from commit 6cc832dfb1de6088a4abcaae62b25a7e944d55c3) --- haddock-api/src/Haddock/Interface/Create.hs | 46 +++++++++++++++++++++-------- 1 file changed, 34 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 85401bfa..e594feae 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -71,6 +71,7 @@ createInterface tm flags modMap instIfaceMap = do !safety = modInfoSafe mi mdl = ms_mod ms sem_mdl = tcg_semantic_mod (fst (tm_internals_ tm)) + is_sig = ms_hsc_src ms == HsigFile dflags = ms_hspp_opts ms !instances = modInfoInstances mi !fam_instances = md_fam_insts md @@ -117,7 +118,7 @@ createInterface tm flags modMap instIfaceMap = do -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems modMap mdl sem_mdl allWarnings gre exportedNames decls + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls maps fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -143,7 +144,7 @@ createInterface tm flags modMap instIfaceMap = do return $! Interface { ifaceMod = mdl - , ifaceIsSig = Module.isHoleModule sem_mdl + , ifaceIsSig = is_sig , ifaceOrigFilename = msHsFilePath ms , ifaceInfo = info , ifaceDoc = Documentation mbDoc modWarn @@ -525,7 +526,8 @@ collectDocs = go Nothing [] -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: IfaceMap + :: Bool -- is it a signature + -> IfaceMap -> Module -- this module -> Module -- semantic module -> WarningMap @@ -540,7 +542,7 @@ mkExportItems -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod semMod warnings gre exportedNames decls + is_sig modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls @@ -569,8 +571,9 @@ mkExportItems Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = - case findDecl t of + declWith t = do + r <- findDecl t + case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap @@ -649,13 +652,32 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n - | m == semMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) - | otherwise = ([], (noDocForDecl, [])) + | m == semMod = + case M.lookup n declMap of + Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Nothing + | is_sig -> do + -- OK, so it wasn't in the local declaration map. It could + -- have been inherited from a signature. Reconstitute it + -- from the type. + mb_r <- hiDecl dflags n + case mb_r of + Nothing -> return ([], (noDocForDecl, [])) + -- TODO: If we try harder, we might be able to find + -- a Haddock! Look in the Haddocks for each thing in + -- requirementContext (pkgState) + Just decl -> return ([decl], (noDocForDecl, [])) + | otherwise -> + return ([], (noDocForDecl, [])) + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + , Just ds <- M.lookup n (ifaceDeclMap iface) = + return (ds, lookupDocs n warnings + (ifaceDocMap iface) + (ifaceArgMap iface) + (ifaceSubMap iface)) + | otherwise = return ([], (noDocForDecl, [])) where m = nameModule n -- cgit v1.2.3 From e0ada1743cb722d2f82498a95b201f3ffb303137 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 11 Apr 2017 20:35:08 +0200 Subject: Read files for hyperlinker eagerly This also exposes Documentation.Haddock.Utf8 --- haddock-api/src/Haddock/Interface/Create.hs | 12 ++++++++---- haddock-library/haddock-library.cabal | 2 +- 2 files changed, 9 insertions(+), 5 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index e594feae..d2ad9294 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -19,6 +19,7 @@ module Haddock.Interface.Create (createInterface) where import Documentation.Haddock.Doc (metaDocAppend) +import Documentation.Haddock.Utf8 as Utf8 import Haddock.Types import Haddock.Options import Haddock.GhcUtils @@ -29,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List @@ -38,6 +40,7 @@ import Data.Ord import Control.Applicative import Control.Arrow (second) import Control.DeepSeq +import Control.Exception (evaluate) import Control.Monad import Data.Function (on) @@ -976,10 +979,11 @@ mkMaybeTokenizedSrc flags tm summary = pm_mod_summary . tm_parsed_module $ tm mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc ms src = - Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc - where - rawSrc = readFile $ msHsFilePath ms +mkTokenizedSrc ms src = do + -- make sure to read the whole file at once otherwise + -- we run out of file descriptors (see #495) + rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate + return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc)) -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index cabfbc67..4e355dd1 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -34,6 +34,7 @@ library Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Doc + Documentation.Haddock.Utf8 other-modules: Data.Attoparsec @@ -48,7 +49,6 @@ library Data.Attoparsec.Internal.Types Data.Attoparsec.Number Documentation.Haddock.Parser.Util - Documentation.Haddock.Utf8 test-suite spec type: exitcode-stdio-1.0 -- cgit v1.2.3 From b44676d9acd36b50a93aea6882751284d00013b6 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 11 Apr 2017 20:37:06 +0200 Subject: Explicit import list ofr Control.DeepSeq in Haddock.Interface.Create --- haddock-api/src/Haddock/Interface/Create.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d2ad9294..6ff1223c 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -39,7 +39,7 @@ import Data.Monoid import Data.Ord import Control.Applicative import Control.Arrow (second) -import Control.DeepSeq +import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Function (on) -- cgit v1.2.3 From c0b1d8b7dc6331efb62e05ad317af781069c13be Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Tue, 25 Apr 2017 11:33:10 +0200 Subject: Expand signatures for class declarations --- haddock-api/src/Haddock/Interface/Create.hs | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 6ff1223c..26ac0281 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -819,20 +819,30 @@ fullModuleContents :: DynFlags -> [LHsDecl Name] -- ^ All the renamed declarations -> ErrMsgGhc [ExportItem Name] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSig decls) + liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) where -- A type signature can have multiple names, like: -- foo, bar :: Types.. -- -- We go through the list of declarations and expand type signatures, so -- that every type signature has exactly one name! - expandSig :: [LHsDecl name] -> [LHsDecl name] - expandSig = foldr f [] + expandSigDecls :: [LHsDecl name] -> [LHsDecl name] + expandSigDecls = concatMap f where - f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names - f x xs = x : xs + f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] + + -- also expand type signatures for class methods + f (L l (TyClD cls@ClassDecl{})) = + [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ] + f x = [x] + + expandLSig :: LSig name -> [LSig name] + expandLSig (L l sig) = [ L l s | s <- expandSig sig ] + + expandSig :: Sig name -> [Sig name] + expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] + expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] + expandSig x = [x] mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do -- cgit v1.2.3 From 506f614402192bd7b6a9a608e925a01b373b2bdc Mon Sep 17 00:00:00 2001 From: Doug Wilson Date: Sun, 28 May 2017 05:54:53 +1200 Subject: Improve Syb code (#621) Specialize.hs and Ast.hs are modified to have their Syb code not recurse into Name or Id in HsSyn types. Specialize.hs is refactored to have fewer calls to Syb functions. Syb.hs has some foldl calls replaced with foldl' calls. There is still a lot of performance on the floor of Ast.hs. The RenamedSource is traversed many times, and lookupBySpan is very inefficient. everywhereBut and lookupBySpan dominate the runtime whenever --hyperlinked-source is passed. --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 28 ++++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 58 +++++++++------------- haddock-api/src/Haddock/Syb.hs | 55 +++++++++++++++++--- 3 files changed, 88 insertions(+), 53 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index b97f0ead..78beacf2 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -2,12 +2,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} - +{-# LANGUAGE TypeApplications #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where -import Haddock.Syb +import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC @@ -16,6 +16,9 @@ import Control.Applicative import Data.Data import Data.Maybe +everythingInRenamedSource :: (Alternative f, Data x) + => (forall a. Data a => a -> f r) -> x -> f r +everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f -- | Add more detailed information to token stream using GHC API. enrich :: GHC.RenamedSource -> [Token] -> [RichToken] @@ -53,7 +56,7 @@ enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). variables :: GHC.RenamedSource -> DetailsMap variables = - everything (<|>) (var `combine` rec) + everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of (Just (GHC.L sspan (GHC.HsVar name))) -> @@ -68,8 +71,7 @@ variables = -- | Obtain details map for types. types :: GHC.RenamedSource -> DetailsMap -types = - everything (<|>) ty +types = everythingInRenamedSource ty where ty term = case cast term of (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> @@ -81,9 +83,10 @@ types = -- That includes both identifiers bound by pattern matching or declared using -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses). + binds :: GHC.RenamedSource -> DetailsMap -binds = - everything (<|>) (fun `combine` pat `combine` tvar) +binds = everythingInRenamedSource + (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> @@ -93,7 +96,7 @@ binds = (Just (GHC.L sspan (GHC.VarPat name))) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everything (<|>) rec recs + [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -112,8 +115,8 @@ binds = decls :: GHC.RenamedSource -> DetailsMap decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) fun . GHC.hs_valds - , everything (<|>) (con `combine` ins) + , everythingInRenamedSource fun . GHC.hs_valds + , everythingInRenamedSource (con `Syb.combine` ins) ] where typ (GHC.L _ t) = case t of @@ -127,7 +130,8 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty con term = case cast term of (Just cdcl) -> - map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl + map decl (GHC.getConNames cdcl) + ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst @@ -149,7 +153,7 @@ decls (group, _, _, _) = concatMap ($ group) -- import lists. imports :: GHC.RenamedSource -> DetailsMap imports src@(_, imps, _, _) = - everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps + everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 28bbf305..8c28cd5a 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} - module Haddock.Interface.Specialize ( specializeInstHead ) where @@ -27,73 +27,66 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set - - --- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) - => Data a - => name -> HsType name -> a -> a -specialize name details = - everywhere $ mkT step - where - step (HsTyVar _ (L _ name')) | name == name' = details - step typ = typ - +import Data.Foldable -- | Instantiate all occurrences of given names with corresponding types. --- --- It is just a convenience function wrapping 'specialize' that supports more --- that one specialization. -specialize' :: (Eq name, Typeable name) +specialize :: forall name a. (Ord name, DataId name, NamedThing name) => Data a => [(name, HsType name)] -> a -> a -specialize' = flip $ foldr (uncurry specialize) +specialize specs = go + where + go :: forall x. Data x => x -> x + go = everywhereButType @name $ mkT $ sugar . specialize_ty_var + specialize_ty_var (HsTyVar _ (L _ name')) + | Just t <- Map.lookup name' spec_map = t + specialize_ty_var typ = typ + -- This is a tricky recursive definition that is guaranteed to terminate + -- because a type binder cannot be instantiated with a type that depends + -- on that binder. i.e. @a -> Maybe a@ is invalid + spec_map = Map.fromList [ (n, go t) | (n, t) <- specs] -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Eq name, DataId name) +specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name) => Data a => LHsQTyVars name -> [HsType name] -> a -> a specializeTyVarBndrs bndrs typs = - specialize' $ zip bndrs' typs + specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs bname (UserTyVar (L _ name)) = name bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Eq name, DataId name) +specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = - decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } - where - specializeTyVars = specializeTyVarBndrs bndrs typs - + decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Eq name, DataId name, SetName name) +specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ { hswc_body = (hswc_body typ) { hsib_body = noLoc typ'}}) + TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType name true_type = unLoc (hsSigWcType typ) typ' :: HsType name - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type + typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, DataId name, SetName name) +specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -115,12 +108,7 @@ specializeInstHead ihd = ihd -- and @(a, b, c)@. sugar :: forall name. (NamedThing name, DataId name) => HsType name -> HsType name -sugar = - everywhere $ mkT step - where - step :: HsType name -> HsType name - step = sugarOperators . sugarTuples . sugarLists - +sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing name => HsType name -> HsType name sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs index 4847e486..7e34ae8c 100644 --- a/haddock-api/src/Haddock/Syb.hs +++ b/haddock-api/src/Haddock/Syb.hs @@ -1,8 +1,11 @@ {-# LANGUAGE Rank2Types #-} - +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb - ( everything, everythingWithState, everywhere + ( everything, everythingButType, everythingWithState + , everywhere, everywhereButType , mkT , combine ) where @@ -10,16 +13,41 @@ module Haddock.Syb import Data.Data import Control.Applicative +import Data.Maybe +import Data.Foldable +-- | Returns true if a == t. +-- requires AllowAmbiguousTypes +isType :: forall a b. (Typeable a, Typeable b) => b -> Bool +isType _ = isJust $ eqT @a @b -- | Perform a query on each level of a tree. -- -- This is stolen directly from SYB package and copied here to not introduce -- additional dependencies. -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) +everything :: (r -> r -> r) + -> (forall a. Data a => a -> r) -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) +everything k f x = foldl' k (f x) (gmapQ (everything k f) x) + +-- | Variation of "everything" with an added stop condition +-- Just like 'everything', this is stolen from SYB package. +everythingBut :: (r -> r -> r) + -> (forall a. Data a => a -> (r, Bool)) + -> (forall a. Data a => a -> r) +everythingBut k f x = let (v, stop) = f x + in if stop + then v + else foldl' k v (gmapQ (everythingBut k f) x) +-- | Variation of "everything" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everythingButType :: + forall t r. (Typeable t) + => (r -> r -> r) + -> (forall a. Data a => a -> r) + -> (forall a. Data a => a -> r) +everythingButType k f = everythingBut k $ (,) <$> f <*> isType @t -- | Perform a query with state on each level of a tree. -- @@ -31,8 +59,7 @@ everythingWithState :: s -> (r -> r -> r) -> (forall a. Data a => a -> r) everythingWithState s k f x = let (r, s') = f x s - in foldl k r (gmapQ (everythingWithState s' k f) x) - + in foldl' k r (gmapQ (everythingWithState s' k f) x) -- | Apply transformation on each level of a tree. -- @@ -40,6 +67,22 @@ everythingWithState s k f x = everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) everywhere f = f . gmapT (everywhere f) +-- | Variation on everywhere with an extra stop condition +-- Just like 'everything', this is stolen from SYB package. +everywhereBut :: (forall a. Data a => a -> Bool) + -> (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereBut q f x + | q x = x + | otherwise = f (gmapT (everywhereBut q f) x) + +-- | Variation of "everywhere" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everywhereButType :: forall t . (Typeable t) + => (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereButType = everywhereBut (isType @t) + -- | Create generic transformation. -- -- Another function stolen from SYB package. -- cgit v1.2.3 From fdf1b017b07e12769a7ca605b41dc76842838855 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 30 May 2017 19:02:12 +0200 Subject: Make haddock-library and haddock-api warning free (#626) --- haddock-api/src/Haddock.hs | 12 ++++++------ haddock-api/src/Haddock/GhcUtils.hs | 4 ---- haddock-api/src/Haddock/Interface/Specialize.hs | 1 - haddock-library/src/Documentation/Haddock/Types.hs | 4 +++- 4 files changed, 9 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index f0e7e6c7..57ea5fea 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -398,12 +398,12 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do ghcLink = NoLink } let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs - defaultCleanupHandler dynflags'' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' + + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags'' + ghcActs dynflags'' where parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index c8e5ea8b..dcc1d834 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,17 +17,13 @@ module Haddock.GhcUtils where import Control.Arrow -import Data.Function import Exception import Outputable import Name import Lexeme import Module -import RdrName (GlobalRdrEnv) -import GhcMonad (withSession) import HscTypes -import UniqFM import GHC import Class diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 8c28cd5a..da8c3e7b 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -27,7 +27,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Foldable -- | Instantiate all occurrences of given names with corresponding types. specialize :: forall name a. (Ord name, DataId name, NamedThing name) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 4d5bb68a..660878ff 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types @@ -14,8 +14,10 @@ -- Exposes documentation data types used for (some) of Haddock. module Documentation.Haddock.Types where +#if !MIN_VERSION_base(4,8,0) import Data.Foldable import Data.Traversable +#endif -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- cgit v1.2.3 From bfb3563f730fd1c973a6611a0fba3435fb1df489 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Sat, 3 Jun 2017 20:37:28 +0200 Subject: Allow user defined signatures for pattern synonyms (#631) --- CHANGES.md | 2 ++ haddock-api/src/Haddock/GhcUtils.hs | 5 +++++ haddock-api/src/Haddock/Interface/Create.hs | 1 + html-test/ref/PatternSyns.html | 29 +++++++++++++++++++++++++++++ html-test/src/PatternSyns.hs | 5 +++++ 5 files changed, 42 insertions(+) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/CHANGES.md b/CHANGES.md index 6c2b5d32..95e1763a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,7 @@ ## Changes in version 2.18.0 + * Support user defined signatures on pattern synonyms + * Synopsis is working again (#599) ## Changes in version 2.17.4 diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index dcc1d834..4280cd80 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -88,6 +88,10 @@ filterSigNames p (ClassOpSig is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing filtered -> Just (ClassOpSig is_default filtered ty) +filterSigNames p (PatSynSig ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (PatSynSig filtered ty) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name @@ -110,6 +114,7 @@ sigNameNoLoc _ = [] isUserLSig :: LSig name -> Bool isUserLSig (L _(TypeSig {})) = True isUserLSig (L _(ClassOpSig {})) = True +isUserLSig (L _(PatSynSig {})) = True isUserLSig _ = False diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 26ac0281..98d4dbe8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -842,6 +842,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap expandSig :: Sig name -> [Sig name] expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] + expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] expandSig x = [x] mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 9f0caaa2..2cf936b3 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -118,6 +118,16 @@ window.onload = function () {pageLoad();}; > k a (b :: k). (><) k a b
  • pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex

    • pattern PatWithExplicitSig :: Eq somex => somex -> FooType somex #

    Earlier ghc versions didn't allow explicit signatures + on pattern synonyms.

    Quux a c (Quux a c b)) a c b0)) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    forall a. a -> a) -> (b, forall a. a -> [c]) -> (b, c) c0. c0 -> [c]) -> (b, c1) #

    forall b. (forall a. a -> [c]) -> c) -> b. b -> [c]) -> c0) -> forall a. a -> b c1. c1 -> b #

    baz :: (a -> b) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> a -> b) -> (b, c) c. c -> a -> b) -> (b0, c) #

    baz' :: b -> ( :: b0 -> (forall c. c -> a -> b) -> ( b1. b1 -> a -> b) -> (forall c. c -> a -> b) -> [(b, a -> b)] b2. b2 -> a -> b) -> [(b0, a -> b)] #

    baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> a -> b) -> c) -> b2. b2 -> a -> b) -> c) -> forall c. c -> b c. c -> b0 #

    baz :: (a, b, c) -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> (a, b, c)) -> (b, c) c0. c0 -> (a, b, c)) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> (a, b, c)) -> ( b1. b1 -> (a, b, c)) -> (forall d. d -> (a, b, c)) -> [(b, (a, b, c))] b2. b2 -> (a, b, c)) -> [(b0, (a, b, c))] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> (a, b, c)) -> c) -> b2. b2 -> (a, b, c)) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    baz :: (a, [b], b, a) -> (forall c. c -> c) -> (b, a0. a0 -> a0) -> (b0, forall c. c -> (a, [b], b, a)) -> (b, c) c. c -> (a, [b], b, a)) -> (b0, c) #

    baz' :: b -> ( :: b0 -> (forall c. c -> (a, [b], b, a)) -> ( b1. b1 -> (a, [b], b, a)) -> (forall c. c -> (a, [b], b, a)) -> [(b, (a, [b], b, a))] b2. b2 -> (a, [b], b, a)) -> [(b0, (a, [b], b, a))] #

    baz'' :: b -> ( :: b0 -> (forall c. ( b1. (forall d. d -> (a, [b], b, a)) -> c) -> b2. b2 -> (a, [b], b, a)) -> c) -> forall c. c -> b c. c -> b0 #

    Quux a b Int -> a -> -> a0 -> Quux a b a a b a0 #

    Quux a b (Quux a b a) -> a b a0) -> Int -> QuuxQuux a c (Quux a c b)) a c b0)) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c)) -> (Quux a c b, a c b0, Quux a c c) a c c0) #

    Quux a b c -> (forall d. d -> d) -> (b, a0. a0 -> a0) -> (b0, forall d. d -> c0. c0 -> Quux a b c) -> (b, c) a b c) -> (b0, c1) #

    baz' :: b -> ( :: b0 -> (forall d. d -> b1. b1 -> Quux a b c) -> (forall d. d -> b2. b2 -> Quux a b c) -> [(b, a b c) -> [(b0, Quux a b c)] #

    baz'' :: b -> ( :: b0 -> (forall d. ( b1. (forall e. e -> b2. b2 -> Quux a b c) -> c) -> a b c) -> c0) -> forall d. d -> b c1. c1 -> b0 #

    b) -> f a -> f b + +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) + +-- | Phantom type a0 is added to block the first renaming from a to a0. This ensures that the renamer doesn't create a new conflict +data ThreeVars a0 a b = ThreeVars a b + +instance Functor (ThreeVars a0 a) where + fmap f (ThreeVars a b) = ThreeVars a (f b) -- cgit v1.2.3 From 3fddb62913c72f29843335aa796c2e444ded1608 Mon Sep 17 00:00:00 2001 From: Tim Baumann Date: Sun, 6 Aug 2017 11:33:38 +0200 Subject: Fix: Generate pattern signatures for constructors exported as patterns (#663) * Fix pretty-printing of pattern signatures Pattern synonyms can have up to two contexts, both having a different semantic meaning: The first holds the constraints required to perform the matching, the second contains the constraints provided by a successful pattern match. When the first context is empty but the second is not it is necessary to render the first, empty context. * Generate pattern synonym signatures for ctors exported as patterns This fixes #653. * Simplify extractPatternSyn It is not necessary to generate the simplest type signature since it will be simplified when pretty-printed. * Add changelog entries for PR #663 * Fix extractPatternSyn error message --- CHANGES.md | 5 + haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 242 ++++++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 34 +++- haddock-api/src/Haddock/Types.hs | 6 + html-test/ref/ConstructorPatternExport.html | 124 +++++++++++++ html-test/ref/PatternSyns.html | 76 ++++++++ html-test/src/ConstructorPatternExport.hs | 26 +++ html-test/src/PatternSyns.hs | 8 +- 8 files changed, 412 insertions(+), 109 deletions(-) create mode 100644 html-test/ref/ConstructorPatternExport.html create mode 100644 html-test/src/ConstructorPatternExport.hs (limited to 'haddock-api/src/Haddock/Interface') diff --git a/CHANGES.md b/CHANGES.md index 5050339d..f96ac325 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,11 @@ * Move markup related data types to haddock-library + * Fix: Show empty constraint contexts in pattern type signatures (#663) + + * Fix: Generate constraint signatures for constructors exported as pattern + synonyms (#663) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index cda0611a..c78bee2d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -71,9 +71,9 @@ ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual + splice unicode qual HideEmptyContexts where - pp_typ = ppLType unicode qual typ + pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsSigType DocName -> @@ -87,20 +87,20 @@ ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html + Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = + splice unicode qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) - splice unicode qual + splice unicode qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -110,8 +110,8 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual + -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ @@ -132,14 +132,14 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) | null (unLoc lctxt) = do_largs n leader ltype | otherwise - = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] + = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = @@ -197,11 +197,11 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars splice unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual + splice unicode qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppLType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual ltype occ = nameOccName . getName $ name fixs | summary = noHtml @@ -220,14 +220,14 @@ ppTyName :: Name -> Html ppTyName = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocName -> Html -ppSimpleSig links splice unicode qual loc names typ = +ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual typ + ppTyp = ppType unicode qual emptyCtxts typ occNames = map getOccName names @@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs , tfe_pats = HsIB { hsib_body = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) @@ -377,7 +377,7 @@ ppAppDocNameTyVarBndrs summ unicode qual n vs = ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Unicode -> Qualification -> Html ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications @@ -398,32 +398,35 @@ ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html + -> Qualification -> HideEmptyContexts -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ - ppContextNoLocsMaybe (map unLoc cxt) unicode qual +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual emptyCtxts -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html -ppContextNoLocsMaybe [] _ _ = Nothing -ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html +ppContextNoLocsMaybe [] _ _ emptyCtxts = + case emptyCtxts of + HideEmptyContexts -> Nothing + ShowEmptyToplevelContexts -> Just (toHtml "()") +ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html -ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual +ppContext :: HsContext DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml +ppHsContext :: [HsType DocName] -> Unicode -> Qualification -> Html +ppHsContext [] _ _ = noHtml ppHsContext [p] unicode qual = ppCtxType unicode qual p -ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) ------------------------------------------------------------------------------- @@ -436,7 +439,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -592,7 +595,7 @@ ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> - ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc , [subInstDetails iid ats sigs] ) @@ -607,7 +610,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = where ptype = keyword "type" <+> typ prhs = ptype <+> maybe noHtml - (\t -> equals <+> ppType unicode qual t) rhs + (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs DataInst dd -> ( subInstHead iid pdata , mdoc @@ -636,9 +639,9 @@ ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ - -- Instance methods signatures are synified and thus don't have a useful + -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -698,7 +701,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] | (SigD (PatSynSig lnames typ),_) <- pats ] @@ -744,7 +747,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] <+> ppFixities subfixs qual ,combineDocumentation (fst d), []) | (SigD (PatSynSig lnames typ),d) <- pats @@ -769,17 +772,17 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual) args), noHtml, noHtml) + : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppOccInfix, ppLParendType unicode qual arg2], + (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, + ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) where resTy = hsib_body (con_type con) @@ -811,7 +814,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual + else ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode +++ toHtml " ") where ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) @@ -827,15 +830,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual) args) + : map (ppLParendType unicode qual HideEmptyContexts) args) <+> fixity RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, + hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, ppOccInfix, - ppLParendType unicode qual arg2] + ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity ConDeclGADT{} -> doGADTCon resTy @@ -852,7 +855,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) doGADTCon :: Located (HsType DocName) -> Html doGADTCon ty = ppOcc <+> dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual ty + <+> ppLType unicode qual HideEmptyContexts ty <+> fixity fixity = ppFixities fixities qual @@ -879,9 +882,12 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) + ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts ltype + , mbDoc + , [] + ) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation @@ -891,7 +897,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html ppShortField summary unicode qual (ConDeclField names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode qual ltype + <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -- | Print the LHS of a data\/newtype declaration. @@ -906,7 +912,7 @@ ppDataHeader summary decl@(DataDecl { tcdDataDefn = (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext ctxt unicode qual <+> + ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b ppDataBinderWithVars summary unicode qual decl <+> case ks of @@ -958,19 +964,18 @@ maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html -ppLType unicode qual y = ppType unicode qual (unLoc y) -ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) -ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocName) -> Html +ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) +ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) +ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppCtxType :: Unicode -> Qualification -> HsType DocName -> Html +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts -ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html -ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual -ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual -ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocName -> Html +ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = @@ -983,62 +988,85 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocName -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts + +ppPatSigType :: Unicode -> Qualification -> LHsType DocName -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = + if hasNonEmptyContext typ && isFirstContextEmpty typ + then ShowEmptyToplevelContexts + else HideEmptyContexts + in ppLType unicode qual emptyCtxts typ + where + hasNonEmptyContext :: LHsType name -> Bool + hasNonEmptyContext t = + case unLoc t of + HsForAllTy _ s -> hasNonEmptyContext s + HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ s -> hasNonEmptyContext s + _ -> False + isFirstContextEmpty :: LHsType name -> Bool + isFirstContextEmpty t = + case unLoc t of + HsForAllTy _ s -> isFirstContextEmpty s + HsQualTy cxt _ -> null (unLoc cxt) + HsFunTy _ s -> isFirstContextEmpty s + _ -> False ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual +ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual + ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q -ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) -ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q = - parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q -ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" +ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e +ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q e = + parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts +ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. @@ -1047,25 +1075,25 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts -- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b9179d11..89f7f71b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -985,7 +985,9 @@ extractDecl name decl O.$$ O.nest 4 (O.ppr matches)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + in if isDataConName name + then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n , dfid_pats = HsIB { hsib_body = tys } , dfid_defn = defn }) -> @@ -1003,6 +1005,36 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" +extractPatternSyn :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> error "extractPatternSyn: constructor pattern not found" + con:_ -> extract <$> con + where + matches :: LConDecl Name -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl Name -> Sig Name + extract con = + let args = + case getConDetails con of + PrefixCon args' -> args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> [arg1, arg2] + typ = longArrow args (data_ty con) + typ' = + case con of + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + _ -> typ + typ'' = noLoc (HsQualTy (noLoc []) typ') + in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + + longArrow :: [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + + data_ty con + | ConDeclGADT{} <- con = hsib_body $ con_type con + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] -> LSig Name extractRecSel _ _ _ [] = error "extractRecSel: selector not found" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index de599bd8..724f59bc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -579,6 +579,12 @@ makeModuleQual qual aliases mdl = OptFullQual -> FullQual OptNoQual -> NoQual +-- | Whether to hide empty contexts +-- Since pattern synonyms have two contexts with different semantics, it is +-- important to all of them, even if one of them is empty. +data HideEmptyContexts + = HideEmptyContexts + | ShowEmptyToplevelContexts ----------------------------------------------------------------------------- -- * Error handling diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html new file mode 100644 index 00000000..20f00d0f --- /dev/null +++ b/html-test/ref/ConstructorPatternExport.html @@ -0,0 +1,124 @@ +ConstructorPatternExport
    Safe HaskellSafe

    ConstructorPatternExport

    Documentation

    pattern FooCons :: String -> a -> Foo a #

    pattern MyRecCons :: Bool -> Int -> MyRec #

    pattern (:+) :: String -> a -> MyInfix a #

    pattern BlubCons :: () => Show b => b -> Blub #

    pattern MyGADTCons :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) #

    \ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 2cf936b3..37596645 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -99,6 +99,28 @@ window.onload = function () {pageLoad();}; >FooType x1))
  • data BlubType = Show x => BlubCtor x
  • pattern Blub :: () => forall x. Show x => x -> BlubType
  • data (a ::

    data BlubType #

    BlubType is existentially quantified

    Constructors

    Show x => BlubCtor x

    pattern Blub :: () => forall x. Show x => x -> BlubType #

    Pattern synonym for Blub x

    data BlubCons b + +data MyGADT :: * -> * where + MyGADTCons :: forall a. Eq a => a -> Int -> MyGADT (Maybe String) + +pattern MyGADTCons' :: () => forall a. Eq a => a -> Int -> MyGADT (Maybe String) +pattern MyGADTCons' x y = MyGADTCons x y \ No newline at end of file diff --git a/html-test/src/PatternSyns.hs b/html-test/src/PatternSyns.hs index a8de113c..bf0f7848 100644 --- a/html-test/src/PatternSyns.hs +++ b/html-test/src/PatternSyns.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternSynonyms, PolyKinds, TypeOperators #-} +{-# LANGUAGE ExistentialQuantification, PatternSynonyms, PolyKinds, TypeOperators #-} -- | Testing some pattern synonyms module PatternSyns where @@ -15,6 +15,12 @@ pattern Bar x = FooCtor (Foo x) -- | Pattern synonym for (':<->') pattern x :<-> y = (Foo x, Bar y) +-- | BlubType is existentially quantified +data BlubType = forall x. Show x => BlubCtor x + +-- | Pattern synonym for 'Blub' x +pattern Blub x = BlubCtor x + -- | Doc for ('><') data (a :: *) >< b = Empty -- cgit v1.2.3 From f1d326b53fbed5d37f2a83c66e73dbbc94a4354f Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 6 Aug 2017 13:18:02 +0200 Subject: Provide --show-interface option to dump interfaces (#645) * WIP: Provide --show-interface option to dump interfaces Like ghcs own --show-iface this flag dumps a binary interface file to stdout in a human (and machine) readable fashion. Currently it uses json as output format. * Fill all the jsonNull stubs * Rework Bifunctor instance of DocH, update changelog and documentation * replace changelog, bring DocMarkupH doc back * Update CHANGES.md * Update CHANGES.md * Move Control.Arrow up It would result in unused import if the Bifunctor instance is not generated. --- doc/invoking.rst | 5 + haddock-api/haddock-api.cabal | 1 + haddock-api/src/Haddock.hs | 7 ++ haddock-api/src/Haddock/Interface/Json.hs | 109 +++++++++++++++++++++ haddock-api/src/Haddock/Options.hs | 6 ++ haddock-library/CHANGES.md | 6 ++ haddock-library/src/Documentation/Haddock/Types.hs | 33 ++++++- haddock.cabal | 1 + 8 files changed, 167 insertions(+), 1 deletion(-) create mode 100644 haddock-api/src/Haddock/Interface/Json.hs (limited to 'haddock-api/src/Haddock/Interface') diff --git a/doc/invoking.rst b/doc/invoking.rst index 83087bac..fc1e4410 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -88,6 +88,11 @@ The following options are available: :option:`--read-interface` option for more details. The interface file is in a binary format; don't try to read it. +.. option:: --show-interface= + + Dumps a binary interface file to stdout in a human readable fashion. + Uses json as output format. + .. [1] Haddock interface files are not the same as Haskell interface files, I just couldn't think of a better name. diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index ef4bb98c..d38e9149 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -73,6 +73,7 @@ library Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances + Haddock.Interface.Json Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Interface.Specialize diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 57ea5fea..554cb416 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -32,6 +32,7 @@ import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface +import Haddock.Interface.Json import Haddock.Parser import Haddock.Types import Haddock.Version @@ -68,6 +69,7 @@ import System.Directory (doesDirectoryExist) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) +import ErrUtils import Packages import Panic (handleGhcException) import Module @@ -164,6 +166,11 @@ haddockWithGhc ghc args = handleTopExceptions $ do dflags <- getDynFlags + forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + forM_ mIfaceFile $ \(_, ifaceFile) -> do + putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs new file mode 100644 index 00000000..9a569204 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RecordWildCards #-} +module Haddock.Interface.Json ( + jsonInstalledInterface + , jsonInterfaceFile + , renderJson + ) where + +import BasicTypes +import Json +import Module +import Name +import Outputable + +import Control.Arrow +import Data.Map (Map) +import Data.Bifunctor +import qualified Data.Map as Map + +import Haddock.Types +import Haddock.InterfaceFile + +jsonInterfaceFile :: InterfaceFile -> JsonDoc +jsonInterfaceFile InterfaceFile{..} = + jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv) + , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces)) + ] + +jsonInstalledInterface :: InstalledInterface -> JsonDoc +jsonInstalledInterface InstalledInterface{..} = jsonObject properties + where + properties = + [ ("module" , jsonModule instMod) + , ("is_sig" , jsonBool instIsSig) + , ("info" , jsonHaddockModInfo instInfo) + , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap) + , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap) + , ("exports" , jsonArray (map jsonName instExports)) + , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) + , ("options" , jsonArray (map (jsonString . show) instOptions)) + , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap) + , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap) + , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) + ] + +jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc +jsonHaddockModInfo HaddockModInfo{..} = + jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description) + , ("copyright" , jsonMaybe jsonString hmi_copyright) + , ("maintainer" , jsonMaybe jsonString hmi_maintainer) + , ("stability" , jsonMaybe jsonString hmi_stability) + , ("protability" , jsonMaybe jsonString hmi_portability) + , ("safety" , jsonMaybe jsonString hmi_safety) + , ("language" , jsonMaybe (jsonString . show) hmi_language) + , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions)) + ] + +jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc +jsonMap f g = jsonObject . map (f *** g) . Map.toList + +jsonMDoc :: MDoc Name -> JsonDoc +jsonMDoc MetaDoc{..} = + jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) + , ("doc", jsonDoc _doc) + ] + +jsonDoc :: Doc Name -> JsonDoc +jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) + +jsonModule :: Module -> JsonDoc +jsonModule = JSString . moduleStableString + +jsonName :: Name -> JsonDoc +jsonName = JSString . nameStableString + +jsonFixity :: Fixity -> JsonDoc +jsonFixity (Fixity _ prec dir) = + jsonObject [ ("prec" , jsonInt prec) + , ("direction" , jsonFixityDirection dir) + ] + +jsonFixityDirection :: FixityDirection -> JsonDoc +jsonFixityDirection InfixL = jsonString "infixl" +jsonFixityDirection InfixR = jsonString "infixr" +jsonFixityDirection InfixN = jsonString "infix" + +renderJson :: JsonDoc -> SDoc +renderJson = renderJSON + +jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc +jsonMaybe = maybe jsonNull + +jsonString :: String -> JsonDoc +jsonString = JSString + +jsonObject :: [(String, JsonDoc)] -> JsonDoc +jsonObject = JSObject + +jsonArray :: [JsonDoc] -> JsonDoc +jsonArray = JSArray + +jsonNull :: JsonDoc +jsonNull = JSNull + +jsonInt :: Int -> JsonDoc +jsonInt = JSInt + +jsonBool :: Bool -> JsonDoc +jsonBool = JSBool + diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 0449c829..d73d1a79 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -25,6 +25,7 @@ module Haddock.Options ( sourceUrls, wikiUrls, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, @@ -53,6 +54,7 @@ data Flag -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -112,6 +114,8 @@ options backwardsCompat = "read an interface from FILE", Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") "write the resulting interface to FILE", + Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE") + "print the interface in a human readable form", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) @@ -270,6 +274,8 @@ wikiUrls flags = optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath +optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index bebb9982..c52908e1 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,9 @@ +## Changes in version 1.4.6 + + * to be released + + * Bifunctor instance for DocH + ## Changes in version 1.4.5 * Move markup related data types to haddock-library diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 0ab6bb4c..22cab425 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -19,6 +19,11 @@ import Data.Foldable import Data.Traversable #endif +#if MIN_VERSION_base(4,8,0) +import Control.Arrow ((***)) +import Data.Bifunctor +#endif + -- | With the advent of 'Version', we may want to start attaching more -- meta-data to comments. We make a structure for this ahead of time -- so we don't have to gut half the core each time we want to add such @@ -81,6 +86,33 @@ data DocH mod id | DocHeader (Header (DocH mod id)) deriving (Eq, Show, Functor, Foldable, Traversable) +#if MIN_VERSION_base(4,8,0) +instance Bifunctor DocH where + bimap _ _ DocEmpty = DocEmpty + bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB) + bimap _ _ (DocString s) = DocString s + bimap f g (DocParagraph doc) = DocParagraph (bimap f g doc) + bimap _ g (DocIdentifier i) = DocIdentifier (g i) + bimap f _ (DocIdentifierUnchecked m) = DocIdentifierUnchecked (f m) + bimap _ _ (DocModule s) = DocModule s + bimap f g (DocWarning doc) = DocWarning (bimap f g doc) + bimap f g (DocEmphasis doc) = DocEmphasis (bimap f g doc) + bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) + bimap f g (DocBold doc) = DocBold (bimap f g doc) + bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs) + bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs) + bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) + bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) + bimap _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap _ _ (DocPic picture) = DocPic picture + bimap _ _ (DocMathInline s) = DocMathInline s + bimap _ _ (DocMathDisplay s) = DocMathDisplay s + bimap _ _ (DocAName s) = DocAName s + bimap _ _ (DocProperty s) = DocProperty s + bimap _ _ (DocExamples examples) = DocExamples examples + bimap f g (DocHeader (Header level title)) = DocHeader (Header level (bimap f g title)) +#endif + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). @@ -114,4 +146,3 @@ data DocMarkupH mod id a = Markup , markupExample :: [Example] -> a , markupHeader :: Header a -> a } - diff --git a/haddock.cabal b/haddock.cabal index 36c80f33..5ae3443c 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -106,6 +106,7 @@ executable haddock Documentation.Haddock Haddock Haddock.Interface + Haddock.Interface.Json Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances -- cgit v1.2.3 From f7032e5e48c7a6635e1dca607a37a16c8893e94b Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 16 Aug 2017 09:06:40 +0200 Subject: Refactoring: Make doc renaming monadic This allows us to later throw warnings if can't find an identifier --- haddock-api/src/Haddock/Interface/Create.hs | 127 ++++++++++++--------- haddock-api/src/Haddock/Interface/LexParseRn.hs | 81 ++++++------- haddock-library/src/Documentation/Haddock/Types.hs | 3 + 3 files changed, 116 insertions(+), 95 deletions(-) (limited to 'haddock-api/src/Haddock/Interface') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 89f7f71b..87cdb01f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -30,6 +30,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) @@ -38,8 +39,6 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative -import Control.Arrow (second) -import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Traversable @@ -109,7 +108,6 @@ createInterface tm flags modMap instIfaceMap = do exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames localBundledPatSyns :: Map Name [Name] localBundledPatSyns = @@ -134,8 +132,10 @@ createInterface tm flags modMap instIfaceMap = do -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - maps@(!docMap, !argMap, !subMap, !declMap, _) = - mkMaps dflags gre localInsts declsWithDocs + warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) + + maps@(!docMap, !argMap, !subMap, !declMap, _) <- + liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) @@ -161,7 +161,8 @@ createInterface tm flags modMap instIfaceMap = do let !aliases = mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings + + modWarn <- liftErrMsg (moduleWarning dflags gre warnings) tokenizedSrc <- mkMaybeTokenizedSrc flags tm @@ -245,27 +246,29 @@ lookupModuleDyn dflags Nothing mdlName = -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> M.empty - WarnAll _ -> M.empty + NoWarnings -> pure M.empty + WarnAll _ -> pure M.empty WarnSome ws -> - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + let ws' = [ (n, w) + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] - in M.fromList $ map (second $ parseWarning dflags gre) ws' + in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) -moduleWarning _ _ NoWarnings = Nothing -moduleWarning _ _ (WarnSome _) = Nothing -moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning _ _ NoWarnings = pure Nothing +moduleWarning _ _ (WarnSome _) = pure Nothing +moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name -parseWarning dflags gre w = force $ case w of +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning dflags gre w = case w of DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . processDocString dflags gre $ HsDocString xs + <$> processDocString dflags gre (HsDocString xs) ------------------------------------------------------------------------------- @@ -313,16 +316,15 @@ mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] -> [(LHsDecl Name, [HsDocString])] - -> Maps -mkMaps dflags gre instances decls = - let - (a, b, c, d) = unzip4 $ map mappings decls - in ( f' (map (nubByName fst) a) - , f (filterMapping (not . M.null) b) - , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) - , instanceMap - ) + -> ErrMsgM Maps +mkMaps dflags gre instances decls = do + (a, b, c, d) <- unzip4 <$> traverse mappings decls + pure ( f' (map (nubByName fst) a) + , f (filterMapping (not . M.null) b) + , f (filterMapping (not . null) c) + , f (filterMapping (not . null) d) + , instanceMap + ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -334,35 +336,42 @@ mkMaps dflags gre instances decls = filterMapping p = map (filter (p . snd)) mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] - ) - mappings (ldecl, docStrs) = + -> ErrMsgM ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = do let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (MDoc Name), Map Int (MDoc Name)) - declDoc strs m = - let doc' = processDocStrings dflags gre strs - m' = M.map (processDocStringParas dflags gre) m - in (doc', m') - (doc, args) = declDoc docStrs (typeDocs decl) + -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) + declDoc strs m = do + doc' <- processDocStrings dflags gre strs + m' <- traverse (processDocStringParas dflags gre) m + pure (doc', m') + + (doc, args) <- declDoc docStrs (typeDocs decl) + + let subs :: [(Name, [HsDocString], Map Int HsDocString)] subs = subordinates instanceMap decl - (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + + (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs + + let ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - in seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - (dm, am, sm, cm) + + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + pure (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] @@ -602,16 +611,20 @@ mkExportItems -- do so. -- NB: Pass in identity module, so we can look it up in index correctly moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = return $ - return . ExportGroup lev "" $ processDocString dflags gre docStr + lookupExport (IEGroup lev docStr) = liftErrMsg $ do + doc <- processDocString dflags gre docStr + return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = return $ - return . ExportDoc $ processDocStringParas dflags gre docStr + lookupExport (IEDoc docStr) = liftErrMsg $ do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] lookupExport (IEDocNamed str) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= return . \case - Nothing -> [] - Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + findNamedDoc str [ unL d | d <- decls ] >>= \case + Nothing -> return [] + Just docStr -> do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] declWith pats t = do @@ -924,9 +937,11 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + doc <- liftErrMsg (processDocString dflags gre docStr) + return . Just . ExportGroup lev "" $ doc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr + doc <- liftErrMsg (processDocStringParas dflags gre docStr) + return . Just . ExportDoc $ doc mkExportItem (L l (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 4f6b2c09..a38e7667 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,20 +34,21 @@ import RdrName import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] - -> Maybe (MDoc Name) -processDocStrings dflags gre strs = - case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -> ErrMsgM (Maybe (MDoc Name)) +processDocStrings dflags gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs + case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing - x -> Just x + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags gre (HsDocString fs) = - overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) + overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) @@ -60,9 +61,11 @@ processModuleHeader dflags gre safety mayStr = do Just (L _ (HsDocString fs)) -> do let str = unpackFS fs (hmi, doc) = parseModuleHeader dflags str - !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = overDoc (rename dflags gre) doc + !descr <- case hmi_description hmi of + Just hmi_descr -> Just <$> rename dflags gre hmi_descr + Nothing -> pure Nothing + let hmi' = hmi { hmi_description = descr } + doc' <- overDocF (rename dflags gre) doc return (hmi', Just doc') let flags :: [LangExt.Extension] @@ -82,12 +85,12 @@ processModuleHeader dflags gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) + DocAppend a b -> DocAppend <$> rn a <*> rn b + DocParagraph doc -> DocParagraph <$> rn doc DocIdentifier x -> do -- Generate the choices for the possible kind of thing this -- is. @@ -100,7 +103,7 @@ rename dflags gre = rn -- We found no names in the env so we start guessing. [] -> case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) + [] -> pure (DocMonospaced (DocString (showPpr dflags x))) -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default @@ -109,37 +112,37 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> pure (outOfScope dflags a) -- There is only one name in the environment that matches so -- use it. - [a] -> DocIdentifier a + [a] -> pure (DocIdentifier a) -- But when there are multiple names available, default to -- type constructors: somewhat awfully GHC returns the -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b + a:b:_ | isTyConName a -> pure (DocIdentifier a) + | otherwise -> pure (DocIdentifier b) - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) + DocWarning doc -> DocWarning <$> rn doc + DocEmphasis doc -> DocEmphasis <$> rn doc + DocBold doc -> DocBold <$> rn doc + DocMonospaced doc -> DocMonospaced <$> rn doc + DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverse rn docs + DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list + DocCodeBlock doc -> DocCodeBlock <$> rn doc + DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) + DocModule str -> pure (DocModule str) + DocHyperlink l -> pure (DocHyperlink l) + DocPic str -> pure (DocPic str) + DocMathInline str -> pure (DocMathInline str) + DocMathDisplay str -> pure (DocMathDisplay str) + DocAName str -> pure (DocAName str) + DocProperty p -> pure (DocProperty p) + DocExamples e -> pure (DocExamples e) + DocEmpty -> pure (DocEmpty) + DocString str -> pure (DocString str) + DocHeader (Header l t) -> DocHeader . Header l <$> rn t -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 48b29075..1e76c631 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -56,6 +56,9 @@ instance Bitraversable MetaDoc where overDoc :: (DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d overDoc f d = d { _doc = f $ _doc d } +overDocF :: Functor f => (DocH a b -> f (DocH c d)) -> MetaDoc a b -> f (MetaDoc c d) +overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) + type Version = [Int] data Hyperlink = Hyperlink -- cgit v1.2.3