[project @ 2002-02-11 08:20:38 by chak]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcUnify.lhs

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index e9d36c4..56ae764 100644 (file)
--- 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}