aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2020-12-16 20:03:14 +0100
committerKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2021-02-05 23:05:56 +0100
commit62bf25cb0931e761e8b2ff082a703d79386fc8bc (patch)
tree2db43650cb17a48e501ae84f6dc041f5dcd619fc /haddock-api/src/Haddock/Backends/Xhtml
parenta2f9f297d17059b3fc68ce4a245702278a5d8340 (diff)
Display linear/multiplicity arrows correctly (#1238)
Previously we were ignoring multiplicity and displayed a %1 -> b as a -> b. (cherry picked from commit b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb)
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs9
2 files changed, 14 insertions, 4 deletions
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/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 "."