aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Backends/Html.hs42
-rw-r--r--src/Haddock/DocName.hs1
-rw-r--r--src/Haddock/Interface/AttachInstances.hs4
-rw-r--r--src/Haddock/Interface/Create.hs87
-rw-r--r--src/Haddock/Interface/Rename.hs16
-rw-r--r--src/Haddock/Types.hs3
7 files changed, 89 insertions, 66 deletions
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]
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 11:49:14 +0000