X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=08a3cbd6ee79fed2654b87f13126d27208ddac8e;hb=2da37f4f15790377900fa6c38ff8fdcd394dfaa2;hp=9a17b0f07d0338b65963ea48ddfb683f8612a1e2;hpb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 9a17b0f..08a3cbd 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -35,14 +35,14 @@ module TcMType (
   tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
   tcInstSigType,
   tcInstSkolTyVars, tcInstSkolType, 
-  tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
+  tcSkolSigType, tcSkolSigTyVars, occurCheckErr, execTcTyVarBinds,
 
   --------------------------------
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
   SourceTyCtxt(..), checkValidTheta, checkFreeness,
   checkValidInstHead, checkValidInstance, 
-  checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
+  checkInstTermination, checkValidTypeInst, checkTyFamFreeness, checkKinds,
   checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt,
   unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs,
   growPredTyVars, growTyVars, growThetaTyVars,
@@ -78,6 +78,7 @@ import VarSet
 import ErrUtils
 import DynFlags
 import Util
+import Bag
 import Maybes
 import ListSetOps
 import UniqSupply
@@ -337,6 +338,27 @@ Rather, we should bind t to () (= non_var_ty2).
 
 --------------
 
+Execute a bag of type variable bindings.
+
+\begin{code}
+execTcTyVarBinds :: TcTyVarBinds -> TcM ()
+execTcTyVarBinds = mapM_ execTcTyVarBind . bagToList
+  where
+    execTcTyVarBind (TcTyVarBind tv ty)
+      = do { ASSERTM2( do { details <- readMetaTyVar tv
+                          ; return (isFlexi details) }, ppr tv )
+           ; ty' <- if isCoVar tv 
+                    then return ty 
+                    else do { maybe_ty <- checkTauTvUpdate tv ty
+                            ; case maybe_ty of
+                                Nothing -> pprPanic "TcRnMonad.execTcTyBind"
+                                             (ppr tv <+> text ":=" <+> ppr ty)
+                                Just ty' -> return ty'
+                            }
+           ; writeMetaTyVar tv ty'
+           }
+\end{code}
+
 Error mesages in case of kind mismatch.
 
 \begin{code}
@@ -522,19 +544,17 @@ writeMetaTyVar tyvar ty
     return ()
   | otherwise
   = ASSERT( isMetaTyVar tyvar )
-    -- TOM: It should also work for coercions
-    -- ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) )
+    ASSERT2( isCoVar tyvar || typeKind ty `isSubKind` tyVarKind tyvar, 
+             (ppr tyvar <+> ppr (tyVarKind tyvar)) 
+             $$ (ppr ty <+> ppr (typeKind ty)) )
     do	{ if debugIsOn then do { details <- readMetaTyVar tyvar; 
+-- FIXME   	     	       	       ; ASSERT2( not (isFlexi details), ppr tyvar )
     	     	       	       ; WARN( not (isFlexi details), ppr tyvar )
 			       	 return () }
 			else return () 
-		-- Temporarily make this a warning, until we fix Trac #2999
 
 	; traceTc (text "writeMetaTyVar" <+> ppr tyvar <+> text ":=" <+> ppr ty)
 	; writeMutVar (metaTvRef tyvar) (Indirect ty) }
-  where
-    _k1 = tyVarKind tyvar
-    _k2 = typeKind ty
 \end{code}
 
 
@@ -1039,11 +1059,13 @@ checkValidType ctxt ty = do
 
 		 ForSigCtxt _	-> gen_rank 1
 		 SpecInstCtxt   -> gen_rank 1
+		 ThBrackCtxt    -> gen_rank 1
 
 	actual_kind = typeKind ty
 
 	kind_ok = case ctxt of
 			TySynCtxt _  -> True -- Any kind will do
+			ThBrackCtxt  -> True -- Any kind will do
 			ResSigCtxt   -> isSubOpenTypeKind actual_kind
 			ExprSigCtxt  -> isSubOpenTypeKind actual_kind
 			GenPatCtxt   -> isLiftedTypeKind actual_kind
@@ -1053,6 +1075,7 @@ checkValidType ctxt ty = do
 	ubx_tup = case ctxt of
 	              TySynCtxt _ | unboxed -> UT_Ok
 	              ExprSigCtxt | unboxed -> UT_Ok
+	              ThBrackCtxt | unboxed -> UT_Ok
 	              _                     -> UT_NotOk
 
 	-- Check that the thing has kind Type, and is lifted if necessary
@@ -1203,13 +1226,14 @@ check_arg_type :: Rank -> Type -> TcM ()
 
 check_arg_type rank ty 
   = do	{ impred <- doptM Opt_ImpredicativeTypes
-	; let rank' = if impred then ArbitraryRank  -- Arg of tycon can have arby rank, regardless
-	              else case rank of 	    -- Predictive => must be monotype
-	      	        MustBeMonoType -> MustBeMonoType 
-			_	       -> TyConArgMonoType
+	; let rank' = case rank of 	    -- Predictive => must be monotype
+	      	        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
+			_other | impred    -> ArbitraryRank
+			       | otherwise -> TyConArgMonoType
 			-- Make sure that MustBeMonoType is propagated, 
 			-- so that we don't suggest -XImpredicativeTypes in
 			--    (Ord (forall a.a)) => a -> a
+			-- and so that if it Must be a monotype, we check that it is!
 
 	; check_type rank' UT_NotOk ty
 	; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) }