diff options
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 20 | ||||
| -rw-r--r-- | src/Haddock/Backends/Html.hs | 26 |
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 |