diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-12-16 20:03:14 +0100 |
|---|---|---|
| committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-02-05 23:05:56 +0100 |
| commit | 62bf25cb0931e761e8b2ff082a703d79386fc8bc (patch) | |
| tree | 2db43650cb17a48e501ae84f6dc041f5dcd619fc /haddock-api/src/Haddock/Backends/Xhtml | |
| parent | a2f9f297d17059b3fc68ce4a245702278a5d8340 (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.hs | 9 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 9 |
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 "." |