From 60962ea3ab84060880426a9f42d88e53a70499a0 Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Wed, 14 Jul 2010 05:38:32 +0000 Subject: better interface to subDecls --- src/Haddock/Backends/Xhtml/Decl.hs | 73 +++++++++++++++++------------------- src/Haddock/Backends/Xhtml/Layout.hs | 38 ++++++++++++++----- 2 files changed, 63 insertions(+), 48 deletions(-) (limited to 'src/Haddock/Backends') diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 1245ff62..ffee5bd7 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -480,7 +480,7 @@ ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode ResTyGADT _ -> keyword "where" _ -> empty - constrBit = subDecls "Constructors" + constrBit = subConstructors (map (ppSideBySideConstr subdocs unicode) cons) instancesBit = ppInstances instances docname unicode @@ -553,45 +553,41 @@ ppConstrHdr forall tvs ctxt unicode Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> empty -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 -> - (hsep ((header_ unicode +++ ppBinder False occ) - : map (ppLParendType unicode) args), - fmap docToHtml mbDoc) - - RecCon fields -> - (header_ unicode +++ ppBinder False occ, - fmap docToHtml mbDoc `with` (Just $ doRecordFields fields)) - - InfixCon arg1 arg2 -> - (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 Nothing - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy - (Just $ doRecordFields fields) - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy Nothing - +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart) where - doRecordFields fields = subDecls "Fields" + decl = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + hsep ((header_ unicode +++ ppBinder False occ) + : map (ppLParendType unicode) args) + + RecCon _ -> header_ unicode +++ ppBinder False occ + + InfixCon arg1 arg2 -> + hsep [header_ unicode+++ppLParendType unicode arg1, + ppBinder False occ, + ppLParendType unicode arg2] + + 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 + cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + fieldPart = case con_details con of + RecCon fields -> [doRecordFields fields] + _ -> [] + + doRecordFields fields = subFields (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 + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = + ppBinder False occ <+> dcolon unicode <+> hsep [ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ], - fmap docToHtml mbDoc `with` fieldsHtml) + ppLType unicode (foldr mkFunTy resTy args) ] - with a = maybe a (\b -> Just $ a +++ b) header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con @@ -604,10 +600,11 @@ 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 -> (Html, Maybe Html) +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype, - fmap docToHtml mbDoc) + 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 3ab93b82..80dd5ec8 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -18,7 +18,9 @@ module Haddock.Backends.Xhtml.Layout ( shortDeclList, divTopDecl, - subDecls, + + SubDecl, + subConstructors, subFields, topDeclElem, declElem, @@ -33,7 +35,6 @@ 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 ) @@ -65,15 +66,32 @@ 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) + +type SubDecl = (Html, Maybe (Doc DocName), [Html]) + +divSubDecls :: String -> String -> Maybe Html -> Html +divSubDecls cssClass captionName = maybe noHtml wrap + where + wrap = (subSection <<) . (subCaption +++) + subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subCaption = paragraph ! [theclass "caption"] << captionName + +subDlist :: [SubDecl] -> Maybe Html +subDlist [] = Nothing +subDlist decls = Just $ dlist << map subEntry decls 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] + subEntry (decl, mdoc, subs) = Just $ + dterm ! [theclass "src"] << decl + +++ ddef << (fmap docToHtml mdoc `with` subs) + Nothing `with` [] = spaceHtml + ma `with` bs = ma +++ bs + +subConstructors :: [(Html, Maybe (Doc DocName), [Html])] -> Html +subConstructors = divSubDecls "constructors" "Constructors" . subDlist + +subFields :: [(Html, Maybe (Doc DocName), [Html])] -> Html +subFields = divSubDecls "fields" "Fields" . subDlist + -- a box for displaying code declElem :: Html -> Html -- cgit v1.2.3