aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml/Decl.hs
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2014-11-21 11:23:09 -0600
committerAustin Seipp <aseipp@pobox.com>2014-11-21 11:23:09 -0600
commit5d8117d8f1f910c85d36865d646b65510b23583d (patch)
treed2868ac32b45a6a1e1be34ee565dc543c6e7bea3 /src/Haddock/Backends/Xhtml/Decl.hs
parent2b3712d701c1df626abbc60525c35e735272e45d (diff)
Follow API changes in D426
Signed-off-by: Austin Seipp <aseipp@pobox.com>
Diffstat (limited to 'src/Haddock/Backends/Xhtml/Decl.hs')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs61
1 files changed, 41 insertions, 20 deletions
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 97f3fb09..0cb5ffb4 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -579,7 +579,8 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
constrBit = subConstructors qual
[ ppSideBySideConstr subdocs subfixs unicode qual c
| c <- cons
- , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
+ (map unLoc (con_names (unLoc c)))) fixities
]
instancesBit = ppInstances instances docname unicode qual
@@ -598,15 +599,15 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualificatio
ppShortConstrParts summary dataInst con unicode qual = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- (header_ unicode qual +++ hsep (ppBinder summary occ
+ (header_ unicode qual +++ hsep (ppOcc
: map (ppLParendType unicode qual) args), noHtml, noHtml)
RecCon fields ->
- (header_ unicode qual +++ ppBinder summary occ <+> char '{',
+ (header_ unicode qual +++ ppOcc <+> char '{',
doRecordFields fields,
char '}')
InfixCon arg1 arg2 ->
(header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppBinderInfix summary occ, ppLParendType unicode qual arg2],
+ ppOccInfix, ppLParendType unicode qual arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -617,20 +618,29 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
-- 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 <+>
+ RecCon fields -> (ppOcc <+> dcolon unicode <+>
ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
doRecordFields fields,
char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
where
- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
- doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))
+ doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [
ppForAll forall_ ltvs lcontext unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
header_ = ppConstrHdr forall_ tyVars context
- occ = nameOccName . getName . unLoc . con_name $ con
+ occ = map (nameOccName . getName . unLoc) $ con_names con
+
+ ppOcc = case occ of
+ [one] -> ppBinder summary one
+ _ -> hsep (punctuate comma (map (ppBinder summary) occ))
+
+ ppOccInfix = case occ of
+ [one] -> ppBinderInfix summary one
+ _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))
+
ltvs = con_qvars con
tyVars = tyvarNames ltvs
lcontext = con_cxt con
@@ -661,15 +671,15 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
decl = case con_res con of
ResTyH98 -> case con_details con of
PrefixCon args ->
- hsep ((header_ +++ ppBinder False occ)
+ hsep ((header_ +++ ppOcc)
: map (ppLParendType unicode qual) args)
<+> fixity
- RecCon _ -> header_ +++ ppBinder False occ <+> fixity
+ RecCon _ -> header_ +++ ppOcc <+> fixity
InfixCon arg1 arg2 ->
hsep [header_ +++ ppLParendType unicode qual arg1,
- ppBinderInfix False occ,
+ ppOccInfix,
ppLParendType unicode qual arg2]
<+> fixity
@@ -685,40 +695,51 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
_ -> []
doRecordFields fields = subFields qual
- (map (ppSideBySideField subdocs unicode qual) fields)
+ (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))
doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
- doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
+ doGADTCon args resTy = ppOcc <+> dcolon unicode
<+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
ppLType unicode qual (foldr mkFunTy resTy args) ]
<+> fixity
fixity = ppFixities fixities qual
header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = nameOccName . getName . unLoc . con_name $ con
+ occ = map (nameOccName . getName . unLoc) $ con_names con
+
+ ppOcc = case occ of
+ [one] -> ppBinder False one
+ _ -> hsep (punctuate comma (map (ppBinder False) occ))
+
+ ppOccInfix = case occ of
+ [one] -> ppBinderInfix False one
+ _ -> hsep (punctuate comma (map (ppBinderInfix False) occ))
+
ltvs = con_qvars con
tyVars = tyvarNames (con_qvars con)
context = unLoc (con_cxt con)
forall_ = con_explicit con
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
+ mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=
+ combineDocumentation . fst
mkFunTy a b = noLoc (HsFunTy a b)
ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
-> ConDeclField DocName -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
- (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =
+ (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,
mbDoc,
[])
where
-- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = lookup name subdocs >>= combineDocumentation . fst
+ -- Where there is more than one name, they all have the same documentation
+ mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst
ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
-ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
- = ppBinder summary (nameOccName . getName $ name)
+ppShortField summary unicode qual (ConDeclField names ltype _)
+ = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names))
<+> dcolon unicode <+> ppLType unicode qual ltype