diff options
author | Mark Lentczner <markl@glyphic.com> | 2010-04-04 06:24:14 +0000 |
---|---|---|
committer | Mark Lentczner <markl@glyphic.com> | 2010-04-04 06:24:14 +0000 |
commit | 1ea671418f3e6650bf6b30f5efb0a364f043093d (patch) | |
tree | 5c48448b4978baec31c64328bed64f32549701fb | |
parent | f5f0af15b7feee9535c2e57afeeb7018231063f4 (diff) |
all decls now generate Html not HtmlTable
- ppDecl return Html, and so now do all of the functions it calls
- added some internal tables to some decls, which is wrong, and will have
to be fixed
- decl "Box" functions became "Elem" functions to make clear they aren't
in a table anymore (see Layout.hs)
- docBox went away, as only used in one place (and its days are numbered)
- cleaned up logic in a number of places, removed dead code
- added maybeDocToHtml which simplified a number of places in the code
-rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 4 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 146 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 3 | ||||
-rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 46 |
4 files changed, 73 insertions, 126 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index dad65a4c..a83bc6ae 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -294,7 +294,7 @@ ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable ppPrologue _ Nothing = emptyTable ppPrologue title (Just doc) = (tda [theclass "section1"] << toHtml title) </> - docBox (rdrDocToHtml doc) + (tda [theclass "doc"] << (rdrDocToHtml doc)) ppModuleTree :: String -> [ModuleTree] -> HtmlTable ppModuleTree _ ts = @@ -736,7 +736,7 @@ processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) processExport _ _ _ (ExportGroup lev id0 doc) = Left $ groupTag lev << namedAnchor id0 << docToHtml doc processExport summary links unicode (ExportDecl decl doc subdocs insts) - = Right $ ppDecl' summary links decl doc insts subdocs unicode + = Right $ ppDecl summary links decl doc insts subdocs unicode processExport _ _ _ (ExportNoDecl y []) = Right $ ppDocName y processExport _ _ _ (ExportNoDecl y subs) diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 66702396..ebb38907 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -33,12 +33,8 @@ import Outputable ( ppr, showSDoc, Outputable ) -- TODO: use DeclInfo DocName or something -ppDecl' :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html -ppDecl' s k l m i d u = vanillaTable << ppDecl s k l m i d u - ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode TyClD d@(TyData {}) @@ -50,11 +46,11 @@ ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = ca TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode - InstD _ -> emptyTable + InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> HsType DocName -> Bool -> HtmlTable + DocName -> HsType DocName -> Bool -> Html ppFunSig summary links loc doc docname typ unicode = ppTypeOrFunSig summary links loc docname typ doc (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode @@ -62,11 +58,11 @@ ppFunSig summary links loc doc docname typ unicode = occname = docNameOcc docname ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> - DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable + DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode | summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1 - | otherwise = topDeclBox links loc docname pref2 </> - (tda [theclass "body"] << vanillaTable << ( + | otherwise = topDeclElem links loc docname pref2 +++ + (vanillaTable << ( do_args 0 sep typ </> (case doc of Just d -> ndocBox (docToHtml d) @@ -110,14 +106,14 @@ tyvarNames :: [LHsTyVarBndr DocName] -> [Name] tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode = ppFunSig summary links loc doc name typ unicode ppFor _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now -ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable +ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode = ppTypeOrFunSig summary links loc name (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode @@ -163,35 +159,31 @@ ppTyFamHeader summary associated decl unicode = ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> HtmlTable + TyClDecl DocName -> Bool -> Html ppTyFam summary associated links loc mbDoc decl unicode | summary = declWithDoc summary links loc docname mbDoc - (ppTyFamHeader True associated decl unicode) - - | associated, isJust mbDoc = header_ </> bodyBox << doc - | associated = header_ - | null instances, isJust mbDoc = header_ </> bodyBox << doc - | null instances = header_ - | isJust mbDoc = header_ </> bodyBox << (doc </> instancesBit) - | otherwise = header_ </> bodyBox << instancesBit + (ppTyFamHeader True associated decl unicode) + | otherwise = header_ +++ maybeDocToHtml mbDoc +++ instancesBit where docname = tcdName decl - header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode) - - doc = ndocBox . docToHtml . fromJust $ mbDoc + header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode) instId = collapseId (getName docname) - instancesBit = instHdr instId </> + instancesBit + | associated || null instances = noHtml + | otherwise = vanillaTable << ( + instHdr instId </> tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << ( aboves (map (ppDocInstance unicode) instances) ) ) + ) -- TODO: get the instances instances = [] @@ -220,23 +212,17 @@ ppDataInst = undefined ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> HtmlTable + TyClDecl DocName -> Bool -> Html ppTyInst summary associated links loc mbDoc decl unicode | summary = declWithDoc summary links loc docname mbDoc (ppTyInstHeader True associated decl unicode) - - | isJust mbDoc = header_ </> bodyBox << doc - | otherwise = header_ + | otherwise = header_ +++ maybeDocToHtml mbDoc where docname = tcdName decl - header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode) - - doc = case mbDoc of - Just d -> ndocBox (docToHtml d) - Nothing -> emptyTable + header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode) ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html @@ -252,7 +238,7 @@ ppTyInstHeader _ _ decl unicode = -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html ppAssocType summ links doc (L loc decl) unicode = case decl of TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode @@ -359,24 +345,23 @@ ppFds fds unicode = fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> hsep (map ppDocName vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = if null sigs && null ats - then (if summary then declBox else topDeclBox links loc nm) hdr - else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") - </> + then (if summary then declElem else topDeclElem links loc nm) hdr + else (if summary then declElem else topDeclElem links loc nm) (hdr <+> keyword "where") + +++ vanillaTable << ( - bodyBox << - aboves - ( - [ ppAssocType summary links doc at unicode | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - - [ ppFunSig summary links loc doc n typ unicode - | L _ (TypeSig (L _ n) (L _ typ)) <- sigs - , let doc = lookupAnySubdoc n subdocs ] - ) - ) + bodyBox << aboves + ( + [ ppAssocType summary links doc at unicode | at <- ats + , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + + [ ppFunSig summary links loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- sigs + , let doc = lookupAnySubdoc n subdocs ] + ) + ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode nm = unLoc lname @@ -386,47 +371,30 @@ ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortC ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> HtmlTable + -> TyClDecl DocName -> Bool -> Html ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _) unicode | summary = ppShortClassDecl summary links decl loc subdocs unicode - | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit) + | otherwise = classheader +++ maybeDocToHtml mbDoc +++ instancesBit where classheader - | null lsigs = topDeclBox links loc nm (hdr unicode) - | otherwise = topDeclBox links loc nm (hdr unicode <+> keyword "where") + | null lsigs = topDeclElem links loc nm (hdr unicode) + | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where") nm = unLoc $ tcdLName decl hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - - classdoc = case mbDoc of - Nothing -> emptyTable - Just d -> ndocBox (docToHtml d) - - body_ - | null lsigs, null ats = emptyTable - | null ats = s8 </> methHdr </> bodyBox << methodTable - | otherwise = s8 </> atHdr </> bodyBox << atTable </> - s8 </> methHdr </> bodyBox << methodTable - - methodTable = - abovesSep s8 [ ppFunSig summary links loc doc n typ unicode - | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc n subdocs ] - - atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - + instId = collapseId (getName nm) instancesBit - | null instances = emptyTable - | otherwise - = s8 </> instHdr instId </> + | null instances = noHtml + | otherwise = vanillaTable << ( + instHdr instId </> tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << aboves (map (ppDocInstance unicode) instances) ) + ) ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" @@ -479,12 +447,12 @@ ppShortDataDecl summary links loc dataDecl unicode where dataHeader = - (if summary then declBox else topDeclBox links loc docname) + (if summary then declElem else topDeclElem links loc docname) ((ppDataHeader summary dataDecl unicode) <+> case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) - doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode) - doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode) + doConstr c con = declElem (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode) + doGADTConstr con = declElem (ppShortConstr summary (unLoc con) unicode) docname = unLoc . tcdLName $ dataDecl cons = tcdCons dataDecl @@ -492,27 +460,21 @@ ppShortDataDecl summary links loc dataDecl unicode ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode | summary = declWithDoc summary links loc docname mbDoc (ppShortDataDecl summary links loc dataDecl unicode) | otherwise - = (if validTable then (</>) else const) header_ $ - tda [theclass "body"] << vanillaTable << ( - datadoc </> - constrBit </> - instancesBit - ) - + = header_ +++ datadoc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode + header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode <+> whereBit) whereBit @@ -548,8 +510,6 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode ) ) - validTable = isJust mbDoc || not (null cons) || not (null instances) - isRecCon :: Located (ConDecl a) -> Bool isRecCon lcon = case con_details (unLoc lcon) of @@ -682,10 +642,10 @@ ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = Just _ -> aboves [hdr, constr_doc, fields_html] ) - where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) + where hdr = declElem (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) constr_doc - | isJust doc = docBox (docToHtml (fromJust doc)) + | isJust doc = docElem (docToHtml (fromJust doc)) | otherwise = emptyTable fields_html = diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index 54e9f700..5103f569 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -80,7 +80,8 @@ rdrDocToHtml :: Doc RdrName -> Html rdrDocToHtml = markup fmt . cleanup where fmt = parHtmlMarkup ppRdrName isRdrTc - +maybeDocToHtml :: Maybe (Doc DocName) -> Html +maybeDocToHtml = maybe noHtml docToHtml cleanup :: Doc a -> Doc a cleanup = markup fmtUnParagraphLists diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index fa96049d..93ce0987 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -24,12 +24,10 @@ import FastString ( unpackFS ) import GHC -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable -declWithDoc True _ _ _ _ html_decl = declBox html_decl -declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl -declWithDoc False links loc nm (Just doc) html_decl = - topDeclBox links loc nm html_decl </> docBox (docToHtml doc) - +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> Html +declWithDoc True _ _ _ _ html_decl = declElem html_decl +declWithDoc False links loc nm doc html_decl = + topDeclElem links loc nm html_decl +++ maybeDocToHtml doc {- @@ -38,36 +36,27 @@ text = strAttr "TEXT" -} -- a box for displaying code -declBox :: Html -> HtmlTable -declBox html = tda [theclass "decl"] << html +declElem :: Html -> Html +declElem = paragraph ! [theclass "decl"] -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box -topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable -topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html -topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) - loc name html = - tda [theclass "topdecl"] << - ( table ! [theclass "declbar"] << - ((tda [theclass "declname"] << html) - <-> srcLink - <-> wikiLink) - ) +topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html +topDeclElem ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) loc name html = + declElem << (html +++ srcLink +++ wikiLink) where srcLink = case maybe_source_url of - Nothing -> emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just origMod) + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just origMod) (Just n) (Just loc) url - in anchor ! [href url'] << toHtml "Source" + in anchor ! [href url', theclass "link"] << "Source" wikiLink = case maybe_wiki_url of - Nothing -> emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just mdl) + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just mdl) (Just n) (Just loc) url - in anchor ! [href url'] << toHtml "Comments" + in anchor ! [href url', theclass "link"] << "Comments" -- For source links, we want to point to the original module, -- because only that will have the source. @@ -81,16 +70,13 @@ topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) fname = unpackFS (srcSpanFile loc) + -- a box for displaying an 'argument' (some code which has text to the -- right of it). Wrapping is not allowed in these boxes, whereas it is -- in a declBox. argBox :: Html -> HtmlTable argBox html = tda [theclass "arg"] << html --- a box for displaying documentation, --- indented and with a little padding at the top -docBox :: Html -> HtmlTable -docBox html = tda [theclass "doc"] << html -- a box for displaying documentation, not indented. ndocBox :: Html -> HtmlTable |