X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=75ce6c94a9008b4bbab87e13c3848485b05a54dd;hb=678086d0d26108713d1c361ab07d5ae12e24f363;hp=02de94079a5f36cec98836bae532c0fb2005e5f9;hpb=911a3e09ad48ff8dac5ee1399fe9294edf58d30c;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 02de940..75ce6c9 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -763,8 +763,11 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
 --
 -- We leave skolem TyVars alone; they are immutable.
 zonkQuantifiedTyVar tv
-  | ASSERT( isTcTyVar tv ) 
-    isSkolemTyVar tv = return tv
+  | ASSERT2( isTcTyVar tv, ppr tv ) 
+    isSkolemTyVar tv 
+  = do { kind <- zonkTcType (tyVarKind tv)
+       ; return $ setTyVarKind tv kind
+       }
 	-- It might be a skolem type variable, 
 	-- for example from a user type signature
 
@@ -896,12 +899,14 @@ zonkType unbound_var_fn ty
 
 	-- The two interesting cases!
     go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar unbound_var_fn tyvar
-		       | otherwise	 = return (TyVarTy tyvar)
+		       | otherwise	 = liftM TyVarTy $ 
+                                             zonkTyVar unbound_var_fn tyvar
 		-- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             return (ForAllTy tyvar ty')
+                             tyvar' <- zonkTyVar unbound_var_fn tyvar
+                             return (ForAllTy tyvar' ty')
 
     go_pred (ClassP c tys)   = do tys' <- mapM go tys
                                   return (ClassP c tys')
@@ -911,7 +916,7 @@ zonkType unbound_var_fn ty
                                   ty2' <- go ty2
                                   return (EqPred ty1' ty2')
 
-zonk_tc_tyvar :: (TcTyVar -> TcM Type)		-- What to do for an unbound mutable variable
+zonk_tc_tyvar :: (TcTyVar -> TcM Type)	-- What to do for an unbound mutable var
  	      -> TcTyVar -> TcM TcType
 zonk_tc_tyvar unbound_var_fn tyvar 
   | not (isMetaTyVar tyvar)	-- Skolems
@@ -922,6 +927,18 @@ zonk_tc_tyvar unbound_var_fn tyvar
 	; case cts of
 	    Flexi       -> unbound_var_fn tyvar    -- Unbound meta type variable
 	    Indirect ty -> zonkType unbound_var_fn ty  }
+
+-- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
+-- kind contains types).
+--
+zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for an unbound mutable var
+ 	  -> TyVar -> TcM TyVar
+zonkTyVar unbound_var_fn tv 
+  | isCoVar tv
+  = do { kind <- zonkType unbound_var_fn (tyVarKind tv)
+       ; return $ setTyVarKind tv kind
+       }
+  | otherwise = return tv
 \end{code}
 
 
@@ -1049,6 +1066,7 @@ checkValidMonoType ty = check_mono_type MustBeMonoType ty
 data Rank = ArbitraryRank	  -- Any rank ok
           | MustBeMonoType  	  -- Monotype regardless of flags
 	  | TyConArgMonoType	  -- Monotype but could be poly if -XImpredicativeTypes
+	  | SynArgMonoType	  -- Monotype but could be poly if -XLiberalTypeSynonyms
           | Rank Int		  -- Rank n, but could be more with -XRankNTypes
 
 decRank :: Rank -> Rank		  -- Function arguments
@@ -1122,7 +1140,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
 	; liberal <- doptM Opt_LiberalTypeSynonyms
 	; if not liberal || isOpenSynTyCon tc then
 		-- For H98 and synonym families, do check the type args
-		mapM_ (check_mono_type TyConArgMonoType) tys
+		mapM_ (check_mono_type SynArgMonoType) tys
 
 	  else	-- In the liberal case (only for closed syns), expand then check
 	  case tcView ty of   
@@ -1199,6 +1217,7 @@ forAllTyErr rank ty
     suggestion = case rank of
     	       	   Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")
     	       	   TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes")
+    	       	   SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms")
 		   _ -> empty      -- Polytype is always illegal
 
 unliftedArgErr, ubxArgTyErr :: Type -> SDoc
@@ -1305,6 +1324,14 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity_err  = arityErr "Class" class_name arity n_tys
     how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this"))
 
+check_pred_ty _ (ClassSCCtxt _) (EqPred _ _)
+  =   -- We do not yet support superclass equalities.
+    failWithTc $
+      sep [ ptext (sLit "The current implementation of type families does not")
+          , ptext (sLit "support equality constraints in superclass contexts.")
+          , ptext (sLit "They are planned for a future release.")
+          ]
+
 check_pred_ty dflags _ pred@(EqPred ty1 ty2)
   = do {	-- Equational constraints are valid in all contexts if type
 		-- families are permitted