[project @ 2002-07-29 13:19:52 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index cf12315..7358cd3 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -35,10 +35,10 @@ import TcUnify              ( unifyKind, unifyOpenTypeKind )
 import TcType          ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
                          TcTyVar, TcKind, TcThetaType, TcTauType,
                          mkTyVarTy, mkTyVarTys, mkFunTy, 
-                         hoistForAllTys, zipFunTys, 
+                         zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy,
                          mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
                          liftedTypeKind, unliftedTypeKind, mkArrowKind,
-                         mkArrowKinds, tcSplitFunTy_maybe
+                         mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
                        )
 import Inst            ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
 
@@ -49,12 +49,13 @@ import TyCon                ( TyCon, tyConKind )
 import Class           ( classTyCon )
 import Name            ( Name )
 import NameSet
+import Subst           ( deShadowTy )
 import TysWiredIn      ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( SrcLoc )
 import Util            ( lengthIs )
 import Outputable
-
+import List            ( nubBy )
 \end{code}
 
 
@@ -629,6 +630,62 @@ mkTcSig poly_id src_loc
 \end{code}
 
 
+%************************************************************************
+%*                                                                     *
+\subsection{Errors and contexts}
+%*                                                                     *
+%************************************************************************
+
+
+\begin{code}
+hoistForAllTys :: Type -> Type
+-- Used for user-written type signatures only
+-- Move all the foralls and constraints to the top
+-- e.g.  T -> forall a. a        ==>   forall a. T -> a
+--      T -> (?x::Int) -> Int   ==>   (?x::Int) -> T -> Int
+--
+-- We want to 'look through' type synonyms when doing this
+-- so it's better done on the Type than the HsType
+
+hoistForAllTys ty
+  = let
+       no_shadow_ty = deShadowTy ty
+       -- Running over ty with an empty substitution gives it the
+       -- no-shadowing property.  This is important.  For example:
+       --      type Foo r = forall a. a -> r
+       --      foo :: Foo (Foo ())
+       -- Here the hoisting should give
+       --      foo :: forall a a1. a -> a1 -> ()
+       --
+       -- What about type vars that are lexically in scope in the envt?
+       -- We simply rely on them having a different unique to any
+       -- binder in 'ty'.  Otherwise we'd have to slurp the in-scope-tyvars
+       -- out of the envt, which is boring and (I think) not necessary.
+    in
+    case hoist no_shadow_ty of 
+       (tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body)
+               -- The 'nubBy' eliminates duplicate constraints
+  where
+    hoist ty
+       | (tvs1, body_ty) <- tcSplitForAllTys ty,
+         not (null tvs1)
+       = case hoist body_ty of
+               (tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau)
+
+       | Just (arg, res) <- tcSplitFunTy_maybe ty
+       = let
+             arg' = hoistForAllTys arg -- Don't forget to apply hoist recursively
+         in                            -- to the argument type
+         if (isPredTy arg') then
+           case hoist res of
+               (tvs,theta,tau) -> (tvs, arg':theta, tau)
+         else
+            case hoist res of
+               (tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau)
+
+       | otherwise = ([], [], ty)
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *