[project @ 2001-01-03 11:48:06 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 8289392..b732b0d 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -17,11 +17,11 @@ 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,
-                  isNotUsgTy, splitAppTy_maybe, mkTyConApp, 
+                  splitAppTy_maybe, mkTyConApp, 
                  tidyOpenType, tidyOpenTypes, tidyTyVar
                )
 import TyCon   ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
@@ -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
 
@@ -306,8 +310,7 @@ 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
@@ -324,7 +327,6 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2)
 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_`
 
@@ -369,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
@@ -430,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}
@@ -457,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}