X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=b502b16a361b05de1173a5195597b940c21f4c66;hb=e0c787c10fc73125878312a5d88e90f9fcab2637;hp=f9ebae4fd26f8053262b5f2703097c2f419c5681;hpb=bca9dd54c2b39638cb4638aaccf6015a104a1df5;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index f9ebae4..b502b16 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -17,7 +17,7 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
 -- friends: 
 import TcMonad
 import TypeRep	( Type(..), PredType(..) )  -- friend
-import Type	( unboxedTypeKind, boxedTypeKind, openTypeKind, 
+import Type	( unliftedTypeKind, liftedTypeKind, openTypeKind, 
 		  typeCon, openKindCon, hasMoreBoxityInfo, 
 		  tyVarsOfType, typeKind,
 		  mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
@@ -26,7 +26,7 @@ import Type	( unboxedTypeKind, boxedTypeKind, openTypeKind,
 		)
 import TyCon	( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
 import Var	( tyVarKind, varName, isSigTyVar )
-import VarSet	( varSetElems )
+import VarSet	( elemVarSet )
 import TcType	( TcType, TcTauType, TcTyVar, TcKind, newBoxityVar,
 		  newTyVarTy, newTyVarTys, tcGetTyVar, tcPutTyVar, zonkTcType
 		)
@@ -164,7 +164,7 @@ uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True  tyvar2 ps_ty1 ty1
 	-- Predicates
 uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2))
   | n1 == n2 = uTys t1 t1 t2 t2
-uTys _ (PredTy (Class c1 tys1)) _ (PredTy (Class c2 tys2))
+uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2))
   | c1 == c2 = unifyTauTyLists tys1 tys2
 
 	-- Functions; just check the two parts
@@ -325,20 +325,23 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
 
 	-- Second one isn't a type variable
 uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
-  = checkKinds swapped tv1 non_var_ty2			`thenTc_`
-    occur_check non_var_ty2				`thenTc_`
+  = 	-- Check that the kinds match
+    checkKinds swapped tv1 non_var_ty2			`thenTc_`
+
+	-- Check that tv1 isn't a type-signature type variable
     checkTcM (not (isSigTyVar tv1))
 	     (failWithTcM (unifyWithSigErr tv1 ps_ty2))	`thenTc_`
 
+	-- Check that we aren't losing boxity info (shouldn't happen)
     warnTc (not (typeKind non_var_ty2 `hasMoreBoxityInfo` tyVarKind tv1))
 	   ((ppr tv1 <+> ppr (tyVarKind tv1)) $$ 
 	     (ppr non_var_ty2 <+> ppr (typeKind non_var_ty2)))		`thenNF_Tc_` 
 
-    tcPutTyVar tv1 non_var_ty2				`thenNF_Tc_`
-	-- This used to say "ps_ty2" instead of "non_var_ty2"
-
-	-- But that led to an infinite loop in the type checker!
-	-- Consider 
+	-- Occurs check
+	-- Basically we want to update     tv1 := ps_ty2
+	-- because ps_ty2 has type-synonym info, which improves later error messages
+	-- 
+	-- But consider 
 	--	type A a = ()
 	--
 	--	f :: (A a -> a -> ()) -> ()
@@ -347,33 +350,33 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
 	-- 	x :: ()
 	-- 	x = f (\ x p -> p x)
 	--
-	-- Here, we try to match "t" with "A t", and succeed
-	-- because the unifier looks through synonyms.  The occurs
-	-- check doesn't kick in because we are "really" binding "t" to "()",
-	-- but we *actually* bind "t" to "A t" if we store ps_ty2.
-	-- That leads the typechecker into an infinite loop later.
-
-    returnTc ()
-  where
-    occur_check ty = mapTc occur_check_tv (varSetElems (tyVarsOfType ty))	`thenTc_`
-		     returnTc ()
-
-    occur_check_tv tv2
-       | tv1 == tv2		-- Same tyvar; fail
-       = zonkTcType ps_ty2	`thenNF_Tc` \ zonked_ty2 ->
-	 failWithTcM (unifyOccurCheck tv1 zonked_ty2)
+	-- In the application (p x), we try to match "t" with "A t".  If we go
+	-- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into 
+	-- an infinite loop later.
+ 	-- But we should not reject the program, because A t = ().
+	-- Rather, we should bind t to () (= non_var_ty2).
+	-- 
+	-- That's why we have this two-state occurs-check
+    zonkTcType ps_ty2					`thenNF_Tc` \ ps_ty2' ->
+    if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then
+	tcPutTyVar tv1 ps_ty2'				`thenNF_Tc_`
+	returnTc ()
+    else
+    zonkTcType non_var_ty2				`thenNF_Tc` \ non_var_ty2' ->
+    if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then
+	-- This branch rarely succeeds, except in strange cases
+	-- like that in the example above
+	tcPutTyVar tv1 non_var_ty2'			`thenNF_Tc_`
+	returnTc ()
+    else
+    failWithTcM (unifyOccurCheck tv1 ps_ty2')
 
-       | otherwise		-- A different tyvar
-       = tcGetTyVar tv2	`thenNF_Tc` \ maybe_ty2 ->
-	 case maybe_ty2 of
-		Just ty2' -> occur_check ty2'
-		other	  -> returnTc ()
 
 checkKinds swapped tv1 ty2
 -- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
--- We need to check that we don't unify a boxed type variable with an
--- unboxed type: e.g.  (id 3#) is illegal
-  | tk1 == boxedTypeKind && tk2 == unboxedTypeKind
+-- We need to check that we don't unify a lifted type variable with an
+-- unlifted type: e.g.  (id 3#) is illegal
+  | tk1 == liftedTypeKind && tk2 == unliftedTypeKind
   = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2)	$
     unifyMisMatch k1 k2
   | otherwise
@@ -432,7 +435,7 @@ unifyListTy ty
 	other					    -> unify_list_ty_help ty
 
 unify_list_ty_help ty	-- Revert to ordinary unification
-  = newTyVarTy boxedTypeKind		`thenNF_Tc` \ elt_ty ->
+  = newTyVarTy liftedTypeKind		`thenNF_Tc` \ elt_ty ->
     unifyTauTy ty (mkListTy elt_ty)	`thenTc_`
     returnTc elt_ty
 \end{code}
@@ -459,7 +462,7 @@ unify_tuple_ty_help boxity arity ty
     unifyTauTy ty (mkTupleTy boxity arity arg_tys)	`thenTc_`
     returnTc arg_tys
   where
-    kind | isBoxed boxity = boxedTypeKind
+    kind | isBoxed boxity = liftedTypeKind
 	 | otherwise      = openTypeKind
 \end{code}