[project @ 2000-06-27 09:08:32 by lewie]

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

diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 0f037f6..9d684c1 100644 (file)
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -8,7 +8,7 @@ updatable substitution).
 
 \begin{code}
 module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, 
-                unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy,
+                unifyFunTy, unifyListTy, unifyTupleTy,
                 unifyKind, unifyKinds, unifyTypeKind
  ) where
 
@@ -25,8 +25,7 @@ import Type   ( tyVarsOfType,
                  splitAppTy_maybe,
                  tidyOpenType, tidyOpenTypes, tidyTyVar
                )
-import TyCon   ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, 
-                 tyConArity )
+import TyCon   ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
 import Name    ( hasBetterProv )
 import Var     ( TyVar, tyVarKind, varName, isSigTyVar )
 import VarEnv  
@@ -36,8 +35,8 @@ import TcType ( TcType, TcTauType, TcTyVar, TcKind,
                  tcGetTyVar, tcPutTyVar, zonkTcType, tcTypeKind
                )
 -- others:
-import BasicTypes ( Arity )
-import TysWiredIn ( listTyCon, mkListTy, mkTupleTy, mkUnboxedTupleTy )
+import BasicTypes ( Arity, Boxity, isBoxed )
+import TysWiredIn ( listTyCon, mkListTy, mkTupleTy )
 import PprType ()              -- Instances
 import Util
 import Outputable
@@ -300,7 +299,26 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2
     ASSERT( isNotUsgTy ps_ty2 )
     checkTcM (not (isSigTyVar tv1))
             (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_`
-    tcPutTyVar tv1 ps_ty2                              `thenNF_Tc_`
+
+    tcPutTyVar tv1 non_var_ty2                         `thenNF_Tc_`
+       -- This used to say "ps_ty2" instead of "non_var_ty2"
+
+       -- But that led to an infinite loop in the type checker!
+       -- Consider 
+       --      type A a = ()
+       --
+       --      f :: (A a -> a -> ()) -> ()
+       --      f = \ _ -> ()
+       --
+       --      x :: ()
+       --      x = f (\ x p -> p x)
+       --
+       -- Here, we try to match "t" with "A t", and succeed
+       -- because the unifier looks through synonyms.  The occurs
+       -- check doesn't kick in because we are "really" binding "t" to "()",
+       -- but we *actually* bind "t" to "A t" if we store ps_ty2.
+       -- That leads the typechecker into an infinite loop later.
+
     returnTc ()
   where
     occur_check ty = mapTc occur_check_tv (varSetElems (tyVarsOfType ty))      `thenTc_`
@@ -385,45 +403,29 @@ unify_list_ty_help ty     -- Revert to ordinary unification
 \end{code}
 
 \begin{code}
-unifyTupleTy :: Arity -> TcType -> TcM s [TcType]
-unifyTupleTy arity ty@(TyVarTy tyvar)
+unifyTupleTy :: Boxity -> Arity -> TcType -> TcM s [TcType]
+unifyTupleTy boxity arity ty@(TyVarTy tyvar)
   = tcGetTyVar tyvar   `thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
-       Just ty' -> unifyTupleTy arity ty'
-       other       -> unify_tuple_ty_help arity ty
+       Just ty' -> unifyTupleTy boxity arity ty'
+       other    -> unify_tuple_ty_help boxity arity ty
 
-unifyTupleTy arity ty
+unifyTupleTy boxity arity ty
   = case splitTyConApp_maybe ty of
-       Just (tycon, arg_tys) |  isTupleTyCon tycon 
-                        && tyConArity tycon == arity
-                        -> returnTc arg_tys
-       other -> unify_tuple_ty_help arity ty
-
-unify_tuple_ty_help arity ty
-  = mapNF_Tc (\ _ -> newTyVarTy boxedTypeKind) [1..arity]      `thenNF_Tc` \ arg_tys ->
-    unifyTauTy ty (mkTupleTy arity arg_tys)                    `thenTc_`
-    returnTc arg_tys
-\end{code}
-
-\begin{code}
-unifyUnboxedTupleTy :: Arity -> TcType -> TcM s [TcType]
-unifyUnboxedTupleTy arity ty@(TyVarTy tyvar)
-  = tcGetTyVar tyvar   `thenNF_Tc` \ maybe_ty ->
-    case maybe_ty of
-       Just ty' -> unifyUnboxedTupleTy arity ty'
-       other    -> unify_unboxed_tuple_ty_help arity ty
-
-unifyUnboxedTupleTy arity ty
-  = case splitTyConApp_maybe ty of
-       Just (tycon, arg_tys) |  isUnboxedTupleTyCon tycon 
-                        && tyConArity tycon == arity
-                        -> returnTc arg_tys
-       other -> unify_tuple_ty_help arity ty
-
-unify_unboxed_tuple_ty_help arity ty
-  = mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..arity]   `thenNF_Tc` \ arg_tys ->
-    unifyTauTy ty (mkUnboxedTupleTy arity arg_tys)     `thenTc_`
+       Just (tycon, arg_tys)
+               |  isTupleTyCon tycon 
+               && tyConArity tycon == arity
+               && tupleTyConBoxity tycon == boxity
+               -> returnTc arg_tys
+       other -> unify_tuple_ty_help boxity arity ty
+
+unify_tuple_ty_help boxity arity ty
+  = mapNF_Tc new_tyvar [1..arity]                      `thenNF_Tc` \ arg_tys ->
+    unifyTauTy ty (mkTupleTy boxity arity arg_tys)     `thenTc_`
     returnTc arg_tys
+  where
+    new_tyvar _ | isBoxed boxity = newTyVarTy boxedTypeKind
+               | otherwise      = newTyVarTy_OpenKind
 \end{code}
 
 Make sure a kind is of the form (Type b) for some boxity b.