From 62bf25cb0931e761e8b2ff082a703d79386fc8bc Mon Sep 17 00:00:00 2001
From: Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io>
Date: Wed, 16 Dec 2020 20:03:14 +0100
Subject: Display linear/multiplicity arrows correctly (#1238)

Previously we were ignoring multiplicity and displayed
a %1 -> b as a -> b.

(cherry picked from commit b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb)
---
 haddock-api/src/Haddock/Backends/LaTeX.hs       | 14 +++++++++++---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs  |  9 +++++++--
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs |  9 +++++++--
 3 files changed, 25 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src')

diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df81fd6e..45574e06 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
@@ -1363,14 +1367,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 "."
 
-- 
cgit v1.2.3