aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs32
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs4
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs56
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs4
4 files changed, 71 insertions, 25 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 53cfccff..18660b3f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -227,8 +227,8 @@ isExportModule _ = Nothing
processExport :: ExportItem DocName -> LaTeX
processExport (ExportGroup lev _id0 doc)
= ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
- = ppDecl decl doc insts subdocs fixities
+processExport (ExportDecl decl pats doc subdocs insts fixities _splice)
+ = ppDecl decl pats doc insts subdocs fixities
processExport (ExportNoDecl y [])
= ppDocName y
processExport (ExportNoDecl y subs)
@@ -278,16 +278,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
ppDecl :: LHsDecl DocName
+ -> [(HsDecl DocName,DocForDecl DocName)]
-> DocForDecl DocName
-> [DocInstance DocName]
-> [(DocName, DocForDecl DocName)]
-> [(DocName, Fixity)]
-> LaTeX
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of
TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc (Just doc) d unicode
+ -> ppDataDecl pats instances subdocs loc (Just doc) d unicode
TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
-- Family instances happen via FamInst now
-- TyClD d@(TySynonym {})
@@ -565,11 +566,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of
-------------------------------------------------------------------------------
-ppDataDecl :: [DocInstance DocName] ->
+ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] ->
[(DocName, DocForDecl DocName)] -> SrcSpan ->
Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
+ppDataDecl pats instances subdocs _loc doc dataDecl unicode
= declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
(if null body then Nothing else Just (vcat body))
@@ -579,10 +580,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
cons = dd_cons (tcdDataDefn dataDecl)
resTy = (unLoc . head) cons
- body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+ body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX]
(whereBit, leaders)
- | null cons = (empty,[])
+ | null cons
+ , null pats = (empty,[])
+ | null cons = (decltt (keyword "where"), repeat empty)
| otherwise = case resTy of
ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)
_ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
@@ -594,6 +597,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode
vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
text "\\end{tabulary}\\par"
+ patternBit
+ | null cons = Nothing
+ | otherwise = Just $
+ text "\\haddockbeginconstrs" $$
+ vcat [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames
+ , dcolon unicode
+ , ppLType unicode (hsSigType ty)
+ ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d)
+ | (SigD (PatSynSig lnames ty),d) <- pats
+ ] $$
+ text "\\end{tabulary}\\par"
+
instancesBit = ppDocInstances unicode instances
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 34ecc5b8..249389b9 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -604,8 +604,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification
processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
processExport summary _ _ qual (ExportGroup lev id0 doc)
= nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
= processDeclOneLiner summary $ ppDocName qual Prefix True y
processExport summary _ _ qual (ExportNoDecl y subs)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 035c8e9e..716050fa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -41,11 +41,12 @@ import BooleanFormula
import RdrName ( rdrNameOcc )
ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
- -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> [(HsDecl DocName, DocForDecl DocName)]
+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
-> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual
TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
@@ -613,7 +614,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =
, [subFamInstDetails iid pdecl])
where
pdata = keyword "data" <+> typ
- pdecl = pdata <+> ppShortDataDecl False True dd unicode qual
+ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual
where
iid = instanceId origin no orphan ihd
typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual
@@ -662,20 +663,23 @@ instanceId origin no orphan ihd = concat $
-- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName
+ -> [(HsDecl DocName,DocForDecl DocName)]
+ -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl pats unicode qual
- | [] <- cons = dataHeader
+ | [] <- cons
+ , [] <- pats = dataHeader
- | [lcon] <- cons, isH98,
+ | [lcon] <- cons, [] <- pats, isH98,
(cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
= (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
- | isH98 = dataHeader
- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+ | [] <- pats, isH98 = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1)
| otherwise = (dataHeader <+> keyword "where")
- +++ shortSubDecls dataInst (map doGADTConstr cons)
+ +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1)
where
dataHeader
@@ -689,16 +693,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual
ConDeclH98 {} -> True
ConDeclGADT{} -> False
+ pats1 = [ hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppLType unicode qual (hsSigType typ)
+ ]
+ | (SigD (PatSynSig lnames typ),_) <- pats
+ ]
+
ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
[(DocName, DocForDecl DocName)] ->
SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+ [(HsDecl DocName,DocForDecl DocName)] ->
Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
splice unicode qual
- | summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit
+ | summary = ppShortDataDecl summary False dataDecl pats unicode qual
+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit
where
docname = tcdName dataDecl
@@ -713,7 +726,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
whereBit
- | null cons = noHtml
+ | null cons
+ , null pats = noHtml
+ | null cons = keyword "where"
| otherwise = if isH98 then noHtml else keyword "where"
constrBit = subConstructors qual
@@ -723,6 +738,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl
(map unLoc (getConNames (unLoc c)))) fixities
]
+ patternBit = subPatterns qual
+ [ (hsep [ keyword "pattern"
+ , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames
+ , dcolon unicode
+ , ppLType unicode qual (hsSigType typ)
+ ] <+> ppFixities subfixs qual
+ ,combineDocumentation (fst d), [])
+ | (SigD (PatSynSig lnames typ),d) <- pats
+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities
+ ]
+
instancesBit = ppInstances links (OriginData docname) instances
splice unicode qual
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index 41457f72..6993c7f6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout (
subArguments,
subAssociatedTypes,
subConstructors,
+ subPatterns,
subEquations,
subFields,
subInstances, subOrphanInstances,
@@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc
subConstructors :: Qualification -> [SubDecl] -> Html
subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+subPatterns :: Qualification -> [SubDecl] -> Html
+subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual
+
subFields :: Qualification -> [SubDecl] -> Html
subFields qual = divSubDecls "fields" "Fields" . subDlist qual
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 21:31:55 +0000