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

7 files changed, 259 insertions, 72 deletions

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: &quot;mathjax&quot;, ignoreClass: &quot;.*&quot; } });</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) =&gt; a -&gt; 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) =&gt; a -&gt; 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"
+		>=&gt; a</td
+		><td class="doc"
+		><p
+		  >this gets turned into a string...</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; 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"
+		>=&gt; a</td
+		><td class="doc"
+		><p
+		  >this gets turned into a string...</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; 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"
-		>-&gt; d</td
+		>-&gt; <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"
-		>=&gt; a b c d</td
+		>=&gt; <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 =&gt; <a href="#"
+	      > x =&gt;  <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 =&gt; <a id="v:BlubCtor" class="def"
+		  > x =&gt;  <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 =&gt; <a href="#"
+		  > b =&gt;  <a href="#"
 		  >Ex1</a
 		  > b</li
 		><li
@@ -591,7 +591,7 @@
 		><li
 		>| <a href="#" title="Test"
 		  >C</a
-		  > a =&gt; <a href="#"
+		  > a =&gt;  <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 =&gt; <a id="v:Ex1" class="def"
+		  > b =&gt;  <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 =&gt; <a id="v:Ex3" class="def"
+		  > a =&gt;  <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