Implement tuple syntax sugaring logic for specialized types.

1 files changed, 34 insertions, 2 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 30501a13..a2cb8799 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -15,6 +15,7 @@ import Haddock.Syb
 import GHC
 import Name
 
+import Control.Monad
 import Data.Data
 
 
@@ -64,5 +65,36 @@ sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
 sugarListsStep typ = typ
 
 
-sugarTuples :: HsType name -> HsType name
-sugarTuples = id
+sugarTuples :: forall name. (NamedThing name, DataId name)
+            => HsType name -> HsType name
+sugarTuples = everywhere $
+    mkT (sugarTuplesStep :: HsType name -> HsType name)
+
+
+sugarTuplesStep :: NamedThing name => HsType name -> HsType name
+sugarTuplesStep typ =
+    aux [] typ
+  where
+    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+    aux apps (HsParTy (L _ typ')) = aux apps typ'
+    aux apps (HsTyVar name)
+        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+      where
+        name' = getName name
+        strName = occNameString . nameOccName $ name'
+        suitable = case parseTupleArity strName of
+            Just arity -> arity == length apps
+            Nothing -> False
+    aux _ _ = typ
+
+
+parseTupleArity :: String -> Maybe Int
+parseTupleArity ('(':commas) = do
+    n <- parseCommas commas
+    guard $ n /= 0
+    return $ n + 1
+  where
+    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
+    parseCommas ")" = Just 0
+    parseCommas _ = Nothing
+parseTupleArity _ = Nothing