[project @ 2002-06-20 08:33:20 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 27abbd5..8e3862c 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -92,7 +92,7 @@ module TcType (
 
   isUnLiftedType,      -- Source types are always lifted
   isUnboxedTupleType,  -- Ditto
-  isPrimitiveType,
+  isPrimitiveType, isTyVarTy,
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
@@ -114,7 +114,7 @@ import Type         (       -- Re-exports
                          Kind, Type, SourceType(..), PredType, ThetaType, 
                          unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
                          mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
-                         mkFunTy, mkFunTys, zipFunTys, 
+                         mkFunTy, mkFunTys, zipFunTys, isTyVarTy,
                          mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
                          mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
                          isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
@@ -737,10 +737,13 @@ hoistForAllTys ty
     hoist orig_ty (ForAllTy tv ty) = case hoist ty ty of
                                        (tvs,theta,tau) -> (tv:tvs,theta,tau)
     hoist orig_ty (FunTy arg res)
-       | isPredTy arg             = case hoist res res of
-                                       (tvs,theta,tau) -> (tvs,arg:theta,tau)
+       | isPredTy arg'            = case hoist res res of
+                                       (tvs,theta,tau) -> (tvs,arg':theta,tau)
        | otherwise                = case hoist res res of
-                                       (tvs,theta,tau) -> (tvs,theta,mkFunTy arg tau)
+                                       (tvs,theta,tau) -> (tvs,theta,mkFunTy arg' tau)
+       where
+         arg' = hoistForAllTys arg     -- Don't forget to apply hoist recursively
+                                       -- to the argument type
 
     hoist orig_ty (NoteTy _ ty)    = hoist orig_ty ty
     hoist orig_ty ty              = ([], [], orig_ty)