From bef29ab118174e4b172495bcfd2171a1cb7eb7e4 Mon Sep 17 00:00:00 2001
From: David Waern <davve@dtek.chalmers.se>
Date: Sat, 8 Dec 2007 16:45:06 +0000
Subject: Fix rendering of instance heads to handle infix operators This is
 also a refactoring to share this code for rendering predicates.

---
 src/Haddock/Backends/Html.hs | 35 ++++++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 13 deletions(-)

(limited to 'src/Haddock/Backends')

diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs
index f00a8f04..4d377995 100644
--- a/src/Haddock/Backends/Html.hs
+++ b/src/Haddock/Backends/Html.hs
@@ -749,6 +749,22 @@ ppTyName name
 ppTyNames = map ppTyName
 
 
+--------------------------------------------------------------------------------
+-- Type applications
+-- Ocurring in contexts and instance heads
+--------------------------------------------------------------------------------
+
+
+ppTypeApp n ts@(t1:t2:rest)
+  | operator, not . null $ rest = parens opApp <+> ppParendTypes rest
+  | operator                    = opApp
+  where
+    operator = isNameSym . getName $ n
+    opApp = ppParendType t1 <+> ppDocName n <+> ppParendType t2
+
+ppTypeApp n ts = ppDocName n <+> ppParendTypes ts
+
+
 --------------------------------------------------------------------------------
 -- Contexts 
 --------------------------------------------------------------------------------
@@ -774,16 +790,7 @@ pp_hs_context cxt = parenList (map ppPred cxt)
 ppLPred = ppPred . unLoc
 
 
-ppPred (HsClassP n ts)
-  | classOp, length ts > 2 = firstApp <+> ppLParendTypes rest
-  | classOp                = firstApp
-  | otherwise              = ppDocName n <+> ppLParendTypes ts
-  where
-   classOp    = isNameConSym . getName $ n
-   t1:t2:rest = ts
-   firstApp   = ppLParendType t1 <+> ppDocName n <+> ppLParendType t2
-
-
+ppPred (HsClassP n ts) = ppTypeApp n (map unLoc ts)
 -- TODO: find out what happened to the Dupable/Linear distinction
 ppPred (HsEqualP t1 t2) = ppLType t1 <+> toHtml "~" <+> ppLType t2
 ppPred (HsIParam (IPName n) t) 
@@ -878,10 +885,9 @@ ppClassDecl summary links instances orig_c loc mbDoc docMap
              ))
 
 ppInstHead :: InstHead DocName -> Html
-ppInstHead ([],   n, ts) = ppAsst n ts 
-ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAsst n ts 
+ppInstHead ([],   n, ts) = ppTypeApp n ts 
+ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppTypeApp n ts 
 
-ppAsst n ts = ppDocName n <+> hsep (map ppParendType ts)
 
 -- -----------------------------------------------------------------------------
 -- Data & newtype declarations
@@ -1230,6 +1236,9 @@ ppLTypes       = hsep . map ppLType
 ppLParendTypes = hsep . map ppLParendType
 
 
+ppParendTypes = hsep . map ppParendType
+
+
 ppLType       = ppType . unLoc
 ppLParendType = ppParendType . unLoc
 
-- 
cgit v1.2.3