Commit 4bca2e7f authored by simonpj's avatar simonpj

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

** MERGE TO STABLE **

Fix an alpha-renaming bug in hoistForAlls
parent 2ddea0a8
......@@ -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
......
......@@ -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}
%************************************************************************
%* *
......
......@@ -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)
......
......@@ -50,7 +50,7 @@ module TcType (
---------------------------------
-- Misc type manipulators
hoistForAllTys, deNoteType,
deNoteType,
namesOfType, namesOfDFunHead,
getDFunTyKey,
......@@ -720,36 +720,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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment