aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Html.hs
diff options
context:
space:
mode:
authorIsaac Dupree <id@isaac.cedarswampstudios.org>2009-08-23 03:01:28 +0000
committerIsaac Dupree <id@isaac.cedarswampstudios.org>2009-08-23 03:01:28 +0000
commitd0d23a5627c7e5b9a699df1b44517841dff2d569 (patch)
treef7ab0c40fdbebc6b7124be235f88c0cabbb1437b /src/Haddock/Backends/Html.hs
parent949baf1be3334c7ae53b5395a1b568dcf3ddc117 (diff)
less big-Map-based proper extraction of constructor subdocs
Diffstat (limited to 'src/Haddock/Backends/Html.hs')
-rw-r--r--src/Haddock/Backends/Html.hs26
1 files changed, 16 insertions, 10 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index 17c1c802..a420dac5 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -821,7 +821,7 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
ppDecl summ links (L loc decl) mbDoc instances docMap subdocs unicode = case decl of
TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode
TyClD d@(TyData {})
- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d unicode
+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode
| Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d
TyClD d@(TySynonym {})
| Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d unicode
@@ -1257,9 +1257,10 @@ ppShortDataDecl summary links loc dataDecl unicode
cons = tcdCons dataDecl
resTy = (con_res . unLoc . head) cons
-ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] ->
+ [(DocName, Maybe (HsDoc DocName))] ->
SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable
-ppDataDecl summary links instances loc mbDoc dataDecl unicode
+ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode
| summary = declWithDoc summary links loc docname mbDoc
(ppShortDataDecl summary links loc dataDecl unicode)
@@ -1299,7 +1300,7 @@ ppDataDecl summary links instances loc mbDoc dataDecl unicode
| null cons = Html.emptyTable
| otherwise = constrHdr </> (
tda [theclass "body"] << constrTable <<
- aboves (map (ppSideBySideConstr unicode) cons)
+ aboves (map (ppSideBySideConstr subdocs unicode) cons)
)
instId = collapseId (getName docname)
@@ -1374,8 +1375,8 @@ ppConstrHdr forall tvs ctxt unicode
Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
Implicit -> empty
-ppSideBySideConstr :: Bool -> LConDecl DocName -> HtmlTable
-ppSideBySideConstr unicode (L _ con) = case con_res con of
+ppSideBySideConstr :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> LConDecl DocName -> HtmlTable
+ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of
ResTyH98 -> case con_details con of
@@ -1404,7 +1405,7 @@ ppSideBySideConstr unicode (L _ con) = case con_res con of
where
doRecordFields fields =
(tda [theclass "body"] << spacedTable1 <<
- aboves (map (ppSideBySideField unicode) fields))
+ aboves (map (ppSideBySideField subdocs unicode) fields))
doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [
ppForAll forall ltvs (con_cxt con) unicode,
ppLType unicode (foldr mkFunTy resTy args) ]
@@ -1417,14 +1418,19 @@ ppSideBySideConstr unicode (L _ con) = case con_res con of
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
forall = con_explicit con
- mbLDoc = con_doc con
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbLDoc = fmap noLoc $ join $ lookup (unLoc $ con_name con) subdocs
mkFunTy a b = noLoc (HsFunTy a b)
-ppSideBySideField :: Bool -> ConDeclField DocName -> HtmlTable
-ppSideBySideField unicode (ConDeclField (L _ name) ltype mbLDoc) =
+ppSideBySideField :: [(DocName, Maybe (HsDoc DocName))] -> Bool -> ConDeclField DocName -> HtmlTable
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
argBox (ppBinder False (docNameOcc name)
<+> dcolon unicode <+> ppLType unicode ltype) <->
maybeRDocBox mbLDoc
+ where
+ -- don't use cd_fld_doc for same reason we don't use con_doc above
+ mbLDoc = fmap noLoc $ join $ lookup name subdocs
{-
ppHsFullConstr :: HsConDecl -> Html