Omit unnecessary foralls and fix #315

This also fixes #86.

3 files changed, 159 insertions, 25 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 8e42ff47..7b30b52f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -138,27 +138,26 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
 
     do_largs n leader (L _ t) = do_args n leader t
     do_args :: Int -> Html -> HsType DocName -> [SubDecl]
-    do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
-      = (leader <+>
-          hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
-          ppLContextNoArrow lctxt unicode qual,
-          Nothing, [])
-        : do_largs n (darrow unicode) ltype
-    do_args n leader (HsForAllTy Implicit _ lctxt ltype)
-      | not (null (unLoc lctxt))
-      = (leader <+> ppLContextNoArrow lctxt unicode qual,
-          Nothing, [])
-        : do_largs n (darrow unicode) ltype
-      -- if we're not showing any 'forall' or class constraints or
-      -- anything, skip having an empty line for the context.
-      | otherwise
-      = do_largs n leader ltype
+    do_args n leader (HsForAllTy _ tvs lctxt ltype)
+      = case unLoc lctxt of
+        [] -> do_largs n leader' ltype
+        _  -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])
+              : do_largs n (darrow unicode) ltype
+      where leader' = leader <+> ppForAll tvs unicode qual
     do_args n leader (HsFunTy lt r)
       = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
         : do_largs (n+1) (arrow unicode) r
     do_args n leader t
       = [(leader <+> ppType unicode qual t, argDoc n, [])]
 
+ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html
+ppForAll tvs unicode qual =
+  case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs 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
@@ -618,7 +617,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
     -- (except each field gets its own line in docs, to match
     -- non-GADT records)
     RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
-                            ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
+                            ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',
                             doRecordFields fields,
                             char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
     InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
@@ -626,7 +625,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of
   where
     doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
     doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
-                             ppForAll forall_ ltvs lcontext unicode qual,
+                             ppForAllCon forall_ ltvs lcontext unicode qual,
                              ppLType unicode qual (foldr mkFunTy resTy args) ]
 
     header_  = ppConstrHdr forall_ tyVars context
@@ -687,7 +686,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, field
       (map (ppSideBySideField subdocs unicode qual) fields)
     doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
     doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
-        <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
+        <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,
                   ppLType unicode qual (foldr mkFunTy resTy args) ]
         <+> fixity
 
@@ -805,9 +804,9 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
 -- Drop top-level for-all type variables in user style
 -- since they are implicit in Haskell
 
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName
          -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
-ppForAll expl tvs cxt unicode qual
+ppForAllCon expl tvs cxt unicode qual
   | show_forall = forall_part <+> ppLContext cxt unicode qual
   | otherwise   = ppLContext cxt unicode qual
   where
@@ -822,7 +821,7 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
 
 ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
 ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
-  = maybeParen ctxt_prec pREC_FUN $ ppForAll expl tvs ctxt unicode qual
+  = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt unicode qual
                                     <+> ppr_mono_lty pREC_TOP ty unicode qual
 
 -- UnicodeSyntax alternatives
diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html
index d3fea6b7..5c1fe892 100644
--- a/html-test/ref/FunArgs.html
+++ b/html-test/ref/FunArgs.html
@@ -55,9 +55,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_FunArgs.html");};
 	    ><table
 	    ><tr
 	      ><td class="src"
-		>:: <span class="keyword"
-		  >forall</span
-		  > a . <a href=""
+		>:: <a href=""
 		  >Ord</a
 		  > a</td
 		><td class="doc empty"
@@ -154,6 +152,122 @@ window.onload = function () {pageLoad();setSynopsis("mini_FunArgs.html");};
 	      ></table
 	    ></div
 	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:h" class="def"
+	    >h</a
+	    ></p
+	  ><div class="subs arguments"
+	  ><p class="caption"
+	    >Arguments</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		>:: a</td
+		><td class="doc"
+		><p
+		  >First argument</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; b</td
+		><td class="doc"
+		><p
+		  >Second argument</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; c</td
+		><td class="doc"
+		><p
+		  >Third argument</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; d</td
+		><td class="doc"
+		><p
+		  >Result</p
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:i" class="def"
+	    >i</a
+	    ></p
+	  ><div class="subs arguments"
+	  ><p class="caption"
+	    >Arguments</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		>:: <span class="keyword"
+		  >forall</span
+		  > (b :: <a href=""
+		  >()</a
+		  >). (d ~ <a href=""
+		  >()</a
+		  >)</td
+		><td class="doc empty"
+		>&nbsp;</td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>=&gt; a b c d</td
+		><td class="doc"
+		><p
+		  >abcd</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; ()</td
+		><td class="doc"
+		><p
+		  >Result</p
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
+	><div class="top"
+	><p class="src"
+	  ><a name="v:j" class="def"
+	    >j</a
+	    ></p
+	  ><div class="subs arguments"
+	  ><p class="caption"
+	    >Arguments</p
+	    ><table
+	    ><tr
+	      ><td class="src"
+		>:: <span class="keyword"
+		  >forall</span
+		  > (a :: <a href=""
+		  >()</a
+		  >). proxy a</td
+		><td class="doc"
+		><p
+		  >First argument</p
+		  ></td
+		></tr
+	      ><tr
+	      ><td class="src"
+		>-&gt; b</td
+		><td class="doc"
+		><p
+		  >Result</p
+		  ></td
+		></tr
+	      ></table
+	    ></div
+	  ></div
 	></div
       ></div
     ><div id="footer"
diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs
index cfde185d..24e1ccff 100644
--- a/html-test/src/FunArgs.hs
+++ b/html-test/src/FunArgs.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies #-}
 module FunArgs where
 
 f :: forall a. Ord a
@@ -15,3 +15,24 @@ g :: a -- ^ First argument
   -> c -- ^ Third argument
   -> d -- ^ Result
 g = undefined
+
+
+h :: forall a b c
+  .  a -- ^ First argument
+  -> b -- ^ Second argument
+  -> c -- ^ Third argument
+  -> forall d. d -- ^ Result
+h = undefined
+
+
+i :: forall a (b :: ()) d. (d ~ '())
+  => forall c
+  .  a b c d -- ^ abcd
+  -> ()      -- ^ Result
+i = undefined
+
+
+j :: forall proxy (a :: ()) b
+  .  proxy a -- ^ First argument
+  -> b       -- ^ Result
+j = undefined