[commit: haddock] master: Group similar fixities together (68a7893)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branch  : master
Link       : http://git.haskell.org/haddock.git/commitdiff/68a78932b5b004945f6681bd51e8080e868fc0ee

>---------------------------------------------------------------

commit 68a78932b5b004945f6681bd51e8080e868fc0ee
Author: Niklas Haas <git at nand.wakku.to>
Date:   Sun Mar 9 16:32:36 2014 +0100

    Group similar fixities together
    
    Identical fixities declared for the same line should now render using
    syntax like: infix 4 <, >=, >, <=


>---------------------------------------------------------------

68a78932b5b004945f6681bd51e8080e868fc0ee
 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 89ebbbb..fdc46aa 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-"
 		>(>><)</a
+		>, <a href="#v:-60--60--62-"
+		>(<<>)</a
 		> :: a -> b -> ()</li
+	      ><li
+	      ><a href="#v:-42--42--62-"
+		>(**>)</a
+		>, <a href="#v:-60--42--42-"
+		>(<**)</a
+		>, <a href="#v:-62--42--42-"
+		>(>**)</a
+		>, <a href="#v:-42--42--60-"
+		>(**<)</a
+		> :: a -> a -> ()</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 >><<br
+	    >infixl 5 <<><br
+	       />infixr 4 >><<br
 	       /><a name="v:-62--62--60-" class="def"
 	      >(>><)</a
+	      >, <a name="v:-60--60--62-" class="def"
+	      >(<<>)</a
 	      > :: a -> b -> ()</p
+	    ><p class="src"
+	    >infixr 8 **>, >**<br
+	       />infixl 8 <**, **<<br
+	       /><a name="v:-42--42--62-" class="def"
+	      >(**>)</a
+	      >, <a name="v:-60--42--42-" class="def"
+	      >(<**)</a
+	      >, <a name="v:-62--42--42-" class="def"
+	      >(>**)</a
+	      >, <a name="v:-42--42--60-" class="def"
+	      >(**<)</a
+	      > :: a -> a -> ()</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 a2e30c1..f7b4d0a 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 5cc86d4..42f0628 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)