From 4bca2e7f766e3a265e77cbce4884f889d6d28299 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 29 Jul 2002 13:19:53 +0000 Subject: [PATCH] [project @ 2002-07-29 13:19:52 by simonpj] ** MERGE TO STABLE ** Fix an alpha-renaming bug in hoistForAlls --- ghc/compiler/coreSyn/Subst.lhs | 5 ++- ghc/compiler/typecheck/TcMonoType.lhs | 63 +++++++++++++++++++++++++++++++-- ghc/compiler/typecheck/TcPat.lhs | 3 +- ghc/compiler/typecheck/TcType.lhs | 32 +---------------- 4 files changed, 66 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index ce5d8bc..17586a1 100644 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4