From 6319cccbd95ba15db6f34101577034233cdc8f88 Mon Sep 17 00:00:00 2001 From: David Waern Date: Thu, 16 Oct 2008 20:58:42 +0000 Subject: Fix #61 We were not getting docs for re-exported class methods. This was because we were looking up the docs in a map made from the declarations in the current module being rendered. Obviously, re-exported class methods come from another module. Class methods and ATs were the only thing we were looking up using the doc map, everything else we found in the ExporItems. So now I've put subordinate docs in the ExportItem's directly, to make things a bit more consistent. To do this, I added subordinates to the the declarations in the declaration map. This was easy since we were computing subordinates anyway, to store stand-alone in the map. I added a new type synonym 'DeclInfo', which is what we call what is now stored in the map. This little refactoring removes duplicate code to retrieve subordinates and documentation from the HsGroup. --- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/Html.hs | 42 +++++------ src/Haddock/DocName.hs | 1 + src/Haddock/Interface/AttachInstances.hs | 4 +- src/Haddock/Interface/Create.hs | 87 +++++++++++---------- src/Haddock/Interface/Rename.hs | 16 +++- src/Haddock/Types.hs | 3 + tests/tests/Hidden.hs | 2 + tests/tests/Ticket61.hs | 3 + tests/tests/Ticket61.html.ref | 125 +++++++++++++++++++++++++++++++ tests/tests/Ticket61_Hidden.hs | 7 ++ 11 files changed, 226 insertions(+), 66 deletions(-) create mode 100644 tests/tests/Ticket61.hs create mode 100644 tests/tests/Ticket61.html.ref create mode 100644 tests/tests/Ticket61_Hidden.hs diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 684d4294..dfd72758 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -81,7 +81,7 @@ operator x = x -- How to print each export ppExport :: ExportItem Name -> [String] -ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl) +ppExport (ExportDecl decl dc _ _) = doc dc ++ f (unL decl) where f (TyClD d@TyData{}) = ppData d f (TyClD d@ClassDecl{}) = ppClass d diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index 1f685c3d..579d7896 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -553,7 +553,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface exports = numberSectionHeadings (ifaceRnExportItems iface) - has_doc (ExportDecl _ doc _) = isJust doc + has_doc (ExportDecl _ doc _ _) = isJust doc has_doc (ExportNoDecl _ _ _) = False has_doc (ExportModule _) = False has_doc _ = True @@ -630,8 +630,8 @@ numberSectionHeadings exports = go 1 exports processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable processExport _ _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links docMap (ExportDecl decl doc insts) - = ppDecl summary links decl doc insts docMap +processExport summary links docMap (ExportDecl decl doc subdocs insts) + = ppDecl summary links decl doc insts docMap subdocs processExport summmary _ _ (ExportNoDecl _ y []) = declBox (ppDocName y) processExport summmary _ _ (ExportNoDecl _ y subs) @@ -660,9 +660,10 @@ declWithDoc False links loc nm (Just doc) html_decl = topDeclBox links loc nm html_decl docBox (docToHtml doc) +-- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable -ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of + Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, HsDoc DocName)] -> HtmlTable +ppDecl summ links (L loc decl) mbDoc instances docMap subdocs = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d TyClD d@(TyData {}) | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d @@ -670,7 +671,7 @@ ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of TyClD d@(TySynonym {}) | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap d + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap subdocs d SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t ForD d -> ppFor summ links loc mbDoc d InstD d -> Html.emptyTable @@ -872,13 +873,11 @@ ppTyInstHeader summary associated decl = -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocMap -> LTyClDecl DocName -> HtmlTable -ppAssocType summ links docMap (L loc decl) = +ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> HtmlTable +ppAssocType summ links doc (L loc decl) = case decl of TyFamily {} -> ppTyFam summ True links loc doc decl TySynonym {} -> ppTySyn summ links loc doc decl - where - doc = Map.lookup (docNameOrig $ tcdName decl) docMap -------------------------------------------------------------------------------- @@ -970,8 +969,8 @@ ppFds fds = fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+> hsep (map ppDocName vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> DocMap -> HtmlTable -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc docMap = +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, HsDoc DocName)] -> HtmlTable +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs = if null sigs && null ats then (if summary then declBox else topDeclBox links loc nm) hdr else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") @@ -980,12 +979,12 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc bodyBox << aboves ( - map (ppAssocType summary links docMap) ats ++ + [ ppAssocType summary links doc at | at <- ats + , let doc = lookup (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc mbDoc n typ + [ ppFunSig summary links loc doc n typ | L _ (TypeSig (L _ n) (L _ typ)) <- sigs - , let mbDoc = Map.lookup (docNameOrig n) docMap ] - + , let doc = lookup n subdocs ] ) ) where @@ -995,11 +994,11 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan -> - Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + Maybe (HsDoc DocName) -> DocMap -> [(DocName, HsDoc DocName)] -> TyClDecl DocName -> HtmlTable -ppClassDecl summary links instances loc mbDoc docMap +ppClassDecl summary links instances loc mbDoc docMap subdocs decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) - | summary = ppShortClassDecl summary links decl loc docMap + | summary = ppShortClassDecl summary links decl loc subdocs | otherwise = classheader bodyBox << (classdoc body instancesBit) where classheader @@ -1024,9 +1023,10 @@ ppClassDecl summary links instances loc mbDoc docMap methodTable = abovesSep s8 [ ppFunSig summary links loc doc n typ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs - , let doc = Map.lookup (docNameOrig n) docMap ] + , let doc = lookup n subdocs ] - atTable = abovesSep s8 $ map (ppAssocType summary links docMap) ats + atTable = abovesSep s8 $ [ ppAssocType summary links doc at | at <- ats + , let doc = lookup (tcdName $ unL at) subdocs ] instId = collapseId (docNameOrig nm) instancesBit diff --git a/src/Haddock/DocName.hs b/src/Haddock/DocName.hs index dfb21c0f..959d028b 100644 --- a/src/Haddock/DocName.hs +++ b/src/Haddock/DocName.hs @@ -16,6 +16,7 @@ import Binary data DocName = Documented Name Module | Undocumented Name + deriving Eq docNameOcc :: DocName -> OccName diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 636a5149..1454bdfc 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -43,9 +43,9 @@ attachInstances modules filterNames = map attach modules where newItems = map attachExport (ifaceExportItems mod) - attachExport (ExportDecl decl@(L _ (TyClD d)) doc _) + attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) | isClassDecl d || isDataDecl d || isFamilyDecl d = - ExportDecl decl doc (case Map.lookup (tcdName d) instMap of + ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of Nothing -> [] Just instheads -> instheads) attachExport export = export diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 5932bc64..9d0995e6 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -54,21 +54,21 @@ createInterface ghcMod flags modMap = do exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) localNames = ghcDefinedNames ghcMod subMap = mkSubMap group - decls = topDecls group - decls' = filterOutInstances decls - declMap = mkDeclMap decls' + decls0 = declInfos . topDecls $ group + decls = filterOutInstances decls0 + declMap = mkDeclMap decls -- famMap = mkFamMap decls' ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod instances = ghcInstances ghcMod - warnAboutFilteredDecls mod decls + warnAboutFilteredDecls mod decls0 visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope ghcMod) subMap exports opts declMap - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls' declMap + exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap subMap opts exports ignoreExps instances -- prune the export list to just those declarations that have @@ -137,20 +137,22 @@ type DeclWithDoc = (Decl, Maybe Doc) -- type Family = (Maybe DeclWithDoc, [DeclWithDoc]) --- | Make a map from names to declarations with documentation. The map excludes --- all kinds of instance declarations (including type family instances) and --- documentation declarations. --- Subordinate names are mapped to the parent declaration, but with the doc --- for the subordinate declaration. -mkDeclMap :: [(Decl, Maybe Doc)] -> Map Name DeclInfo +-- Make a map from names to 'DeclInfo's. Exclude declarations that don't +-- have names (instances and stand-alone documentation comments). Include +-- subordinate names, but map them to their parent declarations. +mkDeclMap :: [DeclInfo] -> Map Name DeclInfo mkDeclMap decls = Map.fromList . concat $ [ (declName d, (parent, doc, subs)) : subDecls - | (parent@(L loc d), doc) <- decls - , let subs = subordinates d + | (parent@(L _ d), doc, subs) <- decls , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] , not (isDocD d), not (isInstD d) ] +declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo] +declInfos decls = [ (parent, doc, subordinates d) + | (parent@(L _ d), doc) <- decls] + + -- | Group type family instances together. Include the family declaration -- if found. {-mkFamMap :: [DeclWithDoc] -> Map Name Family @@ -170,15 +172,18 @@ subordinates _ = [] classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)] classDataSubs decl - | isClassDecl decl = classMeths - | isDataDecl decl = recordFields + | isClassDecl decl = classSubs + | isDataDecl decl = dataSubs | otherwise = [] where - classMeths = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ] - recordFields = [ (unLoc lname, fmap unLoc doc) | - ConDeclField lname _ doc <- fields ] - cons = [ con | L _ con <- tcdCons decl ] - fields = concat [ fields | RecCon fields <- map con_details cons] + classSubs = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ] + dataSubs = constrs ++ fields + where + cons = map unL $ tcdCons decl + constrs = [ (unL $ con_name c, fmap unL $ con_doc c) | c <- cons ] + fields = [ (unL n, fmap unL doc) + | RecCon flds <- map con_details cons + , ConDeclField n _ doc <- flds ] -- All the sub declarations of a class (that we handle), ordered by @@ -206,7 +211,7 @@ topDecls :: HsGroup Name -> [DeclWithDoc] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup -filterOutInstances = filter (\(L _ d, _) -> not (isInstD d)) +filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) -- | Take all declarations in an 'HsGroup' and convert them into a list of @@ -235,7 +240,7 @@ sortByLoc = sortBy (comparing getLoc) warnAboutFilteredDecls mod decls = do let modStr = moduleString mod let typeInstances = - nub [ tcdName d | (L _ (TyClD d), _) <- decls, isFamInstDecl d ] + nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] when (not $null typeInstances) $ tell $ nub [ @@ -244,7 +249,7 @@ warnAboutFilteredDecls mod decls = do ++ "will be filtered out:\n " ++ (concat $ intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _) <- decls + let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls , not (null ats) ] when (not $ null instances) $ @@ -365,7 +370,7 @@ mkExportItems :: ModuleMap -> Module -- this module -> [Name] -- exported names (orig) - -> [(Decl, Maybe Doc)] + -> [DeclInfo] -> Map Name DeclInfo -- maps local names to declarations -> Map Name [Name] -- sub-map for this module -> [DocOption] @@ -380,7 +385,7 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map = everything_local_exported | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs where - instances = [ d | d@(L _ decl, _) <- decls, isInstD decl ] + instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] everything_local_exported = -- everything exported return (fullContentsOfThisModule this_mod decls) @@ -401,7 +406,7 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] lookupExport (IEDocNamed str) = do - r <- findNamedDoc str (map (unLoc . fst) decls) + r <- findNamedDoc str [ unL d | (d,_,_) <- decls ] case r of Nothing -> return [] Just found -> return [ ExportDoc found ] @@ -411,15 +416,19 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map -- temp hack: we filter out separately declared ATs, since we haven't decided how -- to handle them yet. We should really give an warning message also, and filter the -- name out in mkVisibleNames... - | Just (decl, maybeDoc, _) <- findDecl t, t `notElem` declATs (unL decl) = - return [ ExportDecl (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ] + | Just x@(decl,_,_) <- findDecl t, + t `notElem` declATs (unL decl) = return [ mkExportDecl t x ] | otherwise = return [] - where - mdl = nameModule t - subs = filter (`elem` exported_names) all_subs - all_subs - | mdl == this_mod = Map.findWithDefault [] t sub_map - | otherwise = allSubsOfName modMap t + + + mkExportDecl :: Name -> DeclInfo -> ExportItem Name + mkExportDecl n (decl, doc, subs) = decl' + where + decl' = ExportDecl (restrictTo subs' (extractDecl n mdl decl)) doc subdocs [] + mdl = nameModule n + subs' = filter (`elem` exported_names) $ map fst subs + subdocs = [ (n, doc) | (n, Just doc) <- subs ] + fullContentsOf m | m == this_mod = return (fullContentsOfThisModule this_mod decls) @@ -441,11 +450,13 @@ mkExportItems modMap this_mod exported_names decls declMap sub_map m = nameModule n -fullContentsOfThisModule :: Module -> [(Decl, Maybe Doc)] -> [ExportItem Name] +fullContentsOfThisModule :: Module -> [DeclInfo] -> [ExportItem Name] fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls) where - mkExportItem (L _ (DocD (DocGroup lev doc)), _) = Just $ ExportGroup lev "" doc - mkExportItem (decl, doc) = Just $ ExportDecl decl doc [] + mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc + mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subdocs [] + where subdocs = [ (n, doc) | (n, Just doc) <- subs ] + -- mkExportItem _ = Nothing -- TODO: see if this is really needed @@ -513,7 +524,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = -- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items - where hasDoc (ExportDecl _ d _) = isJust d + where hasDoc (ExportDecl _ d _ _) = isJust d hasDoc _ = True diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 3efc2526..3675f0b4 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -369,9 +369,10 @@ renameTyClD d = case d of renameSig sig = case sig of - TypeSig (L loc name) ltype -> do + TypeSig lname ltype -> do + lname' <- renameL lname ltype' <- renameLType ltype - return (TypeSig (L loc (keep name)) ltype') + return (TypeSig lname' ltype') -- we have filtered out all other kinds of signatures in Interface.Create @@ -395,11 +396,12 @@ renameExportItem item = case item of ExportGroup lev id doc -> do doc' <- renameDoc doc return (ExportGroup lev id doc') - ExportDecl decl doc instances -> do + ExportDecl decl doc subs instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc + subs' <- mapM renameSub subs instances' <- mapM renameInstHead instances - return (ExportDecl decl' doc' instances') + return (ExportDecl decl' doc' subs' instances') ExportNoDecl x y subs -> do y' <- lookupRn id y subs' <- mapM (lookupRn id) subs @@ -407,3 +409,9 @@ renameExportItem item = case item of ExportDoc doc -> do doc' <- renameDoc doc return (ExportDoc doc') + + +renameSub (n,doc) = do + n' <- rename n + doc' <- renameDoc doc + return (n', doc') diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 671637c5..24f5fd25 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -47,6 +47,9 @@ data ExportItem name -- | Maybe a doc comment expItemMbDoc :: Maybe (HsDoc name), + -- | Documentation for subordinate declarations + expItemSubDocs :: [(name, HsDoc name)], + -- | Instances relevant to this declaration expItemInstances :: [InstHead name] diff --git a/tests/tests/Hidden.hs b/tests/tests/Hidden.hs index e46fc37f..896da648 100644 --- a/tests/tests/Hidden.hs +++ b/tests/tests/Hidden.hs @@ -1,4 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} + module Hidden where + hidden :: Int -> Int hidden a = a diff --git a/tests/tests/Ticket61.hs b/tests/tests/Ticket61.hs new file mode 100644 index 00000000..26ca287f --- /dev/null +++ b/tests/tests/Ticket61.hs @@ -0,0 +1,3 @@ +module Ticket61 (module Ticket61_Hidden) where + +import Ticket61_Hidden diff --git a/tests/tests/Ticket61.html.ref b/tests/tests/Ticket61.html.ref new file mode 100644 index 00000000..0e0c6c0a --- /dev/null +++ b/tests/tests/Ticket61.html.ref @@ -0,0 +1,125 @@ + + +Ticket61
ContentsIndex
Ticket61
Documentation
class C a where
Methods
f :: a
A comment about f +
Produced by Haddock version 2.3.0
diff --git a/tests/tests/Ticket61_Hidden.hs b/tests/tests/Ticket61_Hidden.hs new file mode 100644 index 00000000..583c10cd --- /dev/null +++ b/tests/tests/Ticket61_Hidden.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Ticket61_Hidden where + +class C a where + -- | A comment about f + f :: a -- cgit v1.2.3