aboutsummaryrefslogtreecommitdiff
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
parent949baf1be3334c7ae53b5395a1b568dcf3ddc117 (diff)
less big-Map-based proper extraction of constructor subdocs
-rw-r--r--src/Haddock/Backends/Hoogle.hs20
-rw-r--r--src/Haddock/Backends/Html.hs26
2 files changed, 28 insertions, 18 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 020c4a71..b96dfc45 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -109,9 +109,9 @@ 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 subdocs _) = doc dc ++ f (unL decl)
where
- f (TyClD d@TyData{}) = ppData d
+ f (TyClD d@TyData{}) = ppData d subdocs
f (TyClD d@ClassDecl{}) = ppClass d
f (TyClD d@TySynonym{}) = ppSynonym d
f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ
@@ -156,9 +156,9 @@ ppInstance :: Instance -> [String]
ppInstance x = [dropComment $ out x]
-ppData :: TyClDecl Name -> [String]
-ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
- concatMap (ppCtor x . unL) (tcdCons x)
+ppData :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))] -> [String]
+ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :
+ concatMap (ppCtor x subdocs . unL) (tcdCons x)
where
-- GHC gives out "data Bar =", we want to delete the equals
-- also writes data : a b, when we want data (:) a b
@@ -168,14 +168,18 @@ ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
nam = out $ tcdLName d
f w = if w == nam then operator nam else w
+-- | for constructors, and named-fields...
+lookupCon :: [(Name, Maybe (HsDoc Name))] -> Located Name -> Maybe (HsDoc Name)
+lookupCon subdocs (L _ name) = join{-Maybe-} $ lookup name subdocs
-ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
-ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
+ppCtor :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))] -> ConDecl Name -> [String]
+ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+ ++ f (con_details con)
where
f (PrefixCon args) = [typeSig name $ args ++ [resType]]
f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [ldoc (cd_fld_doc r) ++
+ [doc (lookupCon subdocs (cd_fld_name r)) ++
[out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
| r <- recs]
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