aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Interface/Create.hs76
1 files changed, 44 insertions, 32 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index f89bcbc0..408e37d1 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -390,10 +390,10 @@ mkExportItems
mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declMap
optExports _ instIfaceMap dflags =
case optExports of
- Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls
+ Nothing -> fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls
Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports
where
- decls = filter (\(L _ d) -> not (isInstD d || isValD d)) decls0
+ decls = filter (not . isInstD . unLoc) decls0
-- A type signature can have multiple names, like:
-- foo, bar :: Types..
@@ -409,7 +409,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
lookupExport (IEThingAll t) = declWith t
lookupExport (IEThingWith t _) = declWith t
lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap
+ moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap docMap argMap subMap declMap
lookupExport (IEGroup lev docStr) = liftErrMsg $
ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
(\doc -> return [ ExportGroup lev "" doc ])
@@ -431,15 +431,12 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
declWith t =
- let doc = (M.lookup t docMap, maybe M.empty id (M.lookup t argMap)) in
+ let (doc, subs) = exportDecl t docMap argMap subMap in
case findDecl t of
[L _ (ValD _)] -> do
-- Top-level binding without type signature
- mayDecl <- ifaceDecl t
- case mayDecl of
- Nothing -> return [ ExportNoDecl t [] ]
- Just decl -> return [ ExportDecl decl doc [] [] ]
-
+ export <- hiValExportItem t doc
+ return [export]
ds | decl : _ <- filter (not . isValD . unLoc) ds ->
let declNames = getMainDeclBinder (unL decl)
in case () of
@@ -462,7 +459,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
return []
-- normal case
- | otherwise -> return [ mkExportDecl t newDecl (exportDecl t newDecl docMap argMap subMap) ]
+ | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ]
where
-- Since a single signature might refer to many names, we
-- need to filter the ones that are actually exported. This
@@ -477,7 +474,7 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
-- Declaration from another package
[] -> do
- mayDecl <- ifaceDecl t
+ mayDecl <- hiDecl t
case mayDecl of
Nothing -> return [ ExportNoDecl t [] ]
Just decl -> do
@@ -487,10 +484,10 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
Nothing -> do
liftErrMsg $ tell
["Warning: Couldn't find .haddock for export " ++ pretty t]
- let subs = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
- return [ mkExportDecl t decl (noDocForDecl, subs) ]
+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ]
+ return [ mkExportDecl t decl (noDocForDecl, subs_) ]
Just iface -> do
- return [ mkExportDecl t decl (exportDecl t decl (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+ return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
_ -> return []
@@ -508,17 +505,16 @@ mkExportItems modMap thisMod gre exportedNames decls0 docMap argMap subMap declM
findDecl :: Name -> [Decl]
- findDecl n
- | m == thisMod = maybe [] id (M.lookup n declMap)
- | otherwise = case M.lookup m modMap of
- Just iface -> maybe [] id (M.lookup n (ifaceDeclMap iface))
- Nothing -> []
+ findDecl name
+ | mdl == thisMod = maybe [] id (M.lookup name declMap)
+ | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface))
+ | otherwise = []
where
- m = nameModule n
+ mdl = nameModule name
-ifaceDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
-ifaceDecl t = do
+hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl t = do
mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
case mayTyThing of
Nothing -> do
@@ -527,8 +523,16 @@ ifaceDecl t = do
Just x -> return (Just (tyThingToLHsDecl x))
-exportDecl :: Name -> Decl -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-exportDecl name _ docMap argMap subMap =
+hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name)
+hiValExportItem name doc = do
+ mayDecl <- hiDecl name
+ case mayDecl of
+ Nothing -> return (ExportNoDecl name [])
+ Just decl -> return (ExportDecl decl doc [] [])
+
+
+exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+exportDecl name docMap argMap subMap =
let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in
let doc = (M.lookup name docMap, lookupArgMap name) in
let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in
@@ -559,9 +563,10 @@ moduleExports :: Module -- ^ Module A
-> DocMap Name
-> ArgMap Name
-> SubMap
+ -> DeclMap
-> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap
- | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre docMap argMap subMap decls
+moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap docMap argMap subMap declMap
+ | m == thisMod = fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls
| otherwise =
case M.lookup m ifaceMap of
Just iface
@@ -599,21 +604,28 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap doc
-- (For more information, see Trac #69)
-fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> [Decl] -> ErrMsgM [ExportItem Name]
-fullContentsOfThisModule dflags gre docMap argMap subMap decls = liftM catMaybes $ mapM mkExportItem decls
+fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> DocMap Name -> ArgMap Name -> SubMap -> DeclMap -> [Decl] -> ErrMsgGhc [ExportItem Name]
+fullContentsOfThisModule dflags gre docMap argMap subMap declMap decls = liftM catMaybes $ mapM mkExportItem decls
where
mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr
+ mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr
return $ fmap (ExportGroup lev "") mbDoc
mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
+ mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
return $ fmap ExportDoc mbDoc
+ mkExportItem (L _ (ValD d))
+ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
+ -- Top-level binding without type signature
+ let (doc, _) = exportDecl name docMap argMap subMap in
+ fmap Just (hiValExportItem name doc)
+ | otherwise = return Nothing
mkExportItem decl
- | name : _ <- getMainDeclBinder (unLoc decl) =
- let (doc, subs) = exportDecl name decl docMap argMap subMap in
+ | name:_ <- getMainDeclBinder (unLoc decl) =
+ let (doc, subs) = exportDecl name docMap argMap subMap in
return $ Just (ExportDecl decl doc subs [])
| otherwise = return Nothing
+
-- | Sometimes the declaration we want to export is not the "main" declaration:
-- it might be an individual record selector or a class method. In these
-- cases we have to extract the required declaration (and somehow cobble
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 21:07:32 +0000