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

** MERGE TO STABLE **

Fix an alpha-renaming bug in hoistForAlls

diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index ce5d8bc..17586a1 100644 (file)
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -28,7 +28,7 @@ module Subst (
 
        -- Type stuff
        mkTyVarSubst, mkTopTyVarSubst, 
-       substTyWith, substTy, substTheta,
+       substTyWith, substTy, substTheta, deShadowTy,
 
        -- Expression stuff
        substExpr
@@ -407,6 +407,9 @@ substTy :: Subst -> Type  -> Type
 substTy subst ty | isEmptySubst subst = ty
                 | otherwise          = subst_ty subst ty
 
+deShadowTy :: Type -> Type             -- Remove any shadowing from the type
+deShadowTy ty = subst_ty emptySubst ty
+
 substTheta :: TyVarSubst -> ThetaType -> ThetaType
 substTheta subst theta
   | isEmptySubst subst = theta

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}
+
 
 %************************************************************************
 %*                                                                     *

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 8f2fd90..0561b78 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -348,8 +348,7 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
     newMethodFromName origin pat_ty geName     `thenNF_Tc` \ ge ->
 
        -- The '-' part is re-mappable syntax
-    tcGetInstLoc origin                                        `thenNF_Tc` \ loc ->
-    tcSyntaxName loc pat_ty minusName minus_name       `thenTc` \ (minus_expr, minus_lie, _) ->
+    tcSyntaxName origin pat_ty minusName minus_name    `thenTc` \ (minus_expr, minus_lie, _) ->
 
     returnTc (NPlusKPat bndr_id i pat_ty
                        (SectionR (HsVar (instToId ge)) over_lit_expr)

diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 8e3862c..8a13a77 100644 (file)
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -50,7 +50,7 @@ module TcType (
 
   ---------------------------------
   -- Misc type manipulators
-  hoistForAllTys, deNoteType,
+  deNoteType, 
   namesOfType, namesOfDFunHead,
   getDFunTyKey,
 
@@ -721,36 +721,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 %************************************************************************
 
 \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
-  = case hoist ty ty of 
-       (tvs, theta, body) -> mkForAllTys tvs (mkFunTys theta body)
-  where
-    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)
-       | otherwise                = case hoist res res of
-                                       (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)
-\end{code}
-
-
-\begin{code}
 deNoteType :: Type -> Type
        -- Remove synonyms, but not source types
 deNoteType ty@(TyVarTy tyvar)  = ty