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/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs21
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs15
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs9
6 files changed, 46 insertions, 19 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 58809f73..9a304030 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -325,7 +325,7 @@ markupTag dflags = Markup {
markupAppend = (++),
markupIdentifier = box (TagInline "a") . str . out dflags,
markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd),
- markupModule = box (TagInline "a") . str,
+ markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label),
markupWarning = box (TagInline "i"),
markupEmphasis = box (TagInline "i"),
markupBold = box (TagInline "b"),
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df81fd6e..ac904273 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1072,9 +1072,13 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
, ppr_mono_lty ty unicode ]
-ppr_mono_ty (HsFunTy _ _ ty1 ty2) u
+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
= sep [ ppr_mono_lty ty1 u
- , arrow u <+> ppr_mono_lty ty2 u ]
+ , arr <+> ppr_mono_lty ty2 u ]
+ where arr = case mult of
+ HsLinearArrow _ -> lollipop u
+ HsUnrestrictedArrow _ -> arrow u
+ HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1210,7 +1214,12 @@ latexMarkup = Markup
, markupAppend = \l r v -> l v . r v
, markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i))
, markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i))
- , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl)))
+ , markupModule =
+ \(ModLink m mLabel) v ->
+ case mLabel of
+ Just lbl -> inlineElem . tt $ lbl v empty
+ Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m
+ in (tt (text mdl)))
, markupWarning = \p v -> p v
, markupEmphasis = \p v -> inlineElem (emph (p v empty))
, markupBold = \p v -> inlineElem (bold (p v empty))
@@ -1363,14 +1372,18 @@ quote :: LaTeX -> LaTeX
quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
-dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
+dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
dcolon unicode = text (if unicode then "∷" else "::")
arrow unicode = text (if unicode then "→" else "->")
+lollipop unicode = text (if unicode then "⊸" else "%1 ->")
darrow unicode = text (if unicode then "⇒" else "=>")
forallSymbol unicode = text (if unicode then "∀" else "forall")
starSymbol unicode = text (if unicode then "★" else "*")
atSign unicode = text (if unicode then "@" else "@")
+multAnnotation :: LaTeX
+multAnnotation = text "%"
+
dot :: LaTeX
dot = char '.'
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index eeb9fa94..0b0050df 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1213,10 +1213,15 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
| otherwise = ppDocName q Prefix True name
ppr_mono_ty (HsStarTy _ isUni) u _ _ =
toHtml (if u || isUni then "★" else "*")
-ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e =
+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
- , arrow u <+> ppr_mono_lty ty2 u q e
+ , arr <+> ppr_mono_lty ty2 u q e
]
+ where arr = case mult of
+ HsLinearArrow _ -> lollipop u
+ HsUnrestrictedArrow _ -> arrow u
+ HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
ppr_mono_ty (HsSumTy _ tys) u q _ =
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 378d0559..7670b193 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -44,13 +44,14 @@ parHtmlMarkup qual insertAnchors ppId = Markup {
markupAppend = (+++),
markupIdentifier = thecode . ppId insertAnchors,
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
- markupModule = \m -> let (mdl,ref) = break (=='#') m
- -- Accomodate for old style
- -- foo\#bar anchors
- mdl' = case reverse mdl of
- '\\':_ -> init mdl
- _ -> mdl
- in ppModuleRef (mkModuleName mdl') ref,
+ markupModule = \(ModLink m lbl) ->
+ let (mdl,ref) = break (=='#') m
+ -- Accomodate for old style
+ -- foo\#bar anchors
+ mdl' = case reverse mdl of
+ '\\':_ -> init mdl
+ _ -> mdl
+ in ppModuleRef lbl (mkModuleName mdl') ref,
markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupBold = strong,
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index 8553cdfb..b324fa38 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -186,9 +186,12 @@ ppModule mdl = anchor ! [href (moduleUrl mdl)]
<< toHtml (moduleString mdl)
-ppModuleRef :: ModuleName -> String -> Html
-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
- << toHtml (moduleNameString mdl)
+ppModuleRef :: Maybe Html -> ModuleName -> String -> Html
+ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << toHtml (moduleNameString mdl)
+ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << lbl
+
-- NB: The ref parameter already includes the '#'.
-- This function is only called from markupModule expanding a
-- DocModule, which doesn't seem to be ever be used.
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index f5f64f51..238f0046 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -21,7 +21,8 @@ module Haddock.Backends.Xhtml.Utils (
keyword, punctuate,
braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
- arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+ arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+ multAnnotation,
atSign,
hsep, vcat,
@@ -187,13 +188,17 @@ ubxparens :: Html -> Html
ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
-dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
+dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html
dcolon unicode = toHtml (if unicode then "∷" else "::")
arrow unicode = toHtml (if unicode then "→" else "->")
+lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->")
darrow unicode = toHtml (if unicode then "⇒" else "=>")
forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
atSign unicode = toHtml (if unicode then "@" else "@")
+multAnnotation :: Html
+multAnnotation = toHtml "%"
+
dot :: Html
dot = toHtml "."
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 13:48:45 +0000