[commit: ghc] ghc-kinds: Don't abstract over kinds containing # or (#)! Fixes Trac #5426 (9de64d1)

[Julien Cretin]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-kinds

http://hackage.haskell.org/trac/ghc/changeset/9de64d1b5355b2354a6f8ffa18509f15cef5f714

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

commit 9de64d1b5355b2354a6f8ffa18509f15cef5f714
Author: Julien Cretin <ghc at ia0.eu>
Date:   Fri Sep 9 12:10:34 2011 +0200

    Don't abstract over kinds containing # or (#)! Fixes Trac #5426

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

 compiler/typecheck/TcHsType.lhs |   10 ++++++----
 compiler/types/Kind.lhs         |   14 +++++++++++++-
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 3d8080b..293b322 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -769,13 +769,15 @@ tcTyVarBndrs :: [LHsTyVarBndr Name] 	-- Kind-annotated binders, which need kind-
 	     -> TcM r
 -- Used when type-checking types/classes/type-decls
 -- Brings into scope immutable TyVars, not mutable ones that require later zonking
+-- Fix #5426: avoid abstraction over kinds containing # or (#)
 tcTyVarBndrs bndrs thing_inside = do
-    tyvars <- mapM (zonk . unLoc) bndrs
+    tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs
     tcExtendTyVarEnv tyvars (thing_inside tyvars)
   where
-    zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind
-				    ; return (mkTyVar name kind') }
-    zonk (KindedTyVar name _ kind) = return (mkTyVar name kind)
+    zonk (name, kind)
+      = do { kind' <- zonkTcKindToKind kind
+           ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)"))
+	   ; return (mkTyVar name kind') }
 
 -----------------------------------
 tcDataKindSig :: Maybe Kind -> TcM [TyVar]
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index cd6423d..7fd66c4 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -29,7 +29,7 @@ module Kind (
         isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
         isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, 
         isSuperKind, isCoercionKind, 
-        isLiftedTypeKindCon,
+        isLiftedTypeKindCon, noHashInKind,
 
         isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
         isSubKindCon, isSubOpenTypeKindCon,
@@ -67,6 +67,18 @@ isTySuperKind _                = False
 
 isLiftedTypeKindCon :: TyCon -> Bool
 isLiftedTypeKindCon tc    = tc `hasKey` liftedTypeKindTyConKey
+
+-- This checks that its argument does not contain # or (#).
+-- It is used in tcTyVarBndrs.
+noHashInKind :: Kind -> Bool
+noHashInKind (TyVarTy {}) = True
+noHashInKind (FunTy k1 k2) = noHashInKind k1 && noHashInKind k2
+noHashInKind (ForAllTy _ ki) = noHashInKind ki
+noHashInKind (TyConApp kc kis)
+  =  not (kc `hasKey` unliftedTypeKindTyConKey)
+  && not (kc `hasKey` ubxTupleKindTyConKey)
+  && all noHashInKind kis
+noHashInKind _ = panic "noHashInKind"
 \end{code}
 
 %************************************************************************