[project @ 2001-01-11 17:25:56 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 bc6f537..b732b0d 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -17,15 +17,15 @@ 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 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
@@ -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,16 +310,16 @@ 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
                        || isSystemName (varName tv2)
                                -- Try to update sys-y type variables in preference to sig-y ones
 
@@ -323,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_`
 
@@ -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}