aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--html-test/ref/Ticket75.html6
-rw-r--r--src/Haddock/Backends/Xhtml.hs14
-rw-r--r--src/Haddock/Backends/Xhtml/Decl.hs32
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs4
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs72
5 files changed, 69 insertions, 59 deletions
diff --git a/html-test/ref/Ticket75.html b/html-test/ref/Ticket75.html
index c6746f39..830e123a 100644
--- a/html-test/ref/Ticket75.html
+++ b/html-test/ref/Ticket75.html
@@ -48,7 +48,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket75.html");};
><li class="src short"
><span class="keyword"
>data</span
- > a <a href=""
+ > a <a href=""
>:-</a
> b = <a href=""
>Q</a
@@ -68,9 +68,9 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket75.html");};
><p class="src"
><span class="keyword"
>data</span
- > a <a name="t::-45-" class="def"
+ > a <a name="t::-45-" class="def"
>:-</a
- > b </p
+ > b</p
><div class="subs constructors"
><p class="caption"
>Constructors</p
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 567abced..ac4282fb 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -587,25 +587,25 @@ processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts
(ClassDecl {}) -> [keyword "class" <+> b]
_ -> []
SigD (TypeSig lnames (L _ _)) ->
- map (ppNameMini mdl . nameOccName . getName . unLoc) lnames
+ map (ppNameMini False mdl . nameOccName . getName . unLoc) lnames
_ -> []
processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
[groupTag lvl << docToHtml qual txt]
processForMiniSynopsis _ _ _ _ = []
-ppNameMini :: Module -> OccName -> Html
-ppNameMini mdl nm =
+ppNameMini :: Bool -> Module -> OccName -> Html
+ppNameMini is_infix mdl nm =
anchor ! [ href (moduleNameUrl mdl nm)
, target mainFrameName ]
- << ppBinder' False nm
+ << ppBinder' is_infix nm
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
ppTyClBinderWithVarsMini mdl decl =
let n = tcdName decl
ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
- in ppTypeApp n ns (ppNameMini mdl . nameOccName . getName) ppTyName
+ in ppTypeApp n ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
@@ -653,10 +653,10 @@ processExport summary _ _ qual (ExportGroup lev id0 doc)
processExport summary links unicode qual (ExportDecl decl doc subdocs insts)
= processDecl summary $ ppDecl summary links decl doc insts subdocs unicode qual
processExport summary _ _ qual (ExportNoDecl y [])
- = processDeclOneLiner summary $ ppDocName qual y
+ = processDeclOneLiner summary $ ppDocName qual (Just False) y
processExport summary _ _ qual (ExportNoDecl y subs)
= processDeclOneLiner summary $
- ppDocName qual y +++ parenList (map (ppDocName qual) subs)
+ ppDocName qual (Just False) y +++ parenList (map (ppDocName qual (Just False)) subs)
processExport summary _ _ qual (ExportDoc doc)
= nothingIf summary $ docSection_ qual doc
processExport summary _ _ _ (ExportModule mdl)
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 04f94c49..acde5a0f 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -82,7 +82,6 @@ ppPatSig summary links loc (doc, _argDocs) docname args typ prov req unicode qua
| 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
@@ -184,9 +183,7 @@ ppTypeSig summary nms pp_ty unicode =
ppTyName :: Name -> Html
-ppTyName name
- | isNameSym name = parens (ppName name)
- | otherwise = ppName name
+ppTyName = ppName (Just False)
--------------------------------------------------------------------------------
@@ -273,25 +270,28 @@ ppDataBinderWithVars summ decl =
-- | Print an application of a DocName and a list of HsTypes
ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html
ppAppNameTypes n ts unicode qual =
- ppTypeApp n ts (ppDocName qual) (ppParendType unicode qual)
+ ppTypeApp n ts (ppDocName qual . Just) (ppParendType unicode qual)
-- | Print an application of a DocName and a list of Names
ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
ppAppDocNameNames summ n ns =
- ppTypeApp n ns (ppBinder summ . nameOccName . getName) ppTyName
-
+ ppTypeApp n ns ppDN ppTyName
+ where
+ ppDN is_infix = ppBinderFixity is_infix summ . nameOccName . getName
+ ppBinderFixity True = ppBinderInfix
+ ppBinderFixity False = ppBinder
-- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp :: DocName -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html
ppTypeApp n (t1:t2:rest) ppDN ppT
| operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
| operator = opApp
where
operator = isNameSym . getName $ n
- opApp = ppT t1 <+> ppDN n <+> ppT t2
+ opApp = ppT t1 <+> ppDN True n <+> ppT t2
-ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
+ppTypeApp n ts ppDN ppT = ppDN False n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
@@ -346,9 +346,8 @@ ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = hsep (map (ppDocName qual) vars1) <+> arrow unicode <+>
- hsep (map (ppDocName qual) vars2)
-
+ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ ppVars = hsep . map (ppDocName qual (Just False))
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
-> [(DocName, DocForDecl DocName)] -> Bool -> Qualification
@@ -557,7 +556,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual
<+> darrow unicode +++ toHtml " ")
where
ppForall = case forall_ of
- Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "
+ Explicit -> forallSymbol unicode <+> hsep (map (ppName (Just False)) tvs) <+> toHtml ". "
Implicit -> noHtml
@@ -721,7 +720,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q name
+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q (Just False) name
ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
ppr_mono_ty _ (HsKindSig ty kind) u q =
@@ -749,8 +748,7 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
= maybeParen ctxt_prec pREC_FUN $
ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
where
- ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op
- occ = nameOccName . getName . unLoc $ op
+ ppr_op = ppLDocName qual (Just True) op
ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
-- = parens (ppr_mono_lty pREC_TOP ty)
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index ca963f48..69174e96 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -80,12 +80,12 @@ parHtmlMarkup qual ppId = Markup {
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
docToHtml :: Qualification -> Doc DocName -> Html
docToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual (ppDocName qual)
+ where fmt = parHtmlMarkup qual (ppDocName qual Nothing)
origDocToHtml :: Qualification -> Doc Name -> Html
origDocToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual ppName
+ where fmt = parHtmlMarkup qual (ppName Nothing)
rdrDocToHtml :: Qualification -> Doc RdrName -> Html
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index 280a888c..1bd2cbc4 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -49,57 +49,64 @@ ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-ppLDocName :: Qualification -> Located DocName -> Html
-ppLDocName qual (L _ d) = ppDocName qual d
+-- The Bool indicates if it is to be rendered in infix notation
+ppLDocName :: Qualification -> Maybe Bool -> Located DocName -> Html
+ppLDocName qual is_infix (L _ d) = ppDocName qual is_infix d
-ppDocName :: Qualification -> DocName -> Html
-ppDocName qual docName =
+-- The Bool indicates if it is to be rendered in infix notation
+-- Nothing means print it raw, i.e. don't force it to either infix or prefix
+-- TODO: instead of Maybe Bool, add a bespoke datatype
+ppDocName :: Qualification -> Maybe Bool -> DocName -> Html
+ppDocName qual is_infix docName =
case docName of
Documented name mdl ->
- linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl
+ linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual is_infix name mdl
Undocumented name
| isExternalName name || isWiredInName name ->
- ppQualifyName qual name (nameModule name)
- | otherwise -> ppName name
+ ppQualifyName qual is_infix name (nameModule name)
+ | otherwise -> ppName is_infix name
-- | Render a name depending on the selected qualification mode
-ppQualifyName :: Qualification -> Name -> Module -> Html
-ppQualifyName qual name mdl =
+ppQualifyName :: Qualification -> Maybe Bool -> Name -> Module -> Html
+ppQualifyName qual is_infix name mdl =
case qual of
- NoQual -> ppName name
- FullQual -> ppFullQualName mdl name
+ NoQual -> ppName is_infix name
+ FullQual -> ppFullQualName is_infix mdl name
LocalQual localmdl ->
if moduleString mdl == moduleString localmdl
- then ppName name
- else ppFullQualName mdl name
+ then ppName is_infix name
+ else ppFullQualName is_infix mdl name
RelativeQual localmdl ->
case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
-- local, A.x -> x
- Just [] -> ppName name
+ Just [] -> ppName is_infix name
-- sub-module, A.B.x -> B.x
Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
-- some module with same prefix, ABC.x -> ABC.x
- Just _ -> ppFullQualName mdl name
+ Just _ -> ppFullQualName is_infix mdl name
-- some other module, D.x -> D.x
- Nothing -> ppFullQualName mdl name
+ Nothing -> ppFullQualName is_infix mdl name
AliasedQual aliases localmdl ->
case (moduleString mdl == moduleString localmdl,
M.lookup mdl aliases) of
- (False, Just alias) -> ppQualName alias name
- _ -> ppName name
+ (False, Just alias) -> ppQualName is_infix alias name
+ _ -> ppName is_infix name
-ppFullQualName :: Module -> Name -> Html
-ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name
+ppFullQualName :: Maybe Bool -> Module -> Name -> Html
+ppFullQualName is_infix mdl name = wrapInfix is_infix (getOccName name) qname
+ where
+ qname = toHtml $ moduleString mdl ++ '.' : getOccString name
-ppQualName :: ModuleName -> Name -> Html
-ppQualName mdlName name =
- toHtml $ moduleNameString mdlName ++ '.' : getOccString name
+ppQualName :: Maybe Bool -> ModuleName -> Name -> Html
+ppQualName is_infix mdlName name = wrapInfix is_infix (getOccName name) qname
+ where
+ qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
-ppName :: Name -> Html
-ppName name = toHtml (getOccString name)
+ppName :: Maybe Bool -> Name -> Html
+ppName is_infix name = wrapInfix is_infix (getOccName name) $ toHtml (getOccString name)
ppBinder :: Bool -> OccName -> Html
@@ -116,12 +123,17 @@ ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
ppBinder' :: Bool -> OccName -> Html
-- The Bool indicates if it is to be rendered in infix notation
-ppBinder' is_infix n = wrap $ ppOccName n
+ppBinder' is_infix n = wrapInfix (Just is_infix) n $ ppOccName n
+
+wrapInfix :: Maybe Bool -> OccName -> Html -> Html
+wrapInfix Nothing _ = id
+wrapInfix (Just is_infix) n | is_star_kind = id
+ | is_infix && not is_sym = quote
+ | not is_infix && is_sym = parens
+ | otherwise = id
where
- wrap | is_infix && not is_sym = quote
- | not is_infix && is_sym = parens
- | otherwise = id
- is_sym = isVarSym n || isConSym n
+ is_sym = isSymOcc n
+ is_star_kind = isTcOcc n && occNameString 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 03:30:17 +0000