From c006c2a31880eab89a69c0ef42eddf7d02cfcd96 Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Wed, 14 Jul 2010 04:21:55 +0000 Subject: constructors and args as dl lists, built in Layout.hs --- src/Haddock/Backends/Xhtml/Decl.hs | 68 +++++++++++++++--------------------- src/Haddock/Backends/Xhtml/Layout.hs | 18 +++++++--- 2 files changed, 42 insertions(+), 44 deletions(-) (limited to 'src/Haddock/Backends') diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 286e9670..1245ff62 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -480,26 +480,12 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode ResTyGADT _ -> keyword "where" _ -> empty - constrTable - | any isRecCon cons = spacedTable5 - | otherwise = spacedTable1 - - constrBit - | null cons = noHtml - | otherwise = constrHdr +++ ( - constrTable << - aboves (map (ppSideBySideConstr subdocs unicode) cons) - ) + constrBit = subDecls "Constructors" + (map (ppSideBySideConstr subdocs unicode) cons) instancesBit = ppInstances instances docname unicode -isRecCon :: Located (ConDecl a) -> Bool -isRecCon lcon = case con_details (unLoc lcon) of - RecCon _ -> True - _ -> False - - ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot @@ -567,43 +553,45 @@ ppConstrHdr forall tvs ctxt unicode Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> empty -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> (Html, Maybe Html) ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) - <-> maybeRDocBox mbDoc + (hsep ((header_ unicode +++ ppBinder False occ) + : map (ppLParendType unicode) args), + fmap docToHtml mbDoc) RecCon fields -> - argBox (header_ unicode +++ ppBinder False occ) <-> - maybeRDocBox mbDoc - - doRecordFields fields + (header_ unicode +++ ppBinder False occ, + fmap docToHtml mbDoc `with` (Just $ doRecordFields fields)) InfixCon arg1 arg2 -> - argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) - <-> maybeRDocBox mbDoc + (hsep [header_ unicode+++ppLParendType unicode arg1, + ppBinder False occ, + ppLParendType unicode arg2], + fmap docToHtml mbDoc) ResTyGADT resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. - PrefixCon args -> doGADTCon args resTy + PrefixCon args -> doGADTCon args resTy Nothing cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + (Just $ doRecordFields fields) + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy Nothing where - doRecordFields fields = - (tda [theclass "body"] << spacedTable1 << - 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) ] - ) <-> maybeRDocBox mbDoc - - + doRecordFields fields = subDecls "Fields" + (map (ppSideBySideField subdocs unicode) fields) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Maybe Html -> (Html, Maybe Html) + doGADTCon args resTy fieldsHtml = + (ppBinder False occ <+> dcolon unicode + <+> hsep [ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ], + fmap docToHtml mbDoc `with` fieldsHtml) + + with a = maybe a (\b -> Just $ a +++ b) header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con @@ -616,10 +604,10 @@ ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs mkFunTy a b = noLoc (HsFunTy a b) -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> (Html, Maybe Html) ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = - argBox (ppBinder False (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc + (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype, + fmap docToHtml mbDoc) where -- don't use cd_fld_doc for same reason we don't use con_doc above mbDoc = join $ fmap fst $ lookup name subdocs diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index 86c722b7..3ab93b82 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -17,11 +17,12 @@ module Haddock.Backends.Xhtml.Layout ( sectionName, shortDeclList, - divTopDecl, + divTopDecl, + subDecls, topDeclElem, declElem, - instHdr, atHdr, methHdr, constrHdr, + instHdr, atHdr, methHdr, argBox, ndocBox, rdocBox, maybeRDocBox, vanillaTable, vanillaTable2, spacedTable1, spacedTable5 @@ -32,6 +33,7 @@ import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Util import Haddock.Types +import Data.Char (isLetter, toLower) import Text.XHtml hiding ( name, title, p, quote ) import FastString ( unpackFS ) @@ -63,6 +65,15 @@ shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items divTopDecl :: Html -> Html divTopDecl = thediv ! [theclass "top"] +subDecls :: String -> [(Html, Maybe Html)] -> Html +subDecls _ [] = noHtml +subDecls name decls = subSection << (subCaption +++ subList) + where + subSection = thediv ! [theclass $ unwords ["subs", subClass]] + subClass = map (\c -> if isLetter c then toLower c else '-') name + subCaption = paragraph ! [theclass "caption"] << name + subList = dlist << map subEntry decls + subEntry (dt,dd) = [dterm ! [theclass "src"] << dt, ddef << nonEmpty dd] -- a box for displaying code declElem :: Html -> Html @@ -129,8 +140,7 @@ spacedTable1, spacedTable5 :: Html -> Html spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] -constrHdr, methHdr, atHdr :: Html -constrHdr = h5 << "Constructors" +methHdr, atHdr :: Html methHdr = h5 << "Methods" atHdr = h5 << "Associated Types" -- cgit v1.2.3