aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Interface/Create.hs76
-rw-r--r--tests/html-tests/tests/Bug8.hs3
-rw-r--r--tests/html-tests/tests/Bug8.html.ref36
-rw-r--r--tests/html-tests/tests/QuasiExpr.html.ref6
-rw-r--r--tests/html-tests/tests/TH2.hs1
-rw-r--r--tests/html-tests/tests/TH2.html.ref10
-rw-r--r--tests/html-tests/tests/TypeFamilies.html.ref22
7 files changed, 117 insertions, 37 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
diff --git a/tests/html-tests/tests/Bug8.hs b/tests/html-tests/tests/Bug8.hs
index 0f279c29..18df63c8 100644
--- a/tests/html-tests/tests/Bug8.hs
+++ b/tests/html-tests/tests/Bug8.hs
@@ -1,6 +1,3 @@
-{- Note that declarations without type signatures are not included in the
- documentation. They could be, but that's a missing feature. -}
-
module Bug8 where
infix -->
diff --git a/tests/html-tests/tests/Bug8.html.ref b/tests/html-tests/tests/Bug8.html.ref
index ee0637b9..05d3ebeb 100644
--- a/tests/html-tests/tests/Bug8.html.ref
+++ b/tests/html-tests/tests/Bug8.html.ref
@@ -82,6 +82,42 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");};
></table
></div
></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:-45--45--62-" class="def"
+ >(--&gt;)</a
+ > :: t -&gt; t1 -&gt; <a href=""
+ >Typ</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:-45--45--45--62-" class="def"
+ >(---&gt;)</a
+ > :: [a] -&gt; <a href=""
+ >Typ</a
+ > -&gt; <a href=""
+ >Typ</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:s" class="def"
+ >s</a
+ > :: a</p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:t" class="def"
+ >t</a
+ > :: a</p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:main" class="def"
+ >main</a
+ > :: a</p
+ ></div
></div
></div
><div id="footer"
diff --git a/tests/html-tests/tests/QuasiExpr.html.ref b/tests/html-tests/tests/QuasiExpr.html.ref
index 0d59ecc8..8241c3f7 100644
--- a/tests/html-tests/tests/QuasiExpr.html.ref
+++ b/tests/html-tests/tests/QuasiExpr.html.ref
@@ -196,6 +196,12 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");};
></div
><div class="top"
><p class="src"
+ ><a name="v:expr" class="def"
+ >expr</a
+ > :: QuasiQuoter</p
+ ></div
+ ><div class="top"
+ ><p class="src"
><a name="v:parseExprExp" class="def"
>parseExprExp</a
> :: <a href=""
diff --git a/tests/html-tests/tests/TH2.hs b/tests/html-tests/tests/TH2.hs
index f8f27710..ea85e547 100644
--- a/tests/html-tests/tests/TH2.hs
+++ b/tests/html-tests/tests/TH2.hs
@@ -4,5 +4,4 @@ module TH2 where
import TH
--- we can't add a type sig here, so we get no doc
$( decl )
diff --git a/tests/html-tests/tests/TH2.html.ref b/tests/html-tests/tests/TH2.html.ref
index 9fc9a056..3d284850 100644
--- a/tests/html-tests/tests/TH2.html.ref
+++ b/tests/html-tests/tests/TH2.html.ref
@@ -42,7 +42,15 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH2.html");};
>TH2</p
></div
><div id="interface"
- ></div
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:f" class="def"
+ >f</a
+ > :: t -&gt; t</p
+ ></div
+ ></div
></div
><div id="footer"
><p
diff --git a/tests/html-tests/tests/TypeFamilies.html.ref b/tests/html-tests/tests/TypeFamilies.html.ref
index 40c949b8..a3d94bb0 100644
--- a/tests/html-tests/tests/TypeFamilies.html.ref
+++ b/tests/html-tests/tests/TypeFamilies.html.ref
@@ -81,6 +81,16 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
> <a href=""
>F</a
> a </li
+ ><li class="src short"
+ ><a href=""
+ >g</a
+ > :: <a href=""
+ >B</a
+ > <a href=""
+ >Int</a
+ > <a href=""
+ >Integer</a
+ ></li
></ul
></div
><div id="interface"
@@ -177,6 +187,18 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");};
</p
></div
></div
+ ><div class="top"
+ ><p class="src"
+ ><a name="v:g" class="def"
+ >g</a
+ > :: <a href=""
+ >B</a
+ > <a href=""
+ >Int</a
+ > <a href=""
+ >Integer</a
+ ></p
+ ></div
></div
></div
><div id="footer"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 04:21:09 +0000