Skip to content
This repository was archived by the owner on Aug 3, 2024. It is now read-only.

Commit 62bf25c

Browse files
monoidalmonoidal
committed
Display linear/multiplicity arrows correctly (#1238)
Previously we were ignoring multiplicity and displayed a %1 -> b as a -> b. (cherry picked from commit b4b4d89)
1 parent a2f9f29 commit 62bf25c

File tree

9 files changed

+259
-7
lines changed

9 files changed

+259
-7
lines changed

‎haddock-api/src/Haddock/Backends/LaTeX.hs

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1072,9 +1072,13 @@ ppr_mono_ty (HsForAllTy _ tele ty) unicode
10721072
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
10731073
= sep [ ppLContext ctxt unicode
10741074
, ppr_mono_lty ty unicode ]
1075-
ppr_mono_ty (HsFunTy _ _ ty1 ty2) u
1075+
ppr_mono_ty (HsFunTy _ mult ty1 ty2) u
10761076
= sep [ ppr_mono_lty ty1 u
1077-
, arrow u <+> ppr_mono_lty ty2 u ]
1077+
, arr <+> ppr_mono_lty ty2 u ]
1078+
where arr = case mult of
1079+
HsLinearArrow _ -> lollipop u
1080+
HsUnrestrictedArrow _ -> arrow u
1081+
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u
10781082

10791083
ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
10801084
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
@@ -1363,14 +1367,18 @@ quote :: LaTeX -> LaTeX
13631367
quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
13641368

13651369

1366-
dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
1370+
dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX
13671371
dcolon unicode = text (if unicode then "∷" else "::")
13681372
arrow unicode = text (if unicode then "→" else "->")
1373+
lollipop unicode = text (if unicode then "⊸" else "%1 ->")
13691374
darrow unicode = text (if unicode then "⇒" else "=>")
13701375
forallSymbol unicode = text (if unicode then "∀" else "forall")
13711376
starSymbol unicode = text (if unicode then "★" else "*")
13721377
atSign unicode = text (if unicode then "@" else "@")
13731378

1379+
multAnnotation :: LaTeX
1380+
multAnnotation = text "%"
1381+
13741382
dot :: LaTeX
13751383
dot = char '.'
13761384

‎haddock-api/src/Haddock/Backends/Xhtml/Decl.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1213,10 +1213,15 @@ ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _
12131213
| otherwise = ppDocName q Prefix True name
12141214
ppr_mono_ty (HsStarTy _ isUni) u _ _ =
12151215
toHtml (if u || isUni then "★" else "*")
1216-
ppr_mono_ty (HsFunTy _ _ ty1 ty2) u q e =
1216+
ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
12171217
hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
1218-
, arrow u <+> ppr_mono_lty ty2 u q e
1218+
, arr <+> ppr_mono_lty ty2 u q e
12191219
]
1220+
where arr = case mult of
1221+
HsLinearArrow _ -> lollipop u
1222+
HsUnrestrictedArrow _ -> arrow u
1223+
HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
1224+
12201225
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
12211226
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
12221227
ppr_mono_ty (HsSumTy _ tys) u q _ =

‎haddock-api/src/Haddock/Backends/Xhtml/Utils.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,8 @@ module Haddock.Backends.Xhtml.Utils (
2121
keyword, punctuate,
2222

2323
braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
24-
arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
24+
arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
25+
multAnnotation,
2526
atSign,
2627

2728
hsep, vcat,
@@ -187,13 +188,17 @@ ubxparens :: Html -> Html
187188
ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
188189

189190

190-
dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
191+
dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html
191192
dcolon unicode = toHtml (if unicode then "∷" else "::")
192193
arrow unicode = toHtml (if unicode then "→" else "->")
194+
lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->")
193195
darrow unicode = toHtml (if unicode then "⇒" else "=>")
194196
forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
195197
atSign unicode = toHtml (if unicode then "@" else "@")
196198

199+
multAnnotation :: Html
200+
multAnnotation = toHtml "%"
201+
197202
dot :: Html
198203
dot = toHtml "."
199204

‎html-test/ref/LinearTypes.html

Lines changed: 108 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,108 @@
1+
<html xmlns="http://www.w3.org/1999/xhtml"
2+
><head
3+
><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
4+
/><meta name="viewport" content="width=device-width, initial-scale=1"
5+
/><title
6+
>LinearTypes</title
7+
><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
8+
/><link rel="stylesheet" type="text/css" href="#"
9+
/><link rel="stylesheet" type="text/css" href="#"
10+
/><script src="haddock-bundle.min.js" async="async" type="text/javascript"
11+
></script
12+
><script type="text/x-mathjax-config"
13+
>MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
14+
><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
15+
></script
16+
></head
17+
><body
18+
><div id="package-header"
19+
><span class="caption empty"
20+
>&nbsp;</span
21+
><ul class="links" id="page-menu"
22+
><li
23+
><a href="#"
24+
>Contents</a
25+
></li
26+
><li
27+
><a href="#"
28+
>Index</a
29+
></li
30+
></ul
31+
></div
32+
><div id="content"
33+
><div id="module-header"
34+
><table class="info"
35+
><tr
36+
><th
37+
>Safe Haskell</th
38+
><td
39+
>Safe-Inferred</td
40+
></tr
41+
></table
42+
><p class="caption"
43+
>LinearTypes</p
44+
></div
45+
><div id="synopsis"
46+
><details id="syn"
47+
><summary
48+
>Synopsis</summary
49+
><ul class="details-toggle" data-details-id="syn"
50+
><li class="src short"
51+
><a href="#"
52+
>unrestricted</a
53+
> :: a -&gt; b</li
54+
><li class="src short"
55+
><a href="#"
56+
>linear</a
57+
> :: a %1 -&gt; b</li
58+
><li class="src short"
59+
><a href="#"
60+
>poly</a
61+
> :: a %m -&gt; b</li
62+
></ul
63+
></details
64+
></div
65+
><div id="interface"
66+
><h1
67+
>Documentation</h1
68+
><div class="top"
69+
><p class="src"
70+
><a id="v:unrestricted" class="def"
71+
>unrestricted</a
72+
> :: a -&gt; b <a href="#" class="selflink"
73+
>#</a
74+
></p
75+
><div class="doc"
76+
><p
77+
>Does something unrestricted.</p
78+
></div
79+
></div
80+
><div class="top"
81+
><p class="src"
82+
><a id="v:linear" class="def"
83+
>linear</a
84+
> :: a %1 -&gt; b <a href="#" class="selflink"
85+
>#</a
86+
></p
87+
><div class="doc"
88+
><p
89+
>Does something linear.</p
90+
></div
91+
></div
92+
><div class="top"
93+
><p class="src"
94+
><a id="v:poly" class="def"
95+
>poly</a
96+
> :: a %m -&gt; b <a href="#" class="selflink"
97+
>#</a
98+
></p
99+
><div class="doc"
100+
><p
101+
>Does something polymorphic.</p
102+
></div
103+
></div
104+
></div
105+
></div
106+
></body
107+
></html
108+
>

‎html-test/src/LinearTypes.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
{-# LANGUAGE LinearTypes #-}
2+
module LinearTypes where
3+
4+
-- | Does something unrestricted.
5+
unrestricted :: a -> b
6+
unrestricted = undefined
7+
8+
-- | Does something linear.
9+
linear :: a %1 -> b
10+
linear = linear
11+
12+
-- | Does something polymorphic.
13+
poly :: a %m -> b
14+
poly = poly

‎latex-test/ref/LinearTypes/LinearTypes.tex

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
\haddockmoduleheading{LinearTypes}
2+
\label{module:LinearTypes}
3+
\haddockbeginheader
4+
{\haddockverb\begin{verbatim}
5+
module LinearTypes (
6+
unrestricted, linear, poly
7+
) where\end{verbatim}}
8+
\haddockendheader
9+
10+
\begin{haddockdesc}
11+
\item[\begin{tabular}{@{}l}
12+
unrestricted :: a -> b
13+
\end{tabular}]
14+
{\haddockbegindoc
15+
Does something unrestricted.\par}
16+
\end{haddockdesc}
17+
\begin{haddockdesc}
18+
\item[\begin{tabular}{@{}l}
19+
linear :: a {\char '45}1 -> b
20+
\end{tabular}]
21+
{\haddockbegindoc
22+
Does something linear.\par}
23+
\end{haddockdesc}
24+
\begin{haddockdesc}
25+
\item[\begin{tabular}{@{}l}
26+
poly :: a {\char '45}m -> b
27+
\end{tabular}]
28+
{\haddockbegindoc
29+
Does something polymorphic.\par}
30+
\end{haddockdesc}

‎latex-test/ref/LinearTypes/haddock.sty

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
% Default Haddock style definitions. To use your own style, invoke
2+
% Haddock with the option --latex-style=mystyle.
3+
4+
\usepackage{tabulary} % see below
5+
6+
% make hyperlinks in the PDF, and add an expandabale index
7+
\usepackage[pdftex,bookmarks=true]{hyperref}
8+
9+
\newenvironment{haddocktitle}
10+
{\begin{center}\bgroup\large\bfseries}
11+
{\egroup\end{center}}
12+
\newenvironment{haddockprologue}{\vspace{1in}}{}
13+
14+
\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}
15+
16+
\newcommand{\haddockbeginheader}{\hrulefill}
17+
\newcommand{\haddockendheader}{\noindent\hrulefill}
18+
19+
% a little gap before the ``Methods'' header
20+
\newcommand{\haddockpremethods}{\vspace{2ex}}
21+
22+
% inserted before \\begin{verbatim}
23+
\newcommand{\haddockverb}{\small}
24+
25+
% an identifier: add an index entry
26+
\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}
27+
28+
% The tabulary environment lets us have a column that takes up ``the
29+
% rest of the space''. Unfortunately it doesn't allow
30+
% the \end{tabulary} to be in the expansion of a macro, it must appear
31+
% literally in the document text, so Haddock inserts
32+
% the \end{tabulary} itself.
33+
\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
34+
\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}
35+
36+
\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}
37+
\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}
38+
39+
\makeatletter
40+
\newenvironment{haddockdesc}
41+
{\list{}{\labelwidth\z@ \itemindent-\leftmargin
42+
\let\makelabel\haddocklabel}}
43+
{\endlist}
44+
\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}
45+
\makeatother
46+
47+
% after a declaration, start a new line for the documentation.
48+
% Otherwise, the documentation starts right after the declaration,
49+
% because we're using the list environment and the declaration is the
50+
% ``label''. I tried making this newline part of the label, but
51+
% couldn't get that to work reliably (the space seemed to stretch
52+
% sometimes).
53+
\newcommand{\haddockbegindoc}{\hfill\\[1ex]}
54+
55+
% spacing between paragraphs and no \parindent looks better
56+
\parskip=10pt plus2pt minus2pt
57+
\setlength{\parindent}{0cm}

‎latex-test/ref/LinearTypes/main.tex

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
\documentclass{book}
2+
\usepackage{haddock}
3+
\begin{document}
4+
\begin{titlepage}
5+
\begin{haddocktitle}
6+
7+
\end{haddocktitle}
8+
\end{titlepage}
9+
\tableofcontents
10+
\input{LinearTypes}
11+
\end{document}

‎latex-test/src/LinearTypes/LinearTypes.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
{-# LANGUAGE LinearTypes #-}
2+
module LinearTypes where
3+
4+
-- | Does something unrestricted.
5+
unrestricted :: a -> b
6+
unrestricted = undefined
7+
8+
-- | Does something linear.
9+
linear :: a %1 -> b
10+
linear = linear
11+
12+
-- | Does something polymorphic.
13+
poly :: a %m -> b
14+
poly = poly

0 commit comments

Comments
 (0)