X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=c993c2d9f953b7aec253073b0f76decb54a52078;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=880dc7aef094557ca0dd9ba11c7429cb739d01f9;hpb=6b13f11dcba5da8c3314b90474aa9542248f106d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 880dc7a..c993c2d 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker} @@ -7,65 +7,61 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -#include "HsVersions.h" - module TcHsSyn ( - SYN_IE(TcIdBndr), TcIdOcc(..), - - SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat), - SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch), - SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds), - SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds), + TcMonoBinds, TcHsBinds, TcPat, + TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch, + TcStmt, TcArithSeqInfo, TcRecordBinds, + TcHsModule, TcCoreExpr, TcDictBinds, + TcForeignExportDecl, - SYN_IE(TypecheckedHsBinds), - SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat), - SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo), - SYN_IE(TypecheckedStmt), - SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule), - SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), - SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds), + TypecheckedHsBinds, + TypecheckedMonoBinds, TypecheckedPat, + TypecheckedHsExpr, TypecheckedArithSeqInfo, + TypecheckedStmt, TypecheckedForeignDecl, + TypecheckedMatch, TypecheckedHsModule, + TypecheckedGRHSsAndBinds, TypecheckedGRHS, + TypecheckedRecordBinds, TypecheckedDictBinds, mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, tcIdTyVars, - zonkBinds, zonkMonoBinds + -- re-exported from TcEnv + TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId, + + maybeBoxedPrimType, + + zonkTopBinds, zonkTcId, zonkId, + zonkForeignExports ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids - SYN_IE(DictVar), idType, - SYN_IE(IdEnv), growIdEnvList, lookupIdEnv, - SYN_IE(Id) - ) -- others: -import Name ( Name{--O only-}, NamedThing(..) ) +import Id ( idType, setIdType, Id ) +import DataCon ( DataCon, dataConArgTys ) +import Name ( NamedThing(..) ) +import BasicTypes ( Unused ) +import TcEnv ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv, + TcIdOcc(..), TcIdBndr, GlobalValueEnv, + tcIdType, tcIdTyVars, tcInstId + ) + import TcMonad -import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), - zonkTcTypeToType, zonkTcTyVarToTyVar +import TcType ( TcType, TcTyVar, TcBox, + zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType ) -import Usage ( SYN_IE(UVar) ) -import Util ( zipEqual, panic, - pprPanic, pprTrace -#ifdef DEBUG - , assertPanic -#endif - ) - -import PprType ( GenType, GenTyVar ) -- instances -import Type ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) ) -import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar), - SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet ) -import TysPrim ( voidTy ) -import CoreSyn ( GenCoreExpr ) -import Unique ( Unique ) -- instances +import TyCon ( isDataTyCon ) +import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type ) +import Var ( TyVar ) +import VarEnv ( TyVarEnv, emptyVarEnv, extendVarEnvList ) +import TysWiredIn ( voidTy ) +import CoreSyn ( Expr ) +import Bag import UniqFM import Outputable -import Pretty \end{code} @@ -80,37 +76,35 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes, which have immutable type variables in them. \begin{code} -type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes -data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either - | RealId Id - -type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcHsBinds s = HsBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcMonoBinds s = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s) type TcDictBinds s = TcMonoBinds s -type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s) -type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) -type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) - -type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar - -type TypecheckedPat = OutPat TyVar UVar Id -type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat +type TcPat s = OutPat (TcBox s) (TcIdOcc s) +type TcExpr s = HsExpr (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcGRHS s = GRHS (TcBox s) (TcIdOcc s) (TcPat s) +type TcMatch s = Match (TcBox s) (TcIdOcc s) (TcPat s) +type TcStmt s = Stmt (TcBox s) (TcIdOcc s) (TcPat s) +type TcArithSeqInfo s = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s) +type TcRecordBinds s = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s) +type TcHsModule s = HsModule (TcBox s) (TcIdOcc s) (TcPat s) + +type TcCoreExpr s = Expr (TcIdOcc s) (TcBox s) +type TcForeignExportDecl s = ForeignDecl (TcIdOcc s) + +type TypecheckedPat = OutPat Unused Id +type TypecheckedMonoBinds = MonoBinds Unused Id TypecheckedPat type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat -type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat -type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat -type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat -type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat -type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat -type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat +type TypecheckedHsBinds = HsBinds Unused Id TypecheckedPat +type TypecheckedHsExpr = HsExpr Unused Id TypecheckedPat +type TypecheckedArithSeqInfo = ArithSeqInfo Unused Id TypecheckedPat +type TypecheckedStmt = Stmt Unused Id TypecheckedPat +type TypecheckedMatch = Match Unused Id TypecheckedPat +type TypecheckedGRHSsAndBinds = GRHSsAndBinds Unused Id TypecheckedPat +type TypecheckedGRHS = GRHS Unused Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds Unused Id TypecheckedPat +type TypecheckedHsModule = HsModule Unused Id TypecheckedPat +type TypecheckedForeignDecl = ForeignDecl Id \end{code} \begin{code} @@ -125,151 +119,208 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr +\end{code} -tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) +%************************************************************************ +%* * +\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} +%* * +%************************************************************************ -tcIdTyVars (TcId id) = tyVarsOfType (idType id) -tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables -\end{code} +Some gruesome hackery for desugaring ccalls. It's here because if we put it +in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and +DsCCall.lhs. \begin{code} -instance Eq (TcIdOcc s) where - (TcId id1) == (TcId id2) = id1 == id2 - (RealId id1) == (RealId id2) = id1 == id2 - _ == _ = False - -instance Outputable (TcIdOcc s) where - ppr sty (TcId id) = ppr sty id - ppr sty (RealId id) = ppr sty id - -instance NamedThing (TcIdOcc s) where - getName (TcId id) = getName id - getName (RealId id) = getName id +maybeBoxedPrimType :: Type -> Maybe (DataCon, Type) +maybeBoxedPrimType ty + = case splitAlgTyConApp_maybe ty of -- Data type, + Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor + -> case (dataConArgTys data_con tys_applied) of + [data_con_arg_ty] -- Applied to exactly one type, + | isUnLiftedType data_con_arg_ty -- which is primitive + -> Just (data_con, data_con_arg_ty) + other_cases -> Nothing + other_cases -> Nothing \end{code} - %************************************************************************ %* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} %* * %************************************************************************ +@zonkTcId@ just works on TcIdOccs. It's used when zonking Method insts. + +\begin{code} +zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s) +zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id +zonkTcId (TcId id) + = zonkId id `thenNF_Tc` \id -> + returnNF_Tc (TcId id) + +zonkId :: TcIdBndr s -> NF_TcM s (TcIdBndr s) +zonkId id + = zonkTcType (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (setIdType id ty') +\end{code} + + This zonking pass runs over the bindings a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc b) convert unbound TcTyVar to Void + c) convert each TcIdBndr to an Id by zonking its type We pass an environment around so that + a) we know which TyVars are unbound b) we maintain sharing; eg an Id is zonked at its binding site and they all occurrences of that Id point to the common zonked copy +Actually, since this is all in the Tc monad, it's convenient to keep the +mapping from TcIds to Ids in the GVE of the Tc monad. (Those TcIds +were previously in the LVE of the Tc monad.) The type variables, though, +we carry round in a separate environment. + It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. - \begin{code} -zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id -zonkIdBndr te (TcId (Id u n ty details prags info)) - = zonkTcTypeToType te ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u n ty' details prags info) +extend_te te tyvars = extendVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] +zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id zonkIdBndr te (RealId id) = returnNF_Tc id +zonkIdBndr te (TcId id) + = zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' -> + returnNF_Tc (setIdType id ty') -zonkIdOcc :: IdEnv Id -> TcIdOcc s -> Id -zonkIdOcc ve (RealId id) = id -zonkIdOcc ve (TcId id) = case (lookupIdEnv ve id) of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $ - Id u n voidTy details prags info - where - Id u n _ details prags info = id - -extend_ve ve ids = growIdEnvList ve [(id,id) | id <- ids] -extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] + +zonkIdOcc :: TcIdOcc s -> NF_TcM s Id +zonkIdOcc (RealId id) = returnNF_Tc id +zonkIdOcc (TcId id) + = tcLookupGlobalValueMaybe (getName id) `thenNF_Tc` \ maybe_id' -> + let + new_id = case maybe_id' of + Just id' -> id' + Nothing -> pprTrace "zonkIdOcc: " (ppr id) $ + setIdType id voidTy + in + returnNF_Tc new_id \end{code} \begin{code} -zonkBinds :: TyVarEnv Type -> IdEnv Id - -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id) - -zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve) - -zonkBinds te ve (ThenBinds binds1 binds2) - = zonkBinds te ve binds1 `thenNF_Tc` \ (new_binds1, ve1) -> - zonkBinds te ve1 binds2 `thenNF_Tc` \ (new_binds2, ve2) -> - returnNF_Tc (ThenBinds new_binds1 new_binds2, ve2) - -zonkBinds te ve (MonoBind bind sigs is_rec) - = ASSERT( null sigs ) - fixNF_Tc (\ ~(_,new_ve) -> - zonkMonoBinds te new_ve bind `thenNF_Tc` \ (new_bind, new_ids) -> - returnNF_Tc (MonoBind new_bind [] is_rec, extend_ve ve new_ids) - ) +zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv) +zonkTopBinds binds -- Top level is implicitly recursive + = fixNF_Tc (\ ~(_, new_ids) -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkMonoBinds emptyVarEnv binds `thenNF_Tc` \ (binds', _, new_ids) -> + -- No top-level existential type variables + tcGetGlobalValEnv `thenNF_Tc` \ env -> + returnNF_Tc ((binds', env), new_ids) + ) `thenNF_Tc` \ (stuff, _) -> + returnNF_Tc stuff + + +zonkBinds :: TyVarEnv Type + -> TcHsBinds s + -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s) + +zonkBinds te binds + = go binds te (\ binds' te' -> tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (binds', te', env)) + where + -- go :: TcHsBinds s + -- -> (TypecheckedHsBinds + -- -> TyVarEnv Type + -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s) + -- ) + -- -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s) + go (ThenBinds b1 b2) te thing_inside = go b1 te $ \ b1' te1 -> + go b2 te1 $ \ b2' te2 -> + thing_inside (b1' `ThenBinds` b2') te2 + + go EmptyBinds te thing_inside = thing_inside EmptyBinds te + + go (MonoBind bind sigs is_rec) te thing_inside + = ASSERT( null sigs ) + fixNF_Tc (\ ~(_, new_tvs, new_ids) -> + let + new_te = extend_te te (bagToList new_tvs) + in + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkMonoBinds new_te bind `thenNF_Tc` \ (new_bind, new_tvs, new_ids) -> + thing_inside (MonoBind new_bind [] is_rec) new_te `thenNF_Tc` \ stuff -> + returnNF_Tc (stuff, new_tvs, new_ids) + ) `thenNF_Tc` \ (stuff, _, _) -> + returnNF_Tc stuff \end{code} \begin{code} ------------------------------------------------------------------------- -zonkMonoBinds :: TyVarEnv Type -> IdEnv Id - -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id]) +zonkMonoBinds :: TyVarEnv Type + -> TcMonoBinds s + -> NF_TcM s (TypecheckedMonoBinds, Bag TyVar, Bag Id) -zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, []) +zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag, emptyBag) -zonkMonoBinds te ve (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds te ve mbinds1 `thenNF_Tc` \ (new_mbinds1, ids1) -> - zonkMonoBinds te ve mbinds2 `thenNF_Tc` \ (new_mbinds2, ids2) -> - returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2, ids1 ++ ids2) +zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2) + = zonkMonoBinds te mbinds1 `thenNF_Tc` \ (b1', tvs1, ids1) -> + zonkMonoBinds te mbinds2 `thenNF_Tc` \ (b2', tvs2, ids2) -> + returnNF_Tc (b1' `AndMonoBinds` b2', + tvs1 `unionBags` tvs2, + ids1 `unionBags` ids2) -zonkMonoBinds te ve (PatMonoBind pat grhss_w_binds locn) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids) +zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn) + = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) -> + zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, tvs, ids) -zonkMonoBinds te ve (VarMonoBind var expr) +zonkMonoBinds te (VarMonoBind var expr) = zonkIdBndr te var `thenNF_Tc` \ new_var -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr, [new_var]) + zonkExpr te expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (VarMonoBind new_var new_expr, emptyBag, unitBag new_var) -zonkMonoBinds te ve (CoreMonoBind var core_expr) +zonkMonoBinds te (CoreMonoBind var core_expr) = zonkIdBndr te var `thenNF_Tc` \ new_var -> - returnNF_Tc (CoreMonoBind new_var core_expr, [new_var]) + returnNF_Tc (CoreMonoBind new_var core_expr, emptyBag, unitBag new_var) -zonkMonoBinds te ve (FunMonoBind var inf ms locn) +zonkMonoBinds te (FunMonoBind var inf ms locn) = zonkIdBndr te var `thenNF_Tc` \ new_var -> - mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_var inf new_ms locn, [new_var]) + mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (FunMonoBind new_var inf new_ms locn, emptyBag, unitBag new_var) -zonkMonoBinds te ve (AbsBinds tyvars dicts exports val_bind) +zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> let new_te = extend_te te new_tyvars in mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + fixNF_Tc (\ ~(_, _, val_bind_tvs, val_bind_ids) -> + let + new_te2 = extend_te new_te (bagToList val_bind_tvs) + in + tcExtendGlobalValEnv (bagToList val_bind_ids) $ + zonkMonoBinds new_te2 val_bind `thenNF_Tc` \ (new_val_bind, val_bind_tvs, val_bind_ids) -> + mapNF_Tc (zonkExport new_te2) exports `thenNF_Tc` \ new_exports -> + returnNF_Tc (new_val_bind, new_exports, val_bind_tvs, val_bind_ids) + ) `thenNF_Tc ` \ (new_val_bind, new_exports, _, _) -> let - ve1 = extend_ve ve new_dicts - in - fixNF_Tc (\ ~(_, _, ve2) -> - zonkMonoBinds new_te ve2 val_bind `thenNF_Tc` \ (new_val_bind, new_ids) -> - mapNF_Tc (zonkExport new_te ve2) exports `thenNF_Tc` \ new_exports -> - returnNF_Tc (new_val_bind, new_exports, extend_ve ve1 new_ids) - ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) -> - - let - new_globals = [global | (_, global, local) <- new_exports] + new_globals = listToBag [global | (_, global, local) <- new_exports] in returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind, + emptyBag, -- For now. new_globals) - where - zonkExport te ve (tyvars, global, local) + zonkExport te (tyvars, global, local) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> zonkIdBndr te global `thenNF_Tc` \ new_global -> - returnNF_Tc (new_tyvars, new_global, zonkIdOcc ve local) + zonkIdOcc local `thenNF_Tc` \ new_local -> + returnNF_Tc (new_tyvars, new_global, new_local) \end{code} %************************************************************************ @@ -279,44 +330,41 @@ zonkMonoBinds te ve (AbsBinds tyvars dicts exports val_bind) %************************************************************************ \begin{code} -zonkMatch :: TyVarEnv Type -> IdEnv Id +zonkMatch :: TyVarEnv Type -> TcMatch s -> NF_TcM s TypecheckedMatch -zonkMatch te ve (PatMatch pat match) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> +zonkMatch te (PatMatch pat match) + = zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) -> let - new_ve = extend_ve ve ids + new_te = extend_te te (bagToList new_tvs) in - zonkMatch te new_ve match `thenNF_Tc` \ new_match -> + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkMatch new_te match `thenNF_Tc` \ new_match -> returnNF_Tc (PatMatch new_pat new_match) -zonkMatch te ve (GRHSMatch grhss_w_binds) - = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> +zonkMatch te (GRHSMatch grhss_w_binds) + = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> returnNF_Tc (GRHSMatch new_grhss_w_binds) -zonkMatch te ve (SimpleMatch expr) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkMatch te (SimpleMatch expr) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SimpleMatch new_expr) ------------------------------------------------------------------------- -zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id +zonkGRHSsAndBinds :: TyVarEnv Type -> TcGRHSsAndBinds s -> NF_TcM s TypecheckedGRHSsAndBinds -zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty) - = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> +zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty) + = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) -> + tcSetEnv new_env $ let - zonk_grhs (GRHS guard expr locn) - = zonkStmts te new_ve guard `thenNF_Tc` \ (new_guard, new_ve2) -> - zonkExpr te new_ve2 expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) + zonk_grhs (GRHS guarded locn) + = zonkStmts new_te guarded `thenNF_Tc` \ new_guarded -> + returnNF_Tc (GRHS new_guarded locn) in mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + zonkTcTypeToType new_te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) \end{code} @@ -327,232 +375,222 @@ zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty) %************************************************************************ \begin{code} -{- -zonkExpr :: TyVarEnv Type -> IdEnv Id +zonkExpr :: TyVarEnv Type -> TcExpr s -> NF_TcM s TypecheckedHsExpr --} -zonkExpr te ve (HsVar name) - = returnNF_Tc (HsVar (zonkIdOcc ve name)) -zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit" +zonkExpr te (HsVar id) + = zonkIdOcc id `thenNF_Tc` \ id' -> + returnNF_Tc (HsVar id') + +zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit" -zonkExpr te ve (HsLitOut lit ty) +zonkExpr te (HsLitOut lit ty) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (HsLitOut lit new_ty) -zonkExpr te ve (HsLam match) - = zonkMatch te ve match `thenNF_Tc` \ new_match -> +zonkExpr te (HsLam match) + = zonkMatch te match `thenNF_Tc` \ new_match -> returnNF_Tc (HsLam new_match) -zonkExpr te ve (HsApp e1 e2) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> +zonkExpr te (HsApp e1 e2) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (HsApp new_e1 new_e2) -zonkExpr te ve (OpApp e1 op fixity e2) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve op `thenNF_Tc` \ new_op -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> +zonkExpr te (OpApp e1 op fixity e2) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te op `thenNF_Tc` \ new_op -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op fixity new_e2) -zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp" -zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar" +zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp" +zonkExpr te (HsPar _) = panic "zonkExpr te:HsPar" -zonkExpr te ve (SectionL expr op) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkExpr te ve op `thenNF_Tc` \ new_op -> +zonkExpr te (SectionL expr op) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkExpr te op `thenNF_Tc` \ new_op -> returnNF_Tc (SectionL new_expr new_op) -zonkExpr te ve (SectionR op expr) - = zonkExpr te ve op `thenNF_Tc` \ new_op -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (SectionR op expr) + = zonkExpr te op `thenNF_Tc` \ new_op -> + zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SectionR new_op new_expr) -zonkExpr te ve (HsCase expr ms src_loc) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms -> +zonkExpr te (HsCase expr ms src_loc) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (zonkMatch te) ms `thenNF_Tc` \ new_ms -> returnNF_Tc (HsCase new_expr new_ms src_loc) -zonkExpr te ve (HsIf e1 e2 e3 src_loc) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> - zonkExpr te ve e3 `thenNF_Tc` \ new_e3 -> +zonkExpr te (HsIf e1 e2 e3 src_loc) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> + zonkExpr te e3 `thenNF_Tc` \ new_e3 -> returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) -zonkExpr te ve (HsLet binds expr) - = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> - zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (HsLet binds expr) + = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) -> + tcSetEnv new_env $ + zonkExpr new_te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr te ve (HsDo _ _ _) = panic "zonkExpr te ve:HsDo" +zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo" -zonkExpr te ve (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) - = zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, _) -> +zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) + = zonkStmts te stmts `thenNF_Tc` \ new_stmts -> zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (HsDoOut do_or_lc new_stmts - (zonkIdOcc ve return_id) - (zonkIdOcc ve then_id) - (zonkIdOcc ve zero_id) + zonkIdOcc return_id `thenNF_Tc` \ new_return_id -> + zonkIdOcc then_id `thenNF_Tc` \ new_then_id -> + zonkIdOcc zero_id `thenNF_Tc` \ new_zero_id -> + returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id new_ty src_loc) -zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList" +zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList" -zonkExpr te ve (ExplicitListOut ty exprs) +zonkExpr te (ExplicitListOut ty exprs) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> + mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitListOut new_ty new_exprs) -zonkExpr te ve (ExplicitTuple exprs) - = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitTuple new_exprs) +zonkExpr te (ExplicitTuple exprs boxed) + = mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitTuple new_exprs boxed) -zonkExpr te ve (RecordCon con rbinds) - = zonkExpr te ve con `thenNF_Tc` \ new_con -> - zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordCon new_con new_rbinds) +zonkExpr te (HsCon data_con tys exprs) + = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> + mapNF_Tc (zonkExpr te) exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (HsCon data_con new_tys new_exprs) -zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd" +zonkExpr te (RecordConOut data_con con_expr rbinds) + = zonkExpr te con_expr `thenNF_Tc` \ new_con_expr -> + zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds) -zonkExpr te ve (RecordUpdOut expr ty dicts rbinds) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd" + +zonkExpr te (RecordUpdOut expr ty dicts rbinds) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds -> + mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> + zonkRbinds te rbinds `thenNF_Tc` \ new_rbinds -> returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds) - where - new_dicts = map (zonkIdOcc ve) dicts -zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig" -zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn" +zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig" +zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn" -zonkExpr te ve (ArithSeqOut expr info) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkArithSeq te ve info `thenNF_Tc` \ new_info -> +zonkExpr te (ArithSeqOut expr info) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkArithSeq te info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) -zonkExpr te ve (CCall fun args may_gc is_casm result_ty) - = mapNF_Tc (zonkExpr te ve) args `thenNF_Tc` \ new_args -> +zonkExpr te (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc (zonkExpr te) args `thenNF_Tc` \ new_args -> zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty -> returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) -zonkExpr te ve (HsSCC label expr) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (HsSCC label expr) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsSCC label new_expr) -zonkExpr te ve (TyLam tyvars expr) +zonkExpr te (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> let new_te = extend_te te new_tyvars in - zonkExpr new_te ve expr `thenNF_Tc` \ new_expr -> + zonkExpr new_te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (TyLam new_tyvars new_expr) -zonkExpr te ve (TyApp expr tys) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (TyApp expr tys) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> returnNF_Tc (TyApp new_expr new_tys) -zonkExpr te ve (DictLam dicts expr) +zonkExpr te (DictLam dicts expr) = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts -> - let - new_ve = extend_ve ve new_dicts - in - zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> + tcExtendGlobalValEnv new_dicts $ + zonkExpr te expr `thenNF_Tc` \ new_expr -> returnNF_Tc (DictLam new_dicts new_expr) -zonkExpr te ve (DictApp expr dicts) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkExpr te (DictApp expr dicts) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> returnNF_Tc (DictApp new_expr new_dicts) - where - new_dicts = map (zonkIdOcc ve) dicts - -zonkExpr te ve (ClassDictLam dicts methods expr) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) - where - new_dicts = map (zonkIdOcc ve) dicts - new_methods = map (zonkIdOcc ve) methods - - -zonkExpr te ve (Dictionary dicts methods) - = returnNF_Tc (Dictionary new_dicts new_methods) - where - new_dicts = map (zonkIdOcc ve) dicts - new_methods = map (zonkIdOcc ve) methods -zonkExpr te ve (SingleDict name) - = returnNF_Tc (SingleDict (zonkIdOcc ve name)) ------------------------------------------------------------------------- -zonkArithSeq :: TyVarEnv Type -> IdEnv Id +zonkArithSeq :: TyVarEnv Type -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo -zonkArithSeq te ve (From e) - = zonkExpr te ve e `thenNF_Tc` \ new_e -> +zonkArithSeq te (From e) + = zonkExpr te e `thenNF_Tc` \ new_e -> returnNF_Tc (From new_e) -zonkArithSeq te ve (FromThen e1 e2) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te (FromThen e1 e2) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromThen new_e1 new_e2) -zonkArithSeq te ve (FromTo e1 e2) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te (FromTo e1 e2) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromTo new_e1 new_e2) -zonkArithSeq te ve (FromThenTo e1 e2 e3) - = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> - zonkExpr te ve e3 `thenNF_Tc` \ new_e3 -> +zonkArithSeq te (FromThenTo e1 e2 e3) + = zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> + zonkExpr te e3 `thenNF_Tc` \ new_e3 -> returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkStmts :: TyVarEnv Type -> IdEnv Id - -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], IdEnv Id) - -zonkStmts te ve [] = returnNF_Tc ([], ve) - -zonkStmts te ve [ReturnStmt expr] - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc ([ReturnStmt new_expr], ve) - -zonkStmts te ve (ExprStmt expr locn : stmts) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, new_ve) -> - returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_ve) - -zonkStmts te ve (GuardStmt expr locn : stmts) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkStmts te ve stmts `thenNF_Tc` \ (new_stmts, new_ve) -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_ve) - -zonkStmts te ve (LetStmt binds : stmts) - = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> - zonkStmts te new_ve stmts `thenNF_Tc` \ (new_stmts, new_ve2) -> - returnNF_Tc (LetStmt new_binds : new_stmts, new_ve2) - -zonkStmts te ve (BindStmt pat expr locn : stmts) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkStmts :: TyVarEnv Type + -> [TcStmt s] + -> NF_TcM s [TypecheckedStmt] + +zonkStmts te [] = returnNF_Tc [] + +zonkStmts te [ReturnStmt expr] + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + returnNF_Tc [ReturnStmt new_expr] + +zonkStmts te (ExprStmt expr locn : stmts) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkStmts te stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmt new_expr locn : new_stmts) + +zonkStmts te (GuardStmt expr locn : stmts) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkStmts te stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (GuardStmt new_expr locn : new_stmts) + +zonkStmts te (LetStmt binds : stmts) + = zonkBinds te binds `thenNF_Tc` \ (new_binds, new_te, new_env) -> + tcSetEnv new_env $ + zonkStmts new_te stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (LetStmt new_binds : new_stmts) + +zonkStmts te (BindStmt pat expr locn : stmts) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkPat te pat `thenNF_Tc` \ (new_pat, new_tvs, new_ids) -> let - new_ve = extend_ve ve ids + new_te = extend_te te (bagToList new_tvs) in - zonkStmts te new_ve stmts `thenNF_Tc` \ (new_stmts, new_ve2) -> - returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_ve2) + tcExtendGlobalValEnv (bagToList new_ids) $ + zonkStmts new_te stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts) ------------------------------------------------------------------------- -zonkRbinds :: TyVarEnv Type -> IdEnv Id +zonkRbinds :: TyVarEnv Type -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds -zonkRbinds te ve rbinds +zonkRbinds te rbinds = mapNF_Tc zonk_rbind rbinds where zonk_rbind (field, expr, pun) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (zonkIdOcc ve field, new_expr, pun) + = zonkExpr te expr `thenNF_Tc` \ new_expr -> + zonkIdOcc field `thenNF_Tc` \ new_field -> + returnNF_Tc (new_field, new_expr, pun) \end{code} %************************************************************************ @@ -562,85 +600,116 @@ zonkRbinds te ve rbinds %************************************************************************ \begin{code} -{- -zonkPat :: TyVarEnv Type -> IdEnv Id - -> TcPat s -> NF_TcM s (TypecheckedPat, [Id]) --} -zonkPat te ve (WildPat ty) +zonkPat :: TyVarEnv Type + -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id) + +zonkPat te (WildPat ty) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty, []) + returnNF_Tc (WildPat new_ty, emptyBag, emptyBag) -zonkPat te ve (VarPat v) +zonkPat te (VarPat v) = zonkIdBndr te v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v, [new_v]) + returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v) -zonkPat te ve (LazyPat pat) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (LazyPat new_pat, ids) +zonkPat te (LazyPat pat) + = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) -> + returnNF_Tc (LazyPat new_pat, tvs, ids) -zonkPat te ve (AsPat n pat) +zonkPat te (AsPat n pat) = zonkIdBndr te n `thenNF_Tc` \ new_n -> - zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc (AsPat new_n new_pat, new_n:ids) + zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) -> + returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids) -zonkPat te ve (ConPat n ty pats) +zonkPat te (ListPat ty pats) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ConPat n new_ty new_pats, ids) + zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) -> + returnNF_Tc (ListPat new_ty new_pats, tvs, ids) -zonkPat te ve (ConOpPat pat1 op pat2 ty) - = zonkPat te ve pat1 `thenNF_Tc` \ (new_pat1, ids1) -> - zonkPat te ve pat2 `thenNF_Tc` \ (new_pat2, ids2) -> - zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 ++ ids2) +zonkPat te (TuplePat pats boxed) + = zonkPats te pats `thenNF_Tc` \ (new_pats, tvs, ids) -> + returnNF_Tc (TuplePat new_pats boxed, tvs, ids) -zonkPat te ve (ListPat ty pats) - = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (ListPat new_ty new_pats, ids) +zonkPat te (ConPat n ty tvs dicts pats) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> + let + new_te = extend_te te new_tvs + in + mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + + zonkPats new_te pats `thenNF_Tc` \ (new_pats, tvs, ids) -> -zonkPat te ve (TuplePat pats) - = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> - returnNF_Tc (TuplePat new_pats, ids) + returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats, + listToBag new_tvs `unionBags` tvs, + listToBag new_dicts `unionBags` ids) -zonkPat te ve (RecPat n ty rpats) +zonkPat te (RecPat n ty tvs dicts rpats) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) -> - returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s) + mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs -> + let + new_te = extend_te te new_tvs + in + mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> + tcExtendGlobalValEnv new_dicts $ + mapNF_Tc (zonk_rpat new_te) rpats `thenNF_Tc` \ stuff -> + let + (new_rpats, tvs_s, ids_s) = unzip3 stuff + in + returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats, + listToBag new_tvs `unionBags` unionManyBags tvs_s, + listToBag new_dicts `unionBags` unionManyBags ids_s) where - zonk_rpat (f, pat, pun) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - returnNF_Tc ((f, new_pat, pun), ids) + zonk_rpat te (f, pat, pun) + = zonkPat te pat `thenNF_Tc` \ (new_pat, tvs, ids) -> + returnNF_Tc ((f, new_pat, pun), tvs, ids) -zonkPat te ve (LitPat lit ty) +zonkPat te (LitPat lit ty) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty, []) + returnNF_Tc (LitPat lit new_ty, emptyBag, emptyBag) -zonkPat te ve (NPat lit ty expr) +zonkPat te (NPat lit ty expr) = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr, []) + zonkExpr te expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (NPat lit new_ty new_expr, emptyBag, emptyBag) -zonkPat te ve (NPlusKPat n k ty e1 e2) +zonkPat te (NPlusKPat n k ty e1 e2) = zonkIdBndr te n `thenNF_Tc` \ new_n -> zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> - zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> - zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, [new_n]) + zonkExpr te e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te e2 `thenNF_Tc` \ new_e2 -> + returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, emptyBag, unitBag new_n) -zonkPat te ve (DictPat ds ms) +zonkPat te (DictPat ds ms) = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds -> mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms, new_ds ++ new_ms) + returnNF_Tc (DictPat new_ds new_ms, emptyBag, + listToBag new_ds `unionBags` listToBag new_ms) -zonkPats te ve [] - = returnNF_Tc ([], []) -zonkPats te ve (pat:pats) - = zonkPat te ve pat `thenNF_Tc` \ (pat', ids1) -> - zonkPats te ve pats `thenNF_Tc` \ (pats', ids2) -> - returnNF_Tc (pat':pats', ids1 ++ ids2) +zonkPats te [] + = returnNF_Tc ([], emptyBag, emptyBag) +zonkPats te (pat:pats) + = zonkPat te pat `thenNF_Tc` \ (pat', tvs1, ids1) -> + zonkPats te pats `thenNF_Tc` \ (pats', tvs2, ids2) -> + returnNF_Tc (pat':pats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2) \end{code} +%************************************************************************ +%* * +\subsection[BackSubst-Foreign]{Foreign exports} +%* * +%************************************************************************ + +\begin{code} +zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports ls = mapNF_Tc zonkForeignExport ls + +zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl) +zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = + zonkIdOcc i `thenNF_Tc` \ i' -> + returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) + +\end{code}