From b4b4d896d2d68d6c48e7db7bfe95c185ca0709cb Mon Sep 17 00:00:00 2001 From: Krzysztof Gogolewski 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. --- 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 +- html-test/ref/LinearTypes.html | 108 ++++++++++++++++++++++++ html-test/src/LinearTypes.hs | 14 +++ latex-test/ref/LinearTypes/LinearTypes.tex | 30 +++++++ latex-test/ref/LinearTypes/haddock.sty | 57 +++++++++++++ latex-test/ref/LinearTypes/main.tex | 11 +++ latex-test/src/LinearTypes/LinearTypes.hs | 14 +++ 9 files changed, 259 insertions(+), 7 deletions(-) create mode 100644 html-test/ref/LinearTypes.html create mode 100644 html-test/src/LinearTypes.hs create mode 100644 latex-test/ref/LinearTypes/LinearTypes.tex create mode 100644 latex-test/ref/LinearTypes/haddock.sty create mode 100644 latex-test/ref/LinearTypes/main.tex create mode 100644 latex-test/src/LinearTypes/LinearTypes.hs diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 52df9dc8..40607082 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1073,9 +1073,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 @@ -1367,14 +1371,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 e9806471..6f474bd9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1226,10 +1226,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..18cd060a --- /dev/null +++ b/html-test/ref/LinearTypes.html @@ -0,0 +1,108 @@ +LinearTypes
 
Safe HaskellSafe-Inferred

LinearTypes

Synopsis

Documentation

unrestricted :: a -> b #

Does something unrestricted.

linear :: a %1 -> b #

Does something linear.

poly :: a %m -> b #

Does something polymorphic.

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..d02b6aa7 --- /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 -- cgit v1.2.3