From 68a78932b5b004945f6681bd51e8080e868fc0ee Mon Sep 17 00:00:00 2001
From: Niklas Haas <git@nand.wakku.to>
Date: Sun, 9 Mar 2014 16:32:36 +0100
Subject: Group similar fixities together

Identical fixities declared for the same line should now render using
syntax like: infix 4 <, >=, >, <=
---
 html-test/ref/Operators.html       | 33 ++++++++++++++++++++++++++++++++-
 html-test/src/Operators.hs         | 10 +++++++++-
 src/Haddock/Backends/Xhtml/Decl.hs | 13 ++++++++++---
 3 files changed, 51 insertions(+), 5 deletions(-)

diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html
index 89ebbbbf..fdc46aa6 100644
--- a/html-test/ref/Operators.html
+++ b/html-test/ref/Operators.html
@@ -144,7 +144,19 @@ window.onload = function () {pageLoad();setSynopsis("mini_Operators.html");};
 	      ><li
 	      ><a href="#v:-62--62--60-"
 		>(&gt;&gt;&lt;)</a
+		>, <a href="#v:-60--60--62-"
+		>(&lt;&lt;&gt;)</a
 		> :: a -&gt; b -&gt; ()</li
+	      ><li
+	      ><a href="#v:-42--42--62-"
+		>(**&gt;)</a
+		>, <a href="#v:-60--42--42-"
+		>(&lt;**)</a
+		>, <a href="#v:-62--42--42-"
+		>(&gt;**)</a
+		>, <a href="#v:-42--42--60-"
+		>(**&lt;)</a
+		> :: a -&gt; a -&gt; ()</li
 	      ></ul
 	    ></li
 	  ><li class="src short"
@@ -345,10 +357,29 @@ window.onload = function () {pageLoad();setSynopsis("mini_Operators.html");};
 	  ><p class="caption"
 	    >Methods</p
 	    ><p class="src"
-	    >infixr 4 &gt;&gt;&lt;<br
+	    >infixl 5 &lt;&lt;&gt;<br
+	       />infixr 4 &gt;&gt;&lt;<br
 	       /><a name="v:-62--62--60-" class="def"
 	      >(&gt;&gt;&lt;)</a
+	      >, <a name="v:-60--60--62-" class="def"
+	      >(&lt;&lt;&gt;)</a
 	      > :: a -&gt; b -&gt; ()</p
+	    ><p class="src"
+	    >infixr 8 **&gt;, &gt;**<br
+	       />infixl 8 &lt;**, **&lt;<br
+	       /><a name="v:-42--42--62-" class="def"
+	      >(**&gt;)</a
+	      >, <a name="v:-60--42--42-" class="def"
+	      >(&lt;**)</a
+	      >, <a name="v:-62--42--42-" class="def"
+	      >(&gt;**)</a
+	      >, <a name="v:-42--42--60-" class="def"
+	      >(**&lt;)</a
+	      > :: a -&gt; a -&gt; ()</p
+	    ><div class="doc"
+	    ><p
+	      >Multiple fixities</p
+	      ></div
 	    ></div
 	  ></div
 	><div class="top"
diff --git a/html-test/src/Operators.hs b/html-test/src/Operators.hs
index a2e30c18..f7b4d0ab 100644
--- a/html-test/src/Operators.hs
+++ b/html-test/src/Operators.hs
@@ -45,11 +45,19 @@ infix 9 **
 class a ><> b where
   type a <>< b :: *
   data a ><< b
-  (>><) :: a -> b -> ()
+  (>><), (<<>) :: a -> b -> ()
+
+  -- | Multiple fixities
+  (**>), (**<), (>**), (<**) :: a -> a -> ()
+
 infixr 1 ><>
 infixl 2 <><
 infixl 3 ><<
 infixr 4 >><
+infixl 5 <<>
+
+infixr 8 **>, >**
+infixl 8 **<, <**
 
 -- | Type synonym with fixity
 type (a >-< b) = a <-> b
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 5cc86d48..42f06280 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TransformListComp #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html.Decl
@@ -34,6 +35,7 @@ import           Data.Monoid           ( mempty )
 import           Text.XHtml hiding     ( name, title, p, quote )
 
 import GHC
+import GHC.Exts
 import Name
 
 
@@ -158,15 +160,20 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)
       = [(leader <+> ppType unicode qual t, argDoc n, [])]
 
 ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
-ppFixities fs qual = vcat $ map ppFix fs
+ppFixities fs qual = vcat $ map ppFix uniq_fs
   where
-    ppFix (n, Fixity p d) = toHtml (ppDir d) <+> toHtml (show p)
-                            <+> ppDocName qual Infix False n
+    ppFix (ns, p, d) = toHtml d <+> toHtml (show p) <+> ppNames ns
 
     ppDir InfixR = "infixr"
     ppDir InfixL = "infixl"
     ppDir InfixN = "infix"
 
+    ppNames = concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)
+
+    uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs
+                                   , let d' = ppDir d
+                                   , then group by Down (p,d') using groupWith ]
+
 
 ppTyVars :: LHsTyVarBndrs DocName -> [Html]
 ppTyVars tvs = map ppTyName (tyvarNames tvs)
-- 
cgit v1.2.3