X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=66fe9cedc9fc9258a8e7f139fb1f0a5261ceebe5;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=b51e4880cb45412a085a62679366cc5a5b7057f2;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index b51e488..66fe9ce 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -7,52 +7,60 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} +#include "HsVersions.h" + module TcHsSyn ( - TcIdBndr(..), TcIdOcc(..), + SYN_IE(TcIdBndr), TcIdOcc(..), - TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), - TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..), - TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..), - TcHsModule(..), + SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), 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), - TypecheckedHsBinds(..), TypecheckedBind(..), - TypecheckedMonoBinds(..), TypecheckedPat(..), - TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), - TypecheckedQual(..), TypecheckedStmt(..), - TypecheckedMatch(..), TypecheckedHsModule(..), - TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), - TypecheckedRecordBinds(..), + SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind), + 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), mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, + tcIdType, tcIdTyVars, zonkBinds, - zonkInst, - zonkId, -- TcIdBndr s -> NF_TcM s Id - unZonkId -- Id -> NF_TcM s (TcIdBndr s) + zonkDictBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..), idType +import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids + SYN_IE(DictVar), idType, + SYN_IE(IdEnv), growIdEnvList, lookupIdEnv ) -- others: +import Name ( Name{--O only-} ) import TcMonad -import TcType ( TcType(..), TcMaybe, TcTyVar(..), - zonkTcTypeToType, zonkTcTyVarToTyVar, - tcInstType +import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), + zonkTcTypeToType, zonkTcTyVarToTyVar ) -import Usage ( UVar(..) ) -import Util ( panic ) +import Usage ( SYN_IE(UVar) ) +import Util ( zipEqual, panic, pprPanic, pprTrace ) import PprType ( GenType, GenTyVar ) -- instances -import TyVar ( GenTyVar ) -- instances +import Type ( mkTyVarTy, tyVarsOfType ) +import TyVar ( GenTyVar {- instances -}, + SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet ) +import TysPrim ( voidTy ) +import CoreSyn ( GenCoreExpr ) import Unique ( Unique ) -- instances +import UniqFM +import PprStyle +import Pretty \end{code} @@ -79,19 +87,19 @@ 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 TcQual s = Qual (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 TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat -type TypecheckedQual = Qual 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 @@ -114,16 +122,18 @@ mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType other = panic "tcIdType" -\end{code} - +tcIdType (TcId id) = idType id +tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) +tcIdTyVars (TcId id) = tyVarsOfType (idType id) +tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables +\end{code} \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 @@ -141,100 +151,148 @@ instance NamedThing (TcIdOcc s) where %* * %************************************************************************ -\begin{code} -zonkId :: TcIdOcc s -> NF_TcM s Id -unZonkId :: Id -> NF_TcM s (TcIdBndr s) +This zonking pass runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void -zonkId (RealId id) = returnNF_Tc id +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 -zonkId (TcId (Id u ty details prags info)) - = zonkTcTypeToType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. -unZonkId (Id u ty details prags info) - = tcInstType [] ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) + +\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) + +zonkIdBndr te (RealId id) = returnNF_Tc id + +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] \end{code} \begin{code} -zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr) -zonkInst (id, expr) - = zonkId id `thenNF_Tc` \ id' -> - zonkExpr expr `thenNF_Tc` \ expr' -> - returnNF_Tc (id', expr') + -- Implicitly mutually recursive, which is overkill, + -- but it means that later ones see earlier ones +zonkDictBinds te ve dbs + = fixNF_Tc (\ ~(_,new_ve) -> + zonkDictBindsLocal te new_ve dbs `thenNF_Tc` \ (new_binds, dict_ids) -> + returnNF_Tc (new_binds, extend_ve ve dict_ids) + ) + + -- The ..Local version assumes the caller has set up + -- a ve that contains all the things bound here +zonkDictBindsLocal te ve [] = returnNF_Tc ([], []) + +zonkDictBindsLocal te ve ((dict,rhs) : binds) + = zonkIdBndr te dict `thenNF_Tc` \ new_dict -> + zonkExpr te ve rhs `thenNF_Tc` \ new_rhs -> + zonkDictBindsLocal te ve binds `thenNF_Tc` \ (new_binds, dict_ids) -> + returnNF_Tc ((new_dict,new_rhs) : new_binds, + new_dict:dict_ids) \end{code} \begin{code} -zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds +zonkBinds :: TyVarEnv Type -> IdEnv Id + -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id) -zonkBinds EmptyBinds = returnNF_Tc EmptyBinds +zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve) -zonkBinds (ThenBinds binds1 binds2) - = zonkBinds binds1 `thenNF_Tc` \ new_binds1 -> - zonkBinds binds2 `thenNF_Tc` \ new_binds2 -> - returnNF_Tc (ThenBinds new_binds1 new_binds2) +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 (SingleBind bind) - = zonkBind bind `thenNF_Tc` \ new_bind -> - returnNF_Tc (SingleBind new_bind) +zonkBinds te ve (SingleBind bind) + = fixNF_Tc (\ ~(_,new_ve) -> + zonkBind te new_ve bind `thenNF_Tc` \ (new_bind, new_ids) -> + returnNF_Tc (SingleBind new_bind, extend_ve ve new_ids) + ) -zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind) +zonkBinds te ve (AbsBinds tyvars dicts locprs dict_binds val_bind) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs -> - mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds -> - zonkBind val_bind `thenNF_Tc` \ new_val_bind -> - returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind) + let + new_te = extend_te te new_tyvars + in + mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc (zonkIdBndr new_te) globals `thenNF_Tc` \ new_globals -> + let + ve1 = extend_ve ve new_globals + ve2 = extend_ve ve1 new_dicts + in + fixNF_Tc (\ ~(_, ve3) -> + zonkDictBindsLocal new_te ve3 dict_binds `thenNF_Tc` \ (new_dict_binds, ds) -> + zonkBind new_te ve3 val_bind `thenNF_Tc` \ (new_val_bind, ls) -> + let + new_locprs = zipEqual "zonkBinds" (map (zonkIdOcc ve3) locals) new_globals + in + returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind, + extend_ve ve2 (ds++ls)) + ) `thenNF_Tc` \ (binds, _) -> + returnNF_Tc (binds, ve1) -- Yes, the "ve1" is right (SLPJ) where - subst_pair (l, g) - = zonkId l `thenNF_Tc` \ new_l -> - zonkId g `thenNF_Tc` \ new_g -> - returnNF_Tc (new_l, new_g) - - subst_bind (v, e) - = zonkId v `thenNF_Tc` \ new_v -> - zonkExpr e `thenNF_Tc` \ new_e -> - returnNF_Tc (new_v, new_e) + (locals, globals) = unzip locprs \end{code} \begin{code} ------------------------------------------------------------------------- -zonkBind :: TcBind s -> NF_TcM s TypecheckedBind +zonkBind :: TyVarEnv Type -> IdEnv Id + -> TcBind s -> NF_TcM s (TypecheckedBind, [Id]) -zonkBind EmptyBind = returnNF_Tc EmptyBind +zonkBind te ve EmptyBind = returnNF_Tc (EmptyBind, []) -zonkBind (NonRecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (NonRecBind new_mbinds) +zonkBind te ve (NonRecBind mbinds) + = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) -> + returnNF_Tc (NonRecBind new_mbinds, new_ids) -zonkBind (RecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (RecBind new_mbinds) +zonkBind te ve (RecBind mbinds) + = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) -> + returnNF_Tc (RecBind new_mbinds, new_ids) ------------------------------------------------------------------------- -zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds - -zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds - -zonkMonoBinds (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 -> - zonkMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 -> - returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2) - -zonkMonoBinds (PatMonoBind pat grhss_w_binds locn) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn) - -zonkMonoBinds (VarMonoBind var expr) - = zonkId var `thenNF_Tc` \ new_var -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr) - -zonkMonoBinds (FunMonoBind name inf ms locn) - = zonkId name `thenNF_Tc` \ new_name -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_name inf new_ms locn) +zonkMonoBinds :: TyVarEnv Type -> IdEnv Id + -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id]) + +zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, []) + +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 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 ve (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]) + +zonkMonoBinds te ve (CoreMonoBind var core_expr) + = zonkIdBndr te var `thenNF_Tc` \ new_var -> + returnNF_Tc (CoreMonoBind new_var core_expr, [new_var]) + +zonkMonoBinds te ve (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]) \end{code} %************************************************************************ @@ -244,39 +302,45 @@ zonkMonoBinds (FunMonoBind name inf ms locn) %************************************************************************ \begin{code} -zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch - -zonkMatch (PatMatch pat match) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkMatch match `thenNF_Tc` \ new_match -> +zonkMatch :: TyVarEnv Type -> IdEnv Id + -> TcMatch s -> NF_TcM s TypecheckedMatch + +zonkMatch te ve (PatMatch pat match) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + let + new_ve = extend_ve ve ids + in + zonkMatch te new_ve match `thenNF_Tc` \ new_match -> returnNF_Tc (PatMatch new_pat new_match) -zonkMatch (GRHSMatch grhss_w_binds) - = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> +zonkMatch te ve (GRHSMatch grhss_w_binds) + = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> returnNF_Tc (GRHSMatch new_grhss_w_binds) -zonkMatch (SimpleMatch expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkMatch te ve (SimpleMatch expr) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SimpleMatch new_expr) ------------------------------------------------------------------------- -zonkGRHSsAndBinds :: TcGRHSsAndBinds s - -> NF_TcM s TypecheckedGRHSsAndBinds - -zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) - = mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkBinds binds `thenNF_Tc` \ new_binds -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> +zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id + -> TcGRHSsAndBinds s + -> NF_TcM s TypecheckedGRHSsAndBinds + +zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + let + zonk_grhs (GRHS guard expr locn) + = zonkExpr te new_ve guard `thenNF_Tc` \ new_guard -> + zonkExpr te new_ve 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) + in + mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> + zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) - where - zonk_grhs (GRHS guard expr locn) - = zonkExpr guard `thenNF_Tc` \ new_guard -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) \end{code} %************************************************************************ @@ -285,211 +349,231 @@ zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) %* * %************************************************************************ -ToDo: panic on things that can't be in @TypecheckedHsExpr@. - \begin{code} -zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TyVarEnv Type -> IdEnv Id + -> TcExpr s -> NF_TcM s TypecheckedHsExpr + +zonkExpr te ve (HsVar name) + = returnNF_Tc (HsVar (zonkIdOcc ve name)) -zonkExpr (HsVar name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (HsVar new_name) +zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit" -zonkExpr (HsLitOut lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> +zonkExpr te ve (HsLitOut lit ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (HsLitOut lit new_ty) -zonkExpr (HsLam match) - = zonkMatch match `thenNF_Tc` \ new_match -> +zonkExpr te ve (HsLam match) + = zonkMatch te ve match `thenNF_Tc` \ new_match -> returnNF_Tc (HsLam new_match) -zonkExpr (HsApp e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkExpr te ve (HsApp e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (HsApp new_e1 new_e2) -zonkExpr (OpApp e1 op e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - returnNF_Tc (OpApp new_e1 new_op 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 -> + returnNF_Tc (OpApp new_e1 new_op fixity new_e2) -zonkExpr (NegApp _) = panic "zonkExpr:NegApp" -zonkExpr (HsPar _) = panic "zonkExpr:HsPar" +zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp" +zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar" -zonkExpr (SectionL expr op) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkExpr op `thenNF_Tc` \ new_op -> +zonkExpr te ve (SectionL expr op) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkExpr te ve op `thenNF_Tc` \ new_op -> returnNF_Tc (SectionL new_expr new_op) -zonkExpr (SectionR op expr) - = zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (SectionR op expr) + = zonkExpr te ve op `thenNF_Tc` \ new_op -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SectionR new_op new_expr) -zonkExpr (HsCase expr ms src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> +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 -> returnNF_Tc (HsCase new_expr new_ms src_loc) -zonkExpr (HsIf e1 e2 e3 src_loc) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> +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 -> returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) -zonkExpr (HsLet binds expr) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +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 -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr (HsDo _ _) = panic "zonkExpr:HsDo" - -zonkExpr (HsDoOut stmts m_id mz_id src_loc) - = zonkStmts stmts `thenNF_Tc` \ new_stmts -> - zonkId m_id `thenNF_Tc` \ m_new -> - zonkId mz_id `thenNF_Tc` \ mz_new -> - returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc) +zonkExpr te ve (HsDo _ _ _) = panic "zonkExpr te ve:HsDo" -zonkExpr (ListComp expr quals) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkQuals quals `thenNF_Tc` \ new_quals -> - returnNF_Tc (ListComp new_expr new_quals) +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 -> + 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) + new_ty src_loc) -zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" +zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList" -zonkExpr (ExplicitListOut ty exprs) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> +zonkExpr te ve (ExplicitListOut ty exprs) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitListOut new_ty new_exprs) -zonkExpr (ExplicitTuple exprs) - = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> +zonkExpr te ve (ExplicitTuple exprs) + = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs) -zonkExpr (RecordCon con rbinds) - = panic "zonkExpr:RecordCon" -zonkExpr (RecordUpd exp rbinds) - = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut exp ids rbinds) - = panic "zonkExpr:RecordUpdOut" +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 (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" -zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" +zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd" + +zonkExpr te ve (RecordUpdOut expr dicts rbinds) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordUpdOut new_expr new_dicts new_rbinds) + where + new_dicts = map (zonkIdOcc ve) dicts -zonkExpr (ArithSeqOut expr info) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkArithSeq info `thenNF_Tc` \ new_info -> +zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig" +zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn" + +zonkExpr te ve (ArithSeqOut expr info) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkArithSeq te ve info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) -zonkExpr (CCall fun args may_gc is_casm result_ty) - = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> - zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> +zonkExpr te ve (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc (zonkExpr te ve) 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 (HsSCC label expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (HsSCC label expr) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsSCC label new_expr) -zonkExpr (TyLam tyvars expr) +zonkExpr te ve (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - zonkExpr expr `thenNF_Tc` \ new_expr -> + let + new_te = extend_te te new_tyvars + in + zonkExpr new_te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (TyLam new_tyvars new_expr) -zonkExpr (TyApp expr tys) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> +zonkExpr te ve (TyApp expr tys) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> returnNF_Tc (TyApp new_expr new_tys) -zonkExpr (DictLam dicts expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (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 -> returnNF_Tc (DictLam new_dicts new_expr) -zonkExpr (DictApp expr dicts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> +zonkExpr te ve (DictApp expr dicts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (DictApp new_expr new_dicts) + where + new_dicts = map (zonkIdOcc ve) dicts -zonkExpr (ClassDictLam dicts methods expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +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 (Dictionary dicts methods) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_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 (SingleDict name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (SingleDict new_name) +zonkExpr te ve (SingleDict name) + = returnNF_Tc (SingleDict (zonkIdOcc ve name)) -zonkExpr (HsCon con tys vargs) - = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> - mapNF_Tc zonkExpr vargs `thenNF_Tc` \ new_vargs -> - returnNF_Tc (HsCon con new_tys new_vargs) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TyVarEnv Type -> IdEnv Id + -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo -zonkArithSeq (From e) - = zonkExpr e `thenNF_Tc` \ new_e -> +zonkArithSeq te ve (From e) + = zonkExpr te ve e `thenNF_Tc` \ new_e -> returnNF_Tc (From new_e) -zonkArithSeq (FromThen e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te ve (FromThen e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromThen new_e1 new_e2) -zonkArithSeq (FromTo e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te ve (FromTo e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromTo new_e1 new_e2) -zonkArithSeq (FromThenTo e1 e2 e3) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> +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 -> returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual] +zonkStmts :: TyVarEnv Type -> IdEnv Id + -> [TcStmt s] -> NF_TcM s [TypecheckedStmt] -zonkQuals quals - = mapNF_Tc zonk_qual quals - where - zonk_qual (GeneratorQual pat expr) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GeneratorQual new_pat new_expr) +zonkStmts te ve [] = returnNF_Tc [] + +zonkStmts te ve [ReturnStmt expr] + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc [ReturnStmt new_expr] + +zonkStmts te ve (ExprStmt expr locn : stmts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmt new_expr locn : new_stmts) + +zonkStmts te ve (GuardStmt expr locn : stmts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (GuardStmt new_expr locn : new_stmts) + +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 -> + returnNF_Tc (LetStmt new_binds : new_stmts) + +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 -> + let + new_ve = extend_ve ve ids + in + zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts) - zonk_qual (FilterQual expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (FilterQual new_expr) - zonk_qual (LetQual binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetQual new_binds) ------------------------------------------------------------------------- -zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt] +zonkRbinds :: TyVarEnv Type -> IdEnv Id + -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds -zonkStmts stmts - = mapNF_Tc zonk_stmt stmts +zonkRbinds te ve rbinds + = mapNF_Tc zonk_rbind rbinds where - zonk_stmt (BindStmt pat expr src_loc) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (BindStmt new_pat new_expr src_loc) - - zonk_stmt (ExprStmt expr src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ExprStmt new_expr src_loc) - - zonk_stmt (LetStmt binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetStmt new_binds) + zonk_rbind (field, expr, pun) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (zonkIdOcc ve field, new_expr, pun) \end{code} %************************************************************************ @@ -499,58 +583,84 @@ zonkStmts stmts %************************************************************************ \begin{code} -zonkPat :: TcPat s -> NF_TcM s TypecheckedPat - -zonkPat (WildPat ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty) - -zonkPat (VarPat v) - = zonkId v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v) - -zonkPat (LazyPat pat) - = zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (LazyPat new_pat) - -zonkPat (AsPat n pat) - = zonkId n `thenNF_Tc` \ new_n -> - zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (AsPat new_n new_pat) - -zonkPat (ConPat n ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ConPat n new_ty new_pats) - -zonkPat (ConOpPat pat1 op pat2 ty) - = zonkPat pat1 `thenNF_Tc` \ new_pat1 -> - zonkPat pat2 `thenNF_Tc` \ new_pat2 -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty) - -zonkPat (ListPat ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ListPat new_ty new_pats) - -zonkPat (TuplePat pats) - = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (TuplePat new_pats) - -zonkPat (LitPat lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty) - -zonkPat (NPat lit ty expr) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr) - -zonkPat (DictPat ds ms) - = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds -> - mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms) +zonkPat :: TyVarEnv Type -> IdEnv Id + -> TcPat s -> NF_TcM s (TypecheckedPat, [Id]) + +zonkPat te ve (WildPat ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (WildPat new_ty, []) + +zonkPat te ve (VarPat v) + = zonkIdBndr te v `thenNF_Tc` \ new_v -> + returnNF_Tc (VarPat new_v, [new_v]) + +zonkPat te ve (LazyPat pat) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc (LazyPat new_pat, ids) + +zonkPat te ve (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 ve (ConPat n 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) + +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 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 ve (TuplePat pats) + = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (TuplePat new_pats, ids) + +zonkPat te ve (RecPat n ty 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) + where + zonk_rpat (f, pat, pun) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc ((f, new_pat, pun), ids) + +zonkPat te ve (LitPat lit ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (LitPat lit new_ty, []) + +zonkPat te ve (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, []) + +zonkPat te ve (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]) + +zonkPat te ve (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) + + +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) + \end{code}