Display linear/multiplicity arrows correctly (#1238)

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

(cherry picked from commit b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb)

9 files changed, 259 insertions, 7 deletions

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 "."
 
diff --git a/html-test/ref/LinearTypes.html b/html-test/ref/LinearTypes.html
new file mode 100644
index 00000000..48ad04e2
--- /dev/null
+++ b/html-test/ref/LinearTypes.html
@@ -0,0 +1,108 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+     /><meta name="viewport" content="width=device-width, initial-scale=1"
+     /><title
+    >LinearTypes</title
+    ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><link rel="stylesheet" type="text/css" href="#"
+     /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+    ></script
+    ><script type="text/x-mathjax-config"
+    >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+    ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+    ></script
+    ></head
+  ><body
+  ><div id="package-header"
+    ><span class="caption empty"
+      >&nbsp;</span
+      ><ul class="links" id="page-menu"
+      ><li
+	><a href="#"
+	  >Contents</a
+	  ></li
+	><li
+	><a href="#"
+	  >Index</a
+	  ></li
+	></ul
+      ></div
+    ><div id="content"
+    ><div id="module-header"
+      ><table class="info"
+	><tr
+	  ><th
+	    >Safe Haskell</th
+	    ><td
+	    >Safe-Inferred</td
+	    ></tr
+	  ></table
+	><p class="caption"
+	>LinearTypes</p
+	></div
+      ><div id="synopsis"
+      ><details id="syn"
+	><summary
+	  >Synopsis</summary
+	  ><ul class="details-toggle" data-details-id="syn"
+	  ><li class="src short"
+	    ><a href="#"
+	      >unrestricted</a
+	      > :: a -&gt; b</li
+	    ><li class="src short"
+	    ><a href="#"
+	      >linear</a
+	      > :: a %1 -&gt; b</li
+	    ><li class="src short"
+	    ><a href="#"
+	      >poly</a
+	      > :: a %m -&gt; b</li
+	    ></ul
+	  ></details
+	></div
+      ><div id="interface"
+      ><h1
+	>Documentation</h1
+	><div class="top"
+	><p class="src"
+	  ><a id="v:unrestricted" class="def"
+	    >unrestricted</a
+	    > :: a -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something unrestricted.</p
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a id="v:linear" class="def"
+	    >linear</a
+	    > :: a %1 -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something linear.</p
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a id="v:poly" class="def"
+	    >poly</a
+	    > :: a %m -&gt; b <a href="#" class="selflink"
+	    >#</a
+	    ></p
+	  ><div class="doc"
+	  ><p
+	    >Does something polymorphic.</p
+	    ></div
+	  ></div
+	></div
+      ></div
+    ></body
+  ></html
+>
diff --git a/html-test/src/LinearTypes.hs b/html-test/src/LinearTypes.hs
new file mode 100644
index 00000000..cb4eb138
--- /dev/null
+++ b/html-test/src/LinearTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearTypes where
+
+-- | Does something unrestricted.
+unrestricted :: a -> b
+unrestricted = undefined
+
+-- | Does something linear.
+linear :: a %1 -> b
+linear = linear
+
+-- | Does something polymorphic.
+poly :: a %m -> b
+poly = poly
diff --git a/latex-test/ref/LinearTypes/LinearTypes.tex b/latex-test/ref/LinearTypes/LinearTypes.tex
new file mode 100644
index 00000000..cb583ca8
--- /dev/null
+++ b/latex-test/ref/LinearTypes/LinearTypes.tex
@@ -0,0 +1,30 @@
+\haddockmoduleheading{LinearTypes}
+\label{module:LinearTypes}
+\haddockbeginheader
+{\haddockverb\begin{verbatim}
+module LinearTypes (
+    unrestricted, linear, poly
+  ) where\end{verbatim}}
+\haddockendheader
+
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+unrestricted :: a -> b
+\end{tabular}]
+{\haddockbegindoc
+Does something unrestricted.\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+linear :: a {\char '45}1 -> b
+\end{tabular}]
+{\haddockbegindoc
+Does something linear.\par}
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+poly :: a {\char '45}m -> b
+\end{tabular}]
+{\haddockbegindoc
+Does something polymorphic.\par}
+\end{haddockdesc}
\ No newline at end of file
diff --git a/latex-test/ref/LinearTypes/haddock.sty b/latex-test/ref/LinearTypes/haddock.sty
new file mode 100644
index 00000000..6e031a98
--- /dev/null
+++ b/latex-test/ref/LinearTypes/haddock.sty
@@ -0,0 +1,57 @@
+% Default Haddock style definitions.  To use your own style, invoke
+% Haddock with the option --latex-style=mystyle.
+
+\usepackage{tabulary} % see below
+
+% make hyperlinks in the PDF, and add an expandabale index
+\usepackage[pdftex,bookmarks=true]{hyperref}
+
+\newenvironment{haddocktitle}
+  {\begin{center}\bgroup\large\bfseries}
+  {\egroup\end{center}}
+\newenvironment{haddockprologue}{\vspace{1in}}{}
+
+\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
+
+\newcommand{\haddockbeginheader}{\hrulefill}
+\newcommand{\haddockendheader}{\noindent\hrulefill}
+
+% a little gap before the ``Methods'' header
+\newcommand{\haddockpremethods}{\vspace{2ex}}
+
+% inserted before \\begin{verbatim}
+\newcommand{\haddockverb}{\small}
+
+% an identifier: add an index entry
+\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
+
+% The tabulary environment lets us have a column that takes up ``the
+% rest of the space''.  Unfortunately it doesn't allow
+% the \end{tabulary} to be in the expansion of a macro, it must appear
+% literally in the document text, so Haddock inserts
+% the \end{tabulary} itself.
+\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
+
+\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
+\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
+
+\makeatletter
+\newenvironment{haddockdesc}
+               {\list{}{\labelwidth\z@ \itemindent-\leftmargin
+                        \let\makelabel\haddocklabel}}
+               {\endlist}
+\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
+\makeatother
+
+% after a declaration, start a new line for the documentation.
+% Otherwise, the documentation starts right after the declaration,
+% because we're using the list environment and the declaration is the
+% ``label''.  I tried making this newline part of the label, but
+% couldn't get that to work reliably (the space seemed to stretch
+% sometimes).
+\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
+
+% spacing between paragraphs and no \parindent looks better
+\parskip=10pt plus2pt minus2pt
+\setlength{\parindent}{0cm}
diff --git a/latex-test/ref/LinearTypes/main.tex b/latex-test/ref/LinearTypes/main.tex
new file mode 100644
index 00000000..655261c3
--- /dev/null
+++ b/latex-test/ref/LinearTypes/main.tex
@@ -0,0 +1,11 @@
+\documentclass{book}
+\usepackage{haddock}
+\begin{document}
+\begin{titlepage}
+\begin{haddocktitle}
+
+\end{haddocktitle}
+\end{titlepage}
+\tableofcontents
+\input{LinearTypes}
+\end{document}
\ No newline at end of file
diff --git a/latex-test/src/LinearTypes/LinearTypes.hs b/latex-test/src/LinearTypes/LinearTypes.hs
new file mode 100644
index 00000000..cb4eb138
--- /dev/null
+++ b/latex-test/src/LinearTypes/LinearTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE LinearTypes #-}
+module LinearTypes where
+
+-- | Does something unrestricted.
+unrestricted :: a -> b
+unrestricted = undefined
+
+-- | Does something linear.
+linear :: a %1 -> b
+linear = linear
+
+-- | Does something polymorphic.
+poly :: a %m -> b
+poly = poly