aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml/Decl.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends/Xhtml/Decl.hs')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs73
1 files changed, 35 insertions, 38 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