aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorHécate Moonlight <Kleidukos@users.noreply.github.com>2021-02-07 16:21:29 +0100
committerGitHub <noreply@github.com>2021-02-07 16:21:29 +0100
commit9dab3bdc9f31c0389e69f21c2199f874d151ccb7 (patch)
tree36252b271f70ae2730063a39dff19fdfb4fadf8d /haddock-api/src/Haddock
parenta10d042ac76c990764250244ac801db16858b6ee (diff)
parent62bf25cb0931e761e8b2ff082a703d79386fc8bc (diff)
Merge pull request #1314 from tweag/show-linear-backport
Backport #1238 (linear types) to ghc-9.0
Diffstat (limited to 'haddock-api/src/Haddock')
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs9
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs9
3 files changed, 25 insertions, 7 deletions
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 2371695f..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
@@ -1368,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/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 "."