aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs73
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs38
2 files changed, 63 insertions, 48 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 20:19:58 +0000