aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMark Lentczner <markl@glyphic.com>2010-06-17 17:36:01 +0000
committerMark Lentczner <markl@glyphic.com>2010-06-17 17:36:01 +0000
commit3da5ad49bb4e18705fdf0f3428648ed425e8009b (patch)
tree48f3bf796e6ea0f5354d8f2998acca2213b62773 /src
parent2fb3ec9518d221e2f8cb822efa1ab26d12f5bcd8 (diff)
push single constructors (newtype) onto line with decl
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs45
1 files changed, 30 insertions, 15 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 3a401cce..286e9670 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -440,8 +440,9 @@ ppShortDataDecl summary _links _loc dataDecl unicode
| [] <- cons = declElem dataHeader
- | [lcon] <- cons, ResTyH98 <- resTy = declElem (dataHeader <+> equals)
- <+> ppShortConstr summary (unLoc lcon) unicode
+ | [lcon] <- cons, ResTyH98 <- resTy,
+ (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode
+ = declElem (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
| ResTyH98 <- resTy = declElem dataHeader
+++ unordList (zipWith doConstr ('=':repeat '|') cons)
@@ -455,7 +456,7 @@ ppShortDataDecl summary _links _loc dataDecl unicode
doGADTConstr con = ppShortConstr summary (unLoc con) unicode
cons = tcdCons dataDecl
- resTy = (con_res . unLoc . head) cons
+ resTy = (con_res . unLoc . head) cons
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] ->
@@ -499,31 +500,45 @@ isRecCon lcon = case con_details (unLoc lcon) of
_ -> False
+
ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html
-ppShortConstr summary con unicode = case con_res con of
+ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot
+ where
+ (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode
+
+
+-- returns three pieces: header, body, footer so that header & footer can be
+-- incorporated into the declaration
+ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html)
+ppShortConstrParts summary con unicode = case con_res con of
ResTyH98 -> case con_details con of
- PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args)
- RecCon fields -> header_ unicode +++ ppBinder summary occ <+>
- doRecordFields fields
- InfixCon arg1 arg2 -> header_ unicode +++
- hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2]
+ PrefixCon args ->
+ (header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args),
+ noHtml, noHtml)
+ RecCon fields ->
+ (header_ unicode +++ ppBinder summary occ <+> char '{',
+ doRecordFields fields,
+ char '}')
+ InfixCon arg1 arg2 ->
+ (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2],
+ noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
-- prefix & infix could use hsConDeclArgTys if it seemed to
-- simplify the code.
- PrefixCon args -> doGADTCon args resTy
+ PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
-- display GADT records with the new syntax,
-- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
-- (except each field gets its own line in docs, to match
-- non-GADT records)
- RecCon fields -> ppBinder summary occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs lcontext unicode,
+ RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
+ ppForAll forall ltvs lcontext unicode <+> char '{',
doRecordFields fields,
- arrow unicode <+> ppLType unicode resTy ]
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+ char '}' <+> arrow unicode <+> ppLType unicode resTy)
+ InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
where
- doRecordFields fields = braces $ unordList (map (ppShortField summary unicode) fields)
+ doRecordFields fields = unordList (map (ppShortField summary unicode) fields)
doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
ppForAll forall ltvs lcontext unicode,
ppLType unicode (foldr mkFunTy resTy args) ]