From e93d48aff9e9b13f393e168e01b10de0bfd290f2 Mon Sep 17 00:00:00 2001
From: davve <davve@dtek.chalmers.se>
Date: Sun, 4 Feb 2007 16:59:08 +0000
Subject: Render infix type constructors properly

---
 src/HaddockHtml.hs | 6 +++++-
 src/HaddockUtil.hs | 4 +++-
 2 files changed, 8 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 2af6922d..59ca8501 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -1078,7 +1078,11 @@ expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
 ppDataHeader :: Bool -> NewOrData -> Name -> [Name] -> Html
 ppDataHeader summary newOrData name tyvars = 
   (if newOrData == NewType then keyword "newtype" else keyword "data") <+> 
-  ppBinder summary name <+> hsep (map ppName tyvars)
+  (if infixConstr then ppName (tyvars!!0) <+> ppBinder summary name <+> ppName (tyvars!!1)
+                  else ppBinder summary name <+> hsep (map ppName tyvars))
+  where 
+    -- there should be a better way to check this using the GHC API
+    infixConstr = (head (nameOccString name) == ':') && (length tyvars == 2)
 
 -- ----------------------------------------------------------------------------
 -- Types and contexts
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index b80e8a1b..4d67f0d7 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -20,7 +20,7 @@ module HaddockUtil (
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
-  moduleString, mkModuleNoPkg,
+  nameOccString, moduleString, mkModuleNoPkg,
 
   -- * HTML cross reference mapping
   html_xrefs_ref,
@@ -231,6 +231,8 @@ escapeStr = flip escapeString unreserved
 escapeStr = escapeURIString isUnreserved
 #endif
 
+nameOccString = occNameString . nameOccName 
+
 moduleString :: Module -> String
 moduleString = moduleNameString . moduleName 
 
-- 
cgit v1.2.3