X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=56ae76492deb3b2a14b7aee832f19218edec44db;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=e9d36c44b80febec6b2727ed1cda2153a0c8149b;hpb=1d874e7c18d8b1bd46cbb27c3e146b092a64fc63;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index e9d36c4..56ae764 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -11,7 +11,7 @@ module TcUnify (
 
 	-- Various unifications
   unifyTauTy, unifyTauTyList, unifyTauTyLists, 
-  unifyFunTy, unifyListTy, unifyTupleTy,
+  unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy,
   unifyKind, unifyKinds, unifyOpenTypeKind,
 
 	-- Coercions
@@ -51,7 +51,7 @@ import TcMType		( getTcTyVar, putTcTyVar, tcInstType,
 			  newTyVarTy, newTyVarTys, newBoxityVar, newHoleTyVarTy,
 			  zonkTcType, zonkTcTyVars, zonkTcTyVar )
 import TcSimplify	( tcSimplifyCheck )
-import TysWiredIn	( listTyCon, mkListTy, mkTupleTy )
+import TysWiredIn	( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy )
 import TcEnv		( TcTyThing(..), tcExtendGlobalTyVars, tcGetGlobalTyVars, tcLEnvElts )
 import TyCon		( tyConArity, isTupleTyCon, tupleTyConBoxity )
 import PprType		( pprType )
@@ -420,10 +420,6 @@ uTys :: TcTauType -> TcTauType	-- Error reporting ty1 and real ty1
 uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2
 uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 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
@@ -641,19 +637,18 @@ 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.
--- ty2 has been zonked at this stage
+-- ty2 has been zonked at this stage.
+
+  | tk2 `hasMoreBoxityInfo` tk1 = returnTc ()
 
-  | tk1 `eqKind` liftedTypeKind && tk2 `eqKind` unliftedTypeKind
-	-- Check that we don't unify a lifted type variable with an
-	-- unlifted type: e.g.  (id 3#) is illegal
+  | otherwise
+	-- Either the kinds aren't compatible
+	--	(can happen if we unify (a b) with (c d))
+	-- or we are unifying a lifted type variable with an
+	-- 	unlifted type: e.g.  (id 3#) is illegal
   = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2)	$
     unifyMisMatch k1 k2
 
-  | otherwise
-  =	-- Check that we aren't losing boxity info (shouldn't happen)
-    WARN (not (tk2 `hasMoreBoxityInfo` tk1),
-	  (ppr tv1 <+> ppr tk1) $$ (ppr ty2 <+> ppr tk2))
-    returnTc ()
   where
     (k1,k2) | swapped   = (tk2,tk1)
 	    | otherwise = (tk1,tk2)
@@ -739,6 +734,26 @@ unify_list_ty_help ty	-- Revert to ordinary unification
   = newTyVarTy liftedTypeKind		`thenNF_Tc` \ elt_ty ->
     unifyTauTy ty (mkListTy elt_ty)	`thenTc_`
     returnTc elt_ty
+
+-- variant for parallel arrays
+--
+unifyPArrTy :: TcType              -- expected list type
+	    -> TcM TcType	   -- list element type
+
+unifyPArrTy ty@(TyVarTy tyvar)
+  = getTcTyVar tyvar	`thenNF_Tc` \ maybe_ty ->
+    case maybe_ty of
+      Just ty' -> unifyPArrTy ty'
+      _        -> unify_parr_ty_help ty
+unifyPArrTy ty
+  = case tcSplitTyConApp_maybe ty of
+      Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnTc arg_ty
+      _  					  -> unify_parr_ty_help ty
+
+unify_parr_ty_help ty	-- Revert to ordinary unification
+  = newTyVarTy liftedTypeKind		`thenNF_Tc` \ elt_ty ->
+    unifyTauTy ty (mkPArrTy elt_ty)	`thenTc_`
+    returnTc elt_ty
 \end{code}
 
 \begin{code}