[commit: ghc] ghc-7.8: In splitHsFunType, take account of prefix (->) (1662245)

[git at git.haskell.org]

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

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/16622452317fe235afc2a053686f46b7d30733a2/ghc

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

commit 16622452317fe235afc2a053686f46b7d30733a2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon May 12 16:02:36 2014 +0100

    In splitHsFunType, take account of prefix (->)
    
    This fixes Trac #9096
    
    (cherry picked from commit 770e16fceee60db0c2f79e3b77f6fc619bc1d864)


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

16622452317fe235afc2a053686f46b7d30733a2
 compiler/hsSyn/HsTypes.lhs    | 31 ++++++++++++++++++++++++-------
 testsuite/tests/gadt/T9096.hs |  6 ++++++
 testsuite/tests/gadt/all.T    |  1 +
 3 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 28c6a2b..6f65a12 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -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
index 0000000..d778798
--- /dev/null
+++ b/testsuite/tests/gadt/T9096.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE GADTs #-}
+
+module T9096 where
+
+data Foo a where
+  MkFoo :: (->) a (Foo a)
diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T
index 9192891..52a8812 100644
--- a/testsuite/tests/gadt/all.T
+++ b/testsuite/tests/gadt/all.T
@@ -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, [''])