[commit: ghc] master: Fix Trac #7805: don't allow nested foralls in promoted types (7501a2c)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/7501a2c3a181a53789e4f4462847295354042849

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

commit 7501a2c3a181a53789e4f4462847295354042849
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Apr 3 14:38:14 2013 +0100

    Fix Trac #7805: don't allow nested foralls in promoted types

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

 compiler/typecheck/TcTyDecls.lhs | 23 +++++++++--------------
 1 file changed, 9 insertions(+), 14 deletions(-)

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index 99ee065..fb54899 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -506,21 +506,16 @@ isPromotableType :: NameSet -> Type -> Bool
 -- Must line up with DataCon.promoteType
 -- But the function lives here because we must treat the
 -- *recursive* tycons as promotable
-isPromotableType rec_tcs ty
-  = case splitForAllTys ty of
-      (_, rho) -> go rho
+isPromotableType rec_tcs con_arg_ty
+  = go con_arg_ty
   where
-    go (TyConApp tc tys) 
-      | tys `lengthIs` tyConArity tc 
-      ,  tyConName tc `elemNameSet` rec_tcs 
-      || isJust (promotableTyCon_maybe tc) 
-                       = all go tys
-      | otherwise      = False
-    go (FunTy arg res) = go arg && go res
-    go (AppTy arg res) = go arg && go res
-    go (ForAllTy _ ty) = go ty
-    go (TyVarTy {})    = True
-    go (LitTy {})      = False
+    go (TyConApp tc tys) =  tys `lengthIs` tyConArity tc 
+                         && (tyConName tc `elemNameSet` rec_tcs 
+                             || isJust (promotableTyCon_maybe tc))
+                         && all go tys
+    go (FunTy arg res) 	 = go arg && go res
+    go (TyVarTy {})    	 = True
+    go _               	 = False
 \end{code}