In splitHsFunType, take account of prefix (->)
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 12 May 2014 15:02:36 +0000 (16:02 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 12 May 2014 15:04:10 +0000 (16:04 +0100)
This fixes Trac #9096

compiler/hsSyn/HsTypes.lhs
testsuite/tests/gadt/T9096.hs [new file with mode: 0644]
testsuite/tests/gadt/all.T

index 28c6a2b..6f65a12 100644 (file)
@@ -45,6 +45,7 @@ import HsLit
 import Name( Name )
 import RdrName( RdrName )
 import DataCon( HsBang(..) )
+import TysPrim( funTyConName )
 import Type
 import HsDoc
 import BasicTypes
@@ -506,15 +507,31 @@ splitLHsClassTy_maybe ty
         HsKindSig ty _     -> checkl ty args
         _                  -> Nothing
 
--- Splits HsType into the (init, last) parts
+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
 -- Breaks up any parens in the result type: 
 --      splitHsFunType (a -> (b -> c)) = ([a,b], c)
-splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
-splitHsFunType (L _ (HsFunTy x y)) = (x:args, res)
-  where
-  (args, res) = splitHsFunType y
-splitHsFunType (L _ (HsParTy ty))  = splitHsFunType ty
-splitHsFunType other               = ([], other)
+-- Also deals with (->) t1 t2; that is why it only works on LHsType Name
+--   (see Trac #9096)
+splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
+splitHsFunType (L _ (HsParTy ty)) 
+  = splitHsFunType ty
+
+splitHsFunType (L _ (HsFunTy x y))
+  | (args, res) <- splitHsFunType y
+  = (x:args, res)
+
+splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) 
+  = go t1 [t2]
+  where  -- Look for (->) t1 t2, possibly with parenthesisation
+    go (L _ (HsTyVar fn))    tys | fn == funTyConName
+                                 , [t1,t2] <- tys
+                                 , (args, res) <- splitHsFunType t2
+                                 = (t1:args, res)
+    go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
+    go (L _ (HsParTy ty))    tys = go ty tys
+    go _                     _   = ([], orig_ty)  -- Failure to match
+
+splitHsFunType other = ([], other)
 \end{code}
 
 
diff --git a/testsuite/tests/gadt/T9096.hs b/testsuite/tests/gadt/T9096.hs
new file mode 100644 (file)
index 0000000..d778798
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE GADTs #-}
+
+module T9096 where
+
+data Foo a where
+  MkFoo :: (->) a (Foo a)
index 9192891..52a8812 100644 (file)
@@ -122,3 +122,4 @@ test('T7321',
      ['$MAKE -s --no-print-directory T7321'])
 test('T7974', normal, compile, [''])
 test('T7558', normal, compile_fail, [''])
+test('T9096', normal, compile, [''])