aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends/Xhtml')
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs71
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs23
2 files changed, 75 insertions, 19 deletions
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-09-21 16:55:47 +0000