From a36ab92b289b4d6b707696eef49145bc7ced4957 Mon Sep 17 00:00:00 2001
From: Alec Theriault <alec.theriault@gmail.com>
Date: Sun, 25 Nov 2018 10:32:22 -0800
Subject: More uniform handling of `forall`'s in HTML/LaTeX
* don't forget to print explicit `forall`'s when there are arg docs
* when printing an explicit `forall`, print all tyvars
Fixes #973
---
haddock-api/src/Haddock/Backends/LaTeX.hs | 49 ++++---
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 61 ++++-----
html-test/ref/Bug973.html | 174 +++++++++++++++++++++++++
html-test/ref/FunArgs.html | 20 ++-
html-test/ref/PatternSyns.html | 4 +-
html-test/ref/Test.html | 8 +-
html-test/src/Bug975.hs | 15 +++
7 files changed, 259 insertions(+), 72 deletions(-)
create mode 100644 html-test/ref/Bug973.html
create mode 100644 html-test/src/Bug975.hs
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 613c6deb..40ea916f 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -458,7 +458,7 @@ ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode
text "\\end{tabulary}\\par" $$
fromMaybe empty (documentationToLaTeX doc)
--- This splits up a type signature along `->` and adds docs (when they exist)
+-- | This splits up a type signature along @->@ and adds docs (when they exist)
-- to the arguments. The output is a list of (leader/seperator, argument and
-- its doc)
ppSubSigLike :: Bool -- ^ unicode
@@ -474,13 +474,10 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ
arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs
do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]
- do_args _n leader (HsForAllTy _ tvs ltype)
- = [ ( decltt leader
- , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))
- <+> ppLType unicode ltype
- ) ]
+ do_args n leader (HsForAllTy _ tvs ltype)
+ = do_largs n (leader <+> decltt (ppForAllPart unicode tvs)) ltype
do_args n leader (HsQualTy _ lctxt ltype)
- = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl)
+ = (decltt leader, decltt (ppLContextNoArrow lctxt unicode) <+> nl)
: do_largs n (darrow unicode) ltype
do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r)
@@ -512,8 +509,9 @@ ppTypeSig nms ty unicode =
<+> ppType unicode ty
-ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX]
-ppTyVars = map (ppSymName . getName . hsLTyVarName)
+-- | Pretty-print type variables.
+ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX]
+ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs
tyvarNames :: LHsQTyVars DocNameI -> [Name]
@@ -716,15 +714,21 @@ ppDataDecl pats instances subdocs doc dataDecl unicode =
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX
-ppConstrHdr forall tvs ctxt unicode
- = (if null tvs then empty else ppForall)
- <+>
- (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
+ppConstrHdr
+ :: Bool -- ^ print explicit foralls
+ -> [LHsTyVarBndr DocNameI] -- ^ type variables
+ -> HsContext DocNameI -- ^ context
+ -> Bool -- ^ unicode
+ -> LaTeX
+ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt
where
- ppForall = case forall of
- True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
- False -> empty
+ ppForall
+ | null tvs || not forall_ = empty
+ | otherwise = ppForAllPart unicode tvs
+
+ ppCtxt
+ | null ctxt = empty
+ | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space
-- | Pretty-print a constructor
@@ -753,10 +757,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
-- First line of the constructor (no doc, no fields, single-line)
decl = case con of
ConDeclH98{ con_args = det
- , con_ex_tvs = vars
+ , con_ex_tvs = tyVars
, con_mb_cxt = cxt
- } -> let tyVars = map (getName . hsLTyVarName) vars
- context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = unLoc (fromMaybe (noLoc []) cxt)
forall_ = False
header_ = ppConstrHdr forall_ tyVars context unicode
in case det of
@@ -1010,13 +1013,17 @@ ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
+ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX
+ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot
+
+
ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
ppr_mono_ty (HsForAllTy _ tvs ty) unicode
- = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ = sep [ ppForAllPart unicode tvs
, ppr_mono_lty ty unicode ]
ppr_mono_ty (HsQualTy _ ctxt ty) unicode
= sep [ ppLContext ctxt unicode
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 9df6acc0..775e0c41 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -130,8 +130,8 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
curname = getName <$> listToMaybe docnames
--- This splits up a type signature along `->` and adds docs (when they exist) to
--- the arguments.
+-- | This splits up a type signature along @->@ and adds docs (when they exist)
+-- to the arguments.
--
-- If one passes in a list of the available subdocs, any top-level `HsRecTy`
-- found will be expanded out into their fields.
@@ -149,9 +149,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]
do_args n leader (HsForAllTy _ tvs ltype)
- = do_largs n leader' ltype
- where
- leader' = leader <+> ppForAll tvs unicode qual
+ = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype
do_args n leader (HsQualTy _ lctxt ltype)
| null (unLoc lctxt)
@@ -185,15 +183,6 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ
gadtOpen = toHtml "{"
-
-ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html
-ppForAll tvs unicode qual =
- case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of
- [] -> noHtml
- ts -> forallSymbol unicode <+> hsep ts +++ dot
- where ppKTv n k = parens $
- ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k
-
ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
ppFixities [] _ = noHtml
ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
@@ -258,10 +247,6 @@ ppTypeSig summary nms pp_ty unicode =
htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
-ppTyName :: Name -> Html
-ppTyName = ppName Prefix
-
-
ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan
-> [DocName] -> HsType DocNameI
-> Html
@@ -814,24 +799,23 @@ ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualificati
ppShortConstrParts summary dataInst con unicode qual
= case con of
ConDeclH98{ con_args = det
- , con_ex_tvs = vars
+ , con_ex_tvs = tyVars
, con_mb_cxt = cxt
- } -> let tyVars = map (getName . hsLTyVarName) vars
- context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = unLoc (fromMaybe (noLoc []) cxt)
forall_ = False
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
PrefixCon args ->
- ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
+ ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args)
, noHtml
, noHtml
)
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
RecCon (L _ fields) ->
- ( header_ +++ ppOcc <+> char '{'
+ ( header_ <+> ppOcc <+> char '{'
, shortSubDecls dataInst [ ppShortField summary unicode qual field
| L _ field <- fields
]
@@ -840,7 +824,7 @@ ppShortConstrParts summary dataInst con unicode qual
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2 ->
- ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1
+ ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts arg2
]
@@ -888,28 +872,27 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
decl = case con of
ConDeclH98{ con_args = det
- , con_ex_tvs = vars
+ , con_ex_tvs = tyVars
, con_mb_cxt = cxt
- } -> let tyVars = map (getName . hsLTyVarName) vars
- context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = unLoc (fromMaybe (noLoc []) cxt)
forall_ = False
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
PrefixCon args
- | hasArgDocs -> header_ +++ ppOcc <+> fixity
- | otherwise -> hsep [ header_ +++ ppOcc
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppOcc
, hsep (map (ppLParendType unicode qual HideEmptyContexts) args)
, fixity
]
-- Record constructor, e.g. 'Identity { runIdentity :: a }'
- RecCon _ -> header_ +++ ppOcc <+> fixity
+ RecCon _ -> header_ <+> ppOcc <+> fixity
-- Infix constructor, e.g. 'a :| [a]'
InfixCon arg1 arg2
- | hasArgDocs -> header_ +++ ppOcc <+> fixity
- | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1
+ | hasArgDocs -> header_ <+> ppOcc <+> fixity
+ | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1
, ppOccInfix
, ppLParendType unicode qual HideEmptyContexts arg2
, fixity
@@ -962,17 +945,17 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: Bool -- ^ print explicit foralls
- -> [Name] -- ^ type variables
- -> HsContext DocNameI -- ^ context
- -> Unicode -> Qualification -> Html
+ppConstrHdr
+ :: Bool -- ^ print explicit foralls
+ -> [LHsTyVarBndr DocNameI] -- ^ type variables
+ -> HsContext DocNameI -- ^ context
+ -> Unicode -> Qualification
+ -> Html
ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt
where
ppForall
| null tvs || not forall_ = noHtml
- | otherwise = forallSymbol unicode
- <+> hsep (map (ppName Prefix) tvs)
- <+> toHtml ". "
+ | otherwise = ppForAllPart unicode qual tvs
ppCtxt
| null ctxt = noHtml
diff --git a/html-test/ref/Bug973.html b/html-test/ref/Bug973.html
new file mode 100644
index 00000000..97d35758
--- /dev/null
+++ b/html-test/ref/Bug973.html
@@ -0,0 +1,174 @@
+<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
+ >Bug973</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"
+ ></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</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >Bug973</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="#"
+ >showRead</a
+ > :: <span class="keyword"
+ >forall</span
+ > a b. (<a href="#" title="Text.Show"
+ >Show</a
+ > a, <a href="#" title="Text.Read"
+ >Read</a
+ > b) => a -> b</li
+ ><li class="src short"
+ ><a href="#"
+ >showRead'</a
+ > :: <span class="keyword"
+ >forall</span
+ > b a. (<a href="#" title="Text.Show"
+ >Show</a
+ > a, <a href="#" title="Text.Read"
+ >Read</a
+ > b) => a -> b</li
+ ></ul
+ ></details
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:showRead" class="def"
+ >showRead</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="subs arguments"
+ ><p class="caption"
+ >Arguments</p
+ ><table
+ ><tr
+ ><td class="src"
+ >:: <span class="keyword"
+ >forall</span
+ > a b. (<a href="#" title="Text.Show"
+ >Show</a
+ > a, <a href="#" title="Text.Read"
+ >Read</a
+ > b)</td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ >=> a</td
+ ><td class="doc"
+ ><p
+ >this gets turned into a string...</p
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ >-> b</td
+ ><td class="doc"
+ ><p
+ >...from which this is read</p
+ ></td
+ ></tr
+ ></table
+ ></div
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:showRead-39-" class="def"
+ >showRead'</a
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="subs arguments"
+ ><p class="caption"
+ >Arguments</p
+ ><table
+ ><tr
+ ><td class="src"
+ >:: <span class="keyword"
+ >forall</span
+ > b a. (<a href="#" title="Text.Show"
+ >Show</a
+ > a, <a href="#" title="Text.Read"
+ >Read</a
+ > b)</td
+ ><td class="doc empty"
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ >=> a</td
+ ><td class="doc"
+ ><p
+ >this gets turned into a string...</p
+ ></td
+ ></tr
+ ><tr
+ ><td class="src"
+ >-> b</td
+ ><td class="doc"
+ ><p
+ >...from which this is read</p
+ ></td
+ ></tr
+ ></table
+ ></div
+ ><div class="doc"
+ ><p
+ >Same as <code
+ ><a href="#" title="Bug973"
+ >showRead</a
+ ></code
+ >, but with type variable order flipped</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ></div
+ ></body
+ ></html
+>
\ No newline at end of file
diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html
index bb54fa27..b40aa97c 100644
--- a/html-test/ref/FunArgs.html
+++ b/html-test/ref/FunArgs.html
@@ -58,7 +58,9 @@
><table
><tr
><td class="src"
- >:: <a href="#" title="Data.Ord"
+ >:: <span class="keyword"
+ >forall</span
+ > a. <a href="#" title="Data.Ord"
>Ord</a
> a</td
><td class="doc empty"
@@ -170,7 +172,9 @@
><table
><tr
><td class="src"
- >:: a</td
+ >:: <span class="keyword"
+ >forall</span
+ > a b c. a</td
><td class="doc"
><p
>First argument</p
@@ -194,7 +198,9 @@
></tr
><tr
><td class="src"
- >-> d</td
+ >-> <span class="keyword"
+ >forall</span
+ > d. d</td
><td class="doc"
><p
>Result</p
@@ -218,7 +224,7 @@
><td class="src"
>:: <span class="keyword"
>forall</span
- > (b :: ()). d ~ <a href="#" title="GHC.Tuple"
+ > a (b :: ()) d. d ~ <a href="#" title="GHC.Tuple"
>()</a
></td
><td class="doc empty"
@@ -226,7 +232,9 @@
></tr
><tr
><td class="src"
- >=> a b c d</td
+ >=> <span class="keyword"
+ >forall</span
+ > c. a b c d</td
><td class="doc"
><p
>abcd</p
@@ -258,7 +266,7 @@
><td class="src"
>:: <span class="keyword"
>forall</span
- > (a :: ()). proxy a</td
+ > proxy (a :: ()) b. proxy a</td
><td class="doc"
><p
>First argument</p
diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html
index a002ca32..bae4b0bd 100644
--- a/html-test/ref/PatternSyns.html
+++ b/html-test/ref/PatternSyns.html
@@ -106,7 +106,7 @@
>BlubType</a
> = <a href="#" title="Text.Show"
>Show</a
- > x => <a href="#"
+ > x => <a href="#"
>BlubCtor</a
> x</li
><li class="src short"
@@ -276,7 +276,7 @@
><td class="src"
><a href="#" title="Text.Show"
>Show</a
- > x => <a id="v:BlubCtor" class="def"
+ > x => <a id="v:BlubCtor" class="def"
>BlubCtor</a
> x</td
><td class="doc empty"
diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html
index 481f5d62..b8d7f251 100644
--- a/html-test/ref/Test.html
+++ b/html-test/ref/Test.html
@@ -581,7 +581,7 @@
><li
>= <a href="#" title="Test"
>C</a
- > b => <a href="#"
+ > b => <a href="#"
>Ex1</a
> b</li
><li
@@ -591,7 +591,7 @@
><li
>| <a href="#" title="Test"
>C</a
- > a => <a href="#"
+ > a => <a href="#"
>Ex3</a
> b</li
><li
@@ -2071,7 +2071,7 @@ is at the beginning of the line).</pre
><td class="src"
><a href="#" title="Test"
>C</a
- > b => <a id="v:Ex1" class="def"
+ > b => <a id="v:Ex1" class="def"
>Ex1</a
> b</td
><td class="doc empty"
@@ -2089,7 +2089,7 @@ is at the beginning of the line).</pre
><td class="src"
><a href="#" title="Test"
>C</a
- > a => <a id="v:Ex3" class="def"
+ > a => <a id="v:Ex3" class="def"
>Ex3</a
> b</td
><td class="doc empty"
diff --git a/html-test/src/Bug975.hs b/html-test/src/Bug975.hs
new file mode 100644
index 00000000..97ebabda
--- /dev/null
+++ b/html-test/src/Bug975.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE ExplicitForAll #-}
+module Bug973 where
+
+showRead
+ :: forall a b. (Show a, Read b)
+ => a -- ^ this gets turned into a string...
+ -> b -- ^ ...from which this is read
+showRead = read . show
+
+-- | Same as 'showRead', but with type variable order flipped
+showRead'
+ :: forall b a. (Show a, Read b)
+ => a -- ^ this gets turned into a string...
+ -> b -- ^ ...from which this is read
+showRead' = read . show
--
cgit v1.2.3