aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Backends/Html.hs16
-rw-r--r--src/Haddock/Interface/Create.hs76
-rw-r--r--src/Haddock/Interface/Rename.hs2
-rw-r--r--src/Haddock/Types.hs4
4 files changed, 29 insertions, 69 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 7302cf2e..e93cb1e2 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -27,7 +27,7 @@ import Haddock.GHC.Utils
import qualified Haddock.Utils.Html as Html
import Control.Exception ( bracket )
-import Control.Monad ( when, unless )
+import Control.Monad ( when, unless, join )
import Data.Char ( isUpper, toUpper )
import Data.List ( sortBy, groupBy )
import Data.Maybe
@@ -763,7 +763,7 @@ declWithDoc False links loc nm (Just doc) html_decl =
-- TODO: use DeclInfo DocName or something
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
- Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, HsDoc DocName)] -> HtmlTable
+ Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (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 {})
@@ -1070,7 +1070,7 @@ ppFds fds =
fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>
hsep (map ppDocName vars2)
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, HsDoc DocName)] -> HtmlTable
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (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
@@ -1081,11 +1081,11 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
aboves
(
[ ppAssocType summary links doc at | at <- ats
- , let doc = lookup (tcdName $ unL at) subdocs ] ++
+ , let doc = join $ lookup (tcdName $ unL at) subdocs ] ++
[ ppFunSig summary links loc doc n typ
| L _ (TypeSig (L _ n) (L _ typ)) <- sigs
- , let doc = lookup n subdocs ]
+ , let doc = join $ lookup n subdocs ]
)
)
where
@@ -1095,7 +1095,7 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc
ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->
- Maybe (HsDoc DocName) -> DocMap -> [(DocName, HsDoc DocName)] -> TyClDecl DocName ->
+ Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> TyClDecl DocName ->
HtmlTable
ppClassDecl summary links instances loc mbDoc docMap subdocs
decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)
@@ -1124,10 +1124,10 @@ ppClassDecl summary links instances loc mbDoc docMap subdocs
methodTable =
abovesSep s8 [ ppFunSig summary links loc doc n typ
| L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
- , let doc = lookup n subdocs ]
+ , let doc = join $ lookup n subdocs ]
atTable = abovesSep s8 $ [ ppAssocType summary links doc at | at <- ats
- , let doc = lookup (tcdName $ unL at) subdocs ]
+ , let doc = join $ lookup (tcdName $ unL at) subdocs ]
instId = collapseId (docNameOrig nm)
instancesBit
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index b7c82267..a5bbff3c 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -62,13 +62,11 @@ createInterface ghcMod flags modMap = do
warnAboutFilteredDecls mod decls0
- visibleNames <- mkVisibleNames mod modMap localNames
- (ghcNamesInScope ghcMod)
- exports opts declMap
-
exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap
opts exports ignoreExps instances
+ let visibleNames = mkVisibleNames exportItems
+
-- prune the export list to just those declarations that have
-- documentation, if the 'prune' option is on.
let
@@ -377,15 +375,13 @@ mkExportItems modMap this_mod exported_names decls declMap
t `notElem` declATs (unL decl) = return [ mkExportDecl t x ]
| otherwise = return []
-
mkExportDecl :: Name -> DeclInfo -> ExportItem Name
mkExportDecl n (decl, doc, subs) = decl'
where
- decl' = ExportDecl (restrictTo subs' (extractDecl n mdl decl)) doc subdocs []
+ decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' []
mdl = nameModule n
- subs' = filter (`elem` exported_names) $ map fst subs
- subdocs = [ (n, doc) | (n, Just doc) <- subs ]
-
+ subs' = filter ((`elem` exported_names) . fst) subs
+ sub_names = map fst subs'
fullContentsOf m
| m == this_mod = return (fullContentsOfThisModule this_mod decls)
@@ -412,8 +408,7 @@ fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls)
where
mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc
mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc
- mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subdocs []
- where subdocs = [ (n, doc) | (n, Just doc) <- subs ]
+ mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs []
-- mkExportItem _ = Nothing -- TODO: see if this is really needed
@@ -486,53 +481,18 @@ pruneExportItems items = filter hasDoc items
hasDoc _ = True
--- | Gather a list of original names exported from this module
-mkVisibleNames :: Module
- -> ModuleMap
- -> [Name]
- -> [Name]
- -> Maybe [IE Name]
- -> [DocOption]
- -> Map Name DeclInfo
- -> ErrMsgM [Name]
-
-mkVisibleNames mdl modMap localNames scope maybeExps opts declMap
- -- if no export list, just return all local names
- | Nothing <- maybeExps = return (filter hasDecl localNames)
- | OptIgnoreExports `elem` opts = return localNames
- | Just expspecs <- maybeExps = do
- visibleNames <- mapM extract expspecs
- return $ filter isNotPackageName (concat visibleNames)
- where
- hasDecl name = isJust (Map.lookup name declMap)
- isNotPackageName name = nameMod == mdl || isJust (Map.lookup nameMod modMap)
- where nameMod = nameModule name
-
- extract e =
- case e of
- IEVar x -> return [x]
- IEThingAbs t -> return [t]
- IEThingAll t -> return (t : all_subs)
- where
- all_subs | nameModule t == mdl = subsOfName t declMap
- | otherwise = allSubsOfName modMap t
-
- IEThingWith t cs -> return (t : cs)
-
- IEModuleContents m
- | mkModule (modulePackageId mdl) m == mdl -> return localNames
- | otherwise -> let m' = mkModule (modulePackageId mdl) m in
- case Map.lookup m' modMap of
- Just mod
- | OptHide `elem` ifaceOptions mod ->
- return (filter (`elem` scope) (ifaceExports mod))
- | otherwise -> return []
- Nothing
- -> tell (exportModuleMissingErr mdl m') >> return []
-
- _ -> return []
-
-
+mkVisibleNames :: [ExportItem Name] -> [Name]
+mkVisibleNames exports = concatMap exportName exports
+ where
+ exportName e@ExportDecl {} =
+ case getMainDeclBinder $ unL $ expItemDecl e of
+ Just n -> n : subs
+ Nothing -> subs
+ where subs = map fst (expItemSubDocs e)
+ exportName e@ExportNoDecl {} = expItemName e : expItemSubs e
+ exportName _ = []
+
+
exportModuleMissingErr this mdl
= ["Warning: in export list of " ++ show (moduleString this)
++ ": module not found: " ++ show (moduleString mdl)]
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 0e0da5a6..3eb52d8f 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -416,5 +416,5 @@ renameExportItem item = case item of
renameSub (n,doc) = do
n' <- rename n
- doc' <- renameDoc doc
+ doc' <- mapM renameDoc doc
return (n', doc')
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 44cc9161..c10cfee7 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -47,8 +47,8 @@ data ExportItem name
-- | Maybe a doc comment
expItemMbDoc :: Maybe (HsDoc name),
- -- | Documentation for subordinate declarations
- expItemSubDocs :: [(name, HsDoc name)],
+ -- | Subordinate names, possibly with documentation
+ expItemSubDocs :: [(name, Maybe (HsDoc name))],
-- | Instances relevant to this declaration
expItemInstances :: [InstHead name]
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 21:33:18 +0000