X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=b732b0d60e1147d28443d97c6995639e5655074a;hb=9c848a68f7b05aa352cd97d9a75488d20a774736;hp=a026827894d5a84411f5635ca0f020282e357161;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index a026827..b732b0d 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -17,20 +17,20 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
 -- friends: 
 import TcMonad
 import TypeRep	( Type(..), PredType(..) )  -- friend
-import Type	( funTyCon, Kind, unboxedTypeKind, boxedTypeKind, openTypeKind, 
-		  superBoxity, typeCon, openKindCon, hasMoreBoxityInfo, 
+import Type	( unliftedTypeKind, liftedTypeKind, openTypeKind, 
+		  typeCon, openKindCon, hasMoreBoxityInfo, 
 		  tyVarsOfType, typeKind,
-		  mkTyVarTy, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
-                  isNotUsgTy, splitAppTy_maybe, mkTyConApp, 
+		  mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
+                  splitAppTy_maybe, mkTyConApp, 
 	   	  tidyOpenType, tidyOpenTypes, tidyTyVar
 		)
 import TyCon	( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
-import Name	( hasBetterProv )
-import Var	( TyVar, tyVarKind, varName, isSigTyVar )
+import Var	( tyVarKind, varName, isSigTyVar )
 import VarSet	( varSetElems )
 import TcType	( TcType, TcTauType, TcTyVar, TcKind, newBoxityVar,
 		  newTyVarTy, newTyVarTys, tcGetTyVar, tcPutTyVar, zonkTcType
 		)
+import Name	( isSystemName )
 
 -- others:
 import BasicTypes ( Arity, Boxity, isBoxed )
@@ -148,10 +148,14 @@ uTys :: TcTauType -> TcTauType	-- Error reporting ty1 and real ty1
      -> TcM ()
 
 	-- Always expand synonyms (see notes at end)
-        -- (this also throws away FTVs and usage annots)
+        -- (this also throws away FTVs)
 uTys ps_ty1 (NoteTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
 uTys ps_ty1 ty1 ps_ty2 (NoteTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
 
+	-- Ignore usage annotations inside typechecker
+uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
+uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2
+
 	-- Variables; go for uVar
 uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2
 uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True  tyvar2 ps_ty1 ty1
@@ -279,7 +283,7 @@ uVar swapped tv1 ps_ty2 ty2
 		 | otherwise -> uTys ty1 ty1 ps_ty2 ty2	-- Same order
 	other       -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
 
-	-- Expand synonyms; ignore FTVs; ignore usage annots
+	-- Expand synonyms; ignore FTVs
 uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy _ ty2)
   = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2
 
@@ -298,7 +302,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
     case maybe_ty2 of
 	Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2'
 
-	Nothing | tv1_dominates_tv2 
+	Nothing | update_tv2
 
 		-> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) )
 		   tcPutTyVar tv2 (TyVarTy tv1)		`thenNF_Tc_`
@@ -306,24 +310,23 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
 		|  otherwise
 
 		-> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) )
-                   (ASSERT( isNotUsgTy ps_ty2 )
-		    tcPutTyVar tv1 ps_ty2		`thenNF_Tc_`
+                   (tcPutTyVar tv1 ps_ty2		`thenNF_Tc_`
 	  	    returnTc ())
   where
     k1 = tyVarKind tv1
     k2 = tyVarKind tv2
-    tv1_dominates_tv2 =    isSigTyVar tv1 
+    update_tv2 = (k2 == openTypeKind) || (k1 /= openTypeKind && nicer_to_update_tv2)
+			-- Try to get rid of open type variables as soon as poss
+
+    nicer_to_update_tv2 =  isSigTyVar tv1 
 				-- Don't unify a signature type variable if poss
-			|| k2 == openTypeKind
-				-- Try to get rid of open type variables as soon as poss
-			|| varName tv1 `hasBetterProv` varName tv2 
+			|| isSystemName (varName tv2)
 				-- Try to update sys-y type variables in preference to sig-y ones
 
 	-- 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_`
-    ASSERT( isNotUsgTy ps_ty2 )
     checkTcM (not (isSigTyVar tv1))
 	     (failWithTcM (unifyWithSigErr tv1 ps_ty2))	`thenTc_`
 
@@ -368,9 +371,9 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
 
 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
@@ -429,7 +432,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}
@@ -456,7 +459,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}