aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/LaTeX.hs44
-rw-r--r--src/Haddock/Backends/Xhtml.hs2
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs71
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs23
4 files changed, 118 insertions, 22 deletions
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 4a30a168..94adc558 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -249,6 +249,7 @@ declNames :: LHsDecl DocName -> [DocName]
declNames (L _ decl) = case decl of
TyClD d -> [tcdName d]
SigD (TypeSig lnames _) -> map unLoc lnames
+ SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
ForD (ForeignImport (L _ n) _ _ _) -> [n]
ForD (ForeignExport (L _ n) _ _ _) -> [n]
_ -> error "declaration not supported by declNames"
@@ -291,6 +292,8 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of
-- Family instances happen via FamInst now
TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode
ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
InstD _ -> empty
_ -> error "declaration not supported by ppDecl"
@@ -345,6 +348,33 @@ ppFunSig loc doc docnames typ unicode =
where
names = map getName docnames
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+ -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+ -> LHsContext DocName -> LHsContext DocName
+ -> Bool -> LaTeX
+ppLPatSig loc doc docname args typ prov req unicode =
+ ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode
+
+ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName
+ -> HsPatSynDetails (HsType DocName) -> HsType DocName
+ -> HsContext DocName -> HsContext DocName
+ -> Bool -> LaTeX
+ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)
+ where
+ pref1 = hsep [ keyword "pattern"
+ , pp_ctx prov
+ , pp_head
+ , dcolon unicode
+ , pp_ctx req
+ , ppType unicode typ
+ ]
+
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]
+
+ pp_type = ppParendType unicode
+ pp_ctx ctx = ppContext ctx unicode
ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
-> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
@@ -914,9 +944,16 @@ ppr_fun_ty ctxt_prec ty1 ty2 unicode
ppBinder :: OccName -> LaTeX
ppBinder n
- | isVarSym n = parens $ ppOccName n
- | otherwise = ppOccName n
+ | isInfixName n = parens $ ppOccName n
+ | otherwise = ppOccName n
+ppBinderInfix :: OccName -> LaTeX
+ppBinderInfix n
+ | isInfixName n = ppOccName n
+ | otherwise = quotes $ ppOccName n
+
+isInfixName :: OccName -> Bool
+isInfixName n = isVarSym n || isConSym n
ppSymName :: Name -> LaTeX
ppSymName name
@@ -953,6 +990,9 @@ ppLDocName (L _ d) = ppDocName d
ppDocBinder :: DocName -> LaTeX
ppDocBinder = ppBinder . nameOccName . getName
+ppDocBinderInfix :: DocName -> LaTeX
+ppDocBinderInfix = ppBinderInfix . nameOccName . getName
+
ppName :: Name -> LaTeX
ppName = ppOccName . nameOccName
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index d61478a8..567abced 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -598,7 +598,7 @@ ppNameMini :: Module -> OccName -> Html
ppNameMini mdl nm =
anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
- << ppBinder' nm
+ << ppBinder' False nm
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 91e6871d..04f94c49 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -30,6 +30,7 @@ import Haddock.Doc (combineDocumentation)
import Data.List ( intersperse )
import qualified Data.Map as Map
import Data.Maybe
+import Data.Monoid ( mempty )
import Text.XHtml hiding ( name, title, p, quote )
import GHC
@@ -40,21 +41,69 @@ ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->
DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] ->
Bool -> Qualification -> Html
ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
- SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual
+ TyClD (FamDecl d) -> ppTyFam summ False links loc mbDoc d unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty unicode qual
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req unicode qual
ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual
InstD _ -> noHtml
_ -> error "declaration not supported by ppDecl"
+ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [Located DocName] -> LHsType DocName -> Bool -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) unicode qual
+
ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
[DocName] -> HsType DocName -> Bool -> Qualification -> Html
ppFunSig summary links loc doc docnames typ unicode qual =
+ ppSigLike summary links loc mempty doc docnames (typ, pp_typ) unicode qual
+ where
+ pp_typ = ppType unicode qual typ
+
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ Located DocName ->
+ HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
+ LHsContext DocName -> LHsContext DocName ->
+ Bool -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode qual
+
+ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ DocName ->
+ HsPatSynDetails (HsType DocName) -> HsType DocName ->
+ HsContext DocName -> HsContext DocName ->
+ Bool -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qual
+ | summary = pref1
+ | otherwise = topDeclElem links loc [docname] pref1 +++ docSection qual doc
+ where
+ -- pref1 = leader <+> ppTypeSig summary occnames pp_typ unicode
+ pref1 = hsep [ toHtml "pattern"
+ , pp_cxt prov
+ , pp_head
+ , dcolon unicode
+ , pp_cxt req
+ , ppType unicode qual typ
+ ]
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
+
+ pp_cxt cxt = ppContext cxt unicode qual
+ pp_type = ppParendType unicode qual
+
+ occname = nameOccName . getName $ docname
+
+ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
+ [DocName] -> (HsType DocName, Html) -> Bool -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames (typ, pp_typ) unicode qual =
ppTypeOrFunSig summary links loc docnames typ doc
- ( ppTypeSig summary occnames typ unicode qual
+ ( leader <+> ppTypeSig summary occnames pp_typ unicode
, concatHtml . punctuate comma $ map (ppBinder False) occnames
, dcolon unicode
)
@@ -127,9 +176,9 @@ ppTySyn summary links loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvar
ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html
-ppTypeSig summary nms ty unicode qual =
- concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty
+ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
+ppTypeSig summary nms pp_ty unicode =
+ concatHtml htmlNames <+> dcolon unicode <+> pp_ty
where
htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
@@ -465,7 +514,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of
char '}')
InfixCon arg1 arg2 ->
(header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppBinder summary occ, ppLParendType unicode qual arg2],
+ ppBinderInfix summary occ, ppLParendType unicode qual arg2],
noHtml, noHtml)
ResTyGADT resTy -> case con_details con of
@@ -526,7 +575,7 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart)
InfixCon arg1 arg2 ->
hsep [header_ unicode qual +++ ppLParendType unicode qual arg1,
- ppBinder False occ,
+ ppBinderInfix False occ,
ppLParendType unicode qual arg2]
ResTyGADT resTy -> case con_details con of
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 2f2b82ed..280a888c 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -12,7 +12,7 @@
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Names (
ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
- ppBinder, ppBinder',
+ ppBinder, ppBinderInfix, ppBinder',
ppModule, ppModuleRef,
ppIPName,
linkId
@@ -105,16 +105,23 @@ ppName name = toHtml (getOccString name)
ppBinder :: Bool -> OccName -> Html
-- The Bool indicates whether we are generating the summary, in which case
-- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' False n
ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' n
+ << ppBinder' False n
+ppBinderInfix :: Bool -> OccName -> Html
+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' True n
+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' True n
-ppBinder' :: OccName -> Html
-ppBinder' n
- | isVarSym n = parens $ ppOccName n
- | otherwise = ppOccName n
-
+ppBinder' :: Bool -> OccName -> Html
+-- The Bool indicates if it is to be rendered in infix notation
+ppBinder' is_infix n = wrap $ ppOccName n
+ where
+ wrap | is_infix && not is_sym = quote
+ | not is_infix && is_sym = parens
+ | otherwise = id
+ is_sym = isVarSym n || isConSym n
linkId :: Module -> Maybe Name -> Html -> Html
linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:39:07 +0000