%
-% (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}
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}
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}
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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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}
projects / ghc-hetmet.git / blobdiff