%
-% (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 (
- TcIdBndr(..), TcIdOcc(..),
+ TcMonoBinds, TcHsBinds, TcPat,
+ TcExpr, TcGRHSs, TcGRHS, TcMatch,
+ TcStmt, TcArithSeqInfo, TcRecordBinds,
+ TcHsModule, TcDictBinds,
+ TcForeignExportDecl,
- TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
- TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
- TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
- TcHsModule(..),
-
- TypecheckedHsBinds(..), TypecheckedBind(..),
- TypecheckedMonoBinds(..), TypecheckedPat(..),
- TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
- TypecheckedQual(..), TypecheckedStmt(..),
- TypecheckedMatch(..), TypecheckedHsModule(..),
- TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
- TypecheckedRecordBinds(..),
-
- mkHsTyApp, mkHsDictApp,
- mkHsTyLam, mkHsDictLam,
- tcIdType, tcIdTyVars,
-
- zonkBinds,
- zonkDictBinds
+ TypecheckedHsBinds, TypecheckedRuleDecl,
+ TypecheckedMonoBinds, TypecheckedPat,
+ TypecheckedHsExpr, TypecheckedArithSeqInfo,
+ TypecheckedStmt, TypecheckedForeignDecl,
+ TypecheckedMatch, TypecheckedHsModule,
+ TypecheckedGRHSs, TypecheckedGRHS,
+ TypecheckedRecordBinds, TypecheckedDictBinds,
+ TypecheckedMatchContext, TypecheckedCoreBind,
+
+ mkHsTyApp, mkHsDictApp, mkHsConApp,
+ mkHsTyLam, mkHsDictLam, mkHsLet,
+ simpleHsLitTy,
+
+ collectTypedPatBinders, outPatType,
+
+ -- re-exported from TcEnv
+ TcId,
+
+ zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
+ zonkForeignExports, zonkRules
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-- friends:
import HsSyn -- oodles of it
-import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
- DictVar(..), idType,
- IdEnv(..), growIdEnvList, lookupIdEnv
- )
-- others:
-import Name ( Name{--O only-} )
-import TcMonad hiding ( rnMtoTcM )
-import TcType ( TcType(..), TcMaybe, TcTyVar(..),
- zonkTcTypeToType, zonkTcTyVarToTyVar
- )
-import Usage ( UVar(..) )
-import Util ( zipEqual, panic, pprPanic, pprTrace )
-
-import PprType ( GenType, GenTyVar ) -- instances
-import Type ( mkTyVarTy, tyVarsOfType )
-import TyVar ( GenTyVar {- instances -},
- TyVarEnv(..), growTyVarEnvList, emptyTyVarSet )
-import TysPrim ( voidTy )
-import Unique ( Unique ) -- instances
-import UniqFM
-import PprStyle
-import Pretty
+import Id ( idName, idType, setIdType, Id )
+import DataCon ( dataConWrapId )
+import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
+
+import TcMonad
+import Type ( Type )
+import TcType ( TcType, tcGetTyVar )
+import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
+import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, addrPrimTy
+ )
+import TysWiredIn ( charTy, stringTy, intTy, integerTy,
+ mkListTy, mkPArrTy, mkTupleTy, unitTy )
+import CoreSyn ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
+import Var ( isId )
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
+import Bag
+import Outputable
+import HscTypes ( TyThing(..) )
\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 TcBind s = Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
-type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat 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 TcQual s = Qualifier (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 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 = Qualifier 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 TcHsBinds = HsBinds TcId TcPat
+type TcMonoBinds = MonoBinds TcId TcPat
+type TcDictBinds = TcMonoBinds
+type TcPat = OutPat TcId
+type TcExpr = HsExpr TcId TcPat
+type TcGRHSs = GRHSs TcId TcPat
+type TcGRHS = GRHS TcId TcPat
+type TcMatch = Match TcId TcPat
+type TcStmt = Stmt TcId TcPat
+type TcArithSeqInfo = ArithSeqInfo TcId TcPat
+type TcRecordBinds = HsRecordBinds TcId TcPat
+type TcHsModule = HsModule TcId TcPat
+
+type TcForeignExportDecl = ForeignDecl TcId
+type TcRuleDecl = RuleDecl TcId TcPat
+
+type TypecheckedPat = OutPat Id
+type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
+type TypecheckedDictBinds = TypecheckedMonoBinds
+type TypecheckedHsBinds = HsBinds Id TypecheckedPat
+type TypecheckedHsExpr = HsExpr Id TypecheckedPat
+type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
+type TypecheckedStmt = Stmt Id TypecheckedPat
+type TypecheckedMatch = Match Id TypecheckedPat
+type TypecheckedMatchContext = HsMatchContext Id
+type TypecheckedGRHSs = GRHSs Id TypecheckedPat
+type TypecheckedGRHS = GRHS Id TypecheckedPat
+type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
+type TypecheckedHsModule = HsModule Id TypecheckedPat
+type TypecheckedForeignDecl = ForeignDecl Id
+type TypecheckedRuleDecl = RuleDecl Id TypecheckedPat
+type TypecheckedCoreBind = (Id, CoreExpr)
\end{code}
\begin{code}
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = DictLam dicts expr
-tcIdType :: TcIdOcc s -> TcType s
-tcIdType (TcId id) = idType id
-tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
+mkHsLet EmptyMonoBinds expr = expr
+mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
+
+mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
+\end{code}
+
+
+------------------------------------------------------
+\begin{code}
+simpleHsLitTy :: HsLit -> TcType
+simpleHsLitTy (HsCharPrim c) = charPrimTy
+simpleHsLitTy (HsStringPrim s) = addrPrimTy
+simpleHsLitTy (HsInt i) = intTy
+simpleHsLitTy (HsInteger i) = integerTy
+simpleHsLitTy (HsIntPrim i) = intPrimTy
+simpleHsLitTy (HsFloatPrim f) = floatPrimTy
+simpleHsLitTy (HsDoublePrim d) = doublePrimTy
+simpleHsLitTy (HsChar c) = charTy
+simpleHsLitTy (HsString str) = stringTy
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%* *
+%************************************************************************
-tcIdTyVars (TcId id) = tyVarsOfType (idType id)
-tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables
+Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
+then something is wrong.
+\begin{code}
+outPatType :: TypecheckedPat -> Type
+
+outPatType (WildPat ty) = ty
+outPatType (VarPat var) = idType var
+outPatType (LazyPat pat) = outPatType pat
+outPatType (AsPat var pat) = idType var
+outPatType (ConPat _ ty _ _ _) = ty
+outPatType (ListPat ty _) = mkListTy ty
+outPatType (PArrPat ty _) = mkPArrTy ty
+outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
+outPatType (RecPat _ ty _ _ _) = ty
+outPatType (SigPat _ ty _) = ty
+outPatType (LitPat lit ty) = ty
+outPatType (NPat lit ty _) = ty
+outPatType (NPlusKPat _ _ ty _ _) = ty
+outPatType (DictPat ds ms) = case (length ds_ms) of
+ 0 -> unitTy
+ 1 -> idType (head ds_ms)
+ n -> mkTupleTy Boxed n (map idType ds_ms)
+ where
+ ds_ms = ds ++ ms
\end{code}
+
+Nota bene: @DsBinds@ relies on the fact that at least for simple
+tuple patterns @collectTypedPatBinders@ returns the binders in
+the same order as they appear in the tuple.
+
+@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
+
\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
+collectTypedPatBinders :: TypecheckedPat -> [Id]
+collectTypedPatBinders (VarPat var) = [var]
+collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
+collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat
+collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat
+collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
+ fields)
+collectTypedPatBinders (DictPat ds ms) = ds ++ ms
+collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
+collectTypedPatBinders any_other_pat = [ {-no binders-} ]
\end{code}
a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
b) convert unbound TcTyVar to Void
+ c) convert each TcId 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
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.
+
+The Ids are converted by binding them in the normal Tc envt; that
+way 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
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)
-
-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]
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> NF_TcM TcId
+zonkId id
+ = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (setIdType id ty')
+
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form. The TyVarEnv give
+zonkIdBndr :: TcId -> NF_TcM Id
+zonkIdBndr id
+ = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (setIdType id ty')
+
+zonkIdOcc :: TcId -> NF_TcM Id
+zonkIdOcc id
+ = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
+ -- We're even look up up superclass selectors and constructors;
+ -- even though zonking them is a no-op anyway, and the
+ -- superclass selectors aren't in the environment anyway.
+ -- But we don't want to call isLocalId to find out whether
+ -- it's a superclass selector (for example) because that looks
+ -- at the IdInfo field, which in turn be in a knot because of
+ -- the big knot in typecheckModule
+ let
+ new_id = case maybe_id' of
+ Just (AnId id') -> id'
+ other -> id -- WARN( isLocalId id, ppr id ) id
+ -- Oops: the warning can give a black hole
+ -- because it looks at the idinfo
+ in
+ returnNF_Tc new_id
\end{code}
+
\begin{code}
- -- 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)
+zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
+zonkTopBinds binds -- Top level is implicitly recursive
+ = fixNF_Tc (\ ~(_, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds binds `thenNF_Tc` \ (binds', new_ids) ->
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc ((binds', env), new_ids)
+ ) `thenNF_Tc` \ (stuff, _) ->
+ returnNF_Tc stuff
+
+zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
+
+zonkBinds binds
+ = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc (binds', env))
+ where
+ -- go :: TcHsBinds
+ -- -> (TypecheckedHsBinds
+ -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
+ -- )
+ -- -> NF_TcM (TypecheckedHsBinds, TcEnv)
+
+ go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' ->
+ go b2 $ \ b2' ->
+ thing_inside (b1' `ThenBinds` b2')
+
+ go EmptyBinds thing_inside = thing_inside EmptyBinds
+
+ go (MonoBind bind sigs is_rec) thing_inside
+ = ASSERT( null sigs )
+ fixNF_Tc (\ ~(_, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkMonoBinds bind `thenNF_Tc` \ (new_bind, new_ids) ->
+ thing_inside (mkMonoBind new_bind [] is_rec) `thenNF_Tc` \ stuff ->
+ returnNF_Tc (stuff, new_ids)
+ ) `thenNF_Tc` \ (stuff, _) ->
+ returnNF_Tc stuff
\end{code}
\begin{code}
-zonkBinds :: TyVarEnv Type -> IdEnv Id
- -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id)
+-------------------------------------------------------------------------
+zonkMonoBinds :: TcMonoBinds
+ -> NF_TcM (TypecheckedMonoBinds, Bag Id)
-zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve)
+zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
-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)
+zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
+ = zonkMonoBinds mbinds1 `thenNF_Tc` \ (b1', ids1) ->
+ zonkMonoBinds mbinds2 `thenNF_Tc` \ (b2', ids2) ->
+ returnNF_Tc (b1' `AndMonoBinds` b2',
+ ids1 `unionBags` ids2)
-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)
- )
+zonkMonoBinds (PatMonoBind pat grhss locn)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
+ returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
-zonkBinds te ve (AbsBinds tyvars dicts locprs dict_binds 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 ->
- 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
- (locals, globals) = unzip locprs
-\end{code}
-
-\begin{code}
--------------------------------------------------------------------------
-zonkBind :: TyVarEnv Type -> IdEnv Id
- -> TcBind s -> NF_TcM s (TypecheckedBind, [Id])
+zonkMonoBinds (VarMonoBind var expr)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
-zonkBind te ve EmptyBind = returnNF_Tc (EmptyBind, [])
+zonkMonoBinds (CoreMonoBind var core_expr)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
-zonkBind te ve (NonRecBind mbinds)
- = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) ->
- returnNF_Tc (NonRecBind new_mbinds, new_ids)
+zonkMonoBinds (FunMonoBind var inf ms locn)
+ = zonkIdBndr var `thenNF_Tc` \ new_var ->
+ mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
-zonkBind te ve (RecBind mbinds)
- = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) ->
- returnNF_Tc (RecBind new_mbinds, new_ids)
--------------------------------------------------------------------------
-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 (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])
+zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
+ = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+ -- No need to extend tyvar env: the effects are
+ -- propagated through binding the tyvars themselves
+
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+
+ fixNF_Tc (\ ~(_, _, val_bind_ids) ->
+ tcExtendGlobalValEnv (bagToList val_bind_ids) $
+ zonkMonoBinds val_bind `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
+ mapNF_Tc zonkExport exports `thenNF_Tc` \ new_exports ->
+ returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
+ ) `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
+ let
+ new_globals = listToBag [global | (_, global, local) <- new_exports]
+ in
+ returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
+ new_globals)
+ where
+ zonkExport (tyvars, global, local)
+ = zonkTcTyVars tyvars `thenNF_Tc` \ tys ->
+ let
+ new_tyvars = map (tcGetTyVar "zonkExport") tys
+ -- This isn't the binding occurrence of these tyvars
+ -- but they should *be* tyvars. Hence tcGetTyVar.
+ in
+ zonkIdBndr global `thenNF_Tc` \ new_global ->
+ zonkIdOcc local `thenNF_Tc` \ new_local ->
+ returnNF_Tc (new_tyvars, new_global, new_local)
\end{code}
%************************************************************************
%* *
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
%* *
%************************************************************************
\begin{code}
-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 :: TcMatch -> NF_TcM TypecheckedMatch
-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 te ve (SimpleMatch expr)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (SimpleMatch new_expr)
+zonkMatch (Match pats _ grhss)
+ = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkGRHSs grhss `thenNF_Tc` \ new_grhss ->
+ returnNF_Tc (Match new_pats Nothing new_grhss)
-------------------------------------------------------------------------
-zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id
- -> TcGRHSsAndBinds s
- -> NF_TcM s TypecheckedGRHSsAndBinds
+zonkGRHSs :: TcGRHSs
+ -> NF_TcM TypecheckedGRHSs
-zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
+zonkGRHSs (GRHSs grhss binds ty)
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
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)
+ zonk_grhs (GRHS guarded locn)
+ = zonkStmts 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 ->
- returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (GRHSs new_grhss new_binds new_ty)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-zonkExpr :: TyVarEnv Type -> IdEnv Id
- -> TcExpr s -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
+
+zonkExpr (HsVar id)
+ = zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsVar id')
+
+zonkExpr (HsIPVar id)
+ = mapIPNameTc zonkIdOcc id `thenNF_Tc` \ id' ->
+ returnNF_Tc (HsIPVar id')
-zonkExpr te ve (HsVar name)
- = returnNF_Tc (HsVar (zonkIdOcc ve name))
+zonkExpr (HsLit (HsRat f ty))
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (HsLit (HsRat f new_ty))
-zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit"
+zonkExpr (HsLit (HsLitLit lit ty))
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (HsLit (HsLitLit lit new_ty))
-zonkExpr te ve (HsLitOut lit ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (HsLitOut lit new_ty)
+zonkExpr (HsLit lit)
+ = returnNF_Tc (HsLit lit)
-zonkExpr te ve (HsLam match)
- = zonkMatch te ve match `thenNF_Tc` \ new_match ->
+-- HsOverLit doesn't appear in typechecker output
+
+zonkExpr (HsLam match)
+ = zonkMatch 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 (HsApp e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (HsApp new_e1 new_e2)
-zonkExpr te ve (OpApp e1 op 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 new_e2)
+zonkExpr (OpApp e1 op fixity 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 fixity new_e2)
-zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
-zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar"
+zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
+zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
-zonkExpr te ve (SectionL expr op)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkExpr te ve op `thenNF_Tc` \ new_op ->
+zonkExpr (SectionL expr op)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkExpr 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 (SectionR op expr)
+ = zonkExpr op `thenNF_Tc` \ new_op ->
+ zonkExpr 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 (HsCase expr ms src_loc)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkMatch 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 (HsIf e1 e2 e3 src_loc)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr 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 (HsLet binds expr)
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (HsLet new_binds new_expr)
-zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo"
-
-zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc)
- = zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc)
-
-zonkExpr te ve (ListComp expr quals)
- = zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) ->
- zonkExpr te new_ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (ListComp new_expr new_quals)
-
-zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList"
-
-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 te ve (ExplicitTuple exprs)
- = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs ->
- returnNF_Tc (ExplicitTuple new_exprs)
-
-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 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 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 ->
+zonkExpr (HsWith expr binds is_with)
+ = zonkIPBinds binds `thenNF_Tc` \ new_binds ->
+ tcExtendGlobalValEnv (map (ipNameName . fst) new_binds) $
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsWith new_expr new_binds is_with)
+ where
+ zonkIPBinds = mapNF_Tc zonkIPBind
+ zonkIPBind (n, e)
+ = mapIPNameTc zonkIdBndr n `thenNF_Tc` \ n' ->
+ zonkExpr e `thenNF_Tc` \ e' ->
+ returnNF_Tc (n', e')
+
+zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
+ = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkIdOcc ids `thenNF_Tc` \ new_ids ->
+ returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
+
+zonkExpr (ExplicitList ty exprs)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitList new_ty new_exprs)
+
+zonkExpr (ExplicitPArr ty exprs)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitPArr new_ty new_exprs)
+
+zonkExpr (ExplicitTuple exprs boxed)
+ = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
+ returnNF_Tc (ExplicitTuple new_exprs boxed)
+
+zonkExpr (RecordConOut data_con con_expr rbinds)
+ = zonkExpr con_expr `thenNF_Tc` \ new_con_expr ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
+ returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
+
+zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
+
+zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
+ zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
+ zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
+ returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
+
+zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
+zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
+zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn"
+
+zonkExpr (ArithSeqOut expr info)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq 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 ->
- zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty ->
- returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
+zonkExpr (PArrSeqOut expr info)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkArithSeq info `thenNF_Tc` \ new_info ->
+ returnNF_Tc (PArrSeqOut new_expr new_info)
+
+zonkExpr (HsCCall fun args may_gc is_casm result_ty)
+ = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
+ zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
+ returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
-zonkExpr te ve (HsSCC label expr)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc (HsSCC label new_expr)
+zonkExpr (HsSCC lbl expr)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (HsSCC lbl new_expr)
-zonkExpr te ve (TyLam tyvars expr)
+zonkExpr (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 ->
+ -- No need to extend tyvar env; see AbsBinds
+
+ zonkExpr 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 ->
- mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
+zonkExpr (TyApp expr tys)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
returnNF_Tc (TyApp new_expr new_tys)
-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 ->
+zonkExpr (DictLam dicts expr)
+ = mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+ zonkExpr 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 (DictApp expr dicts)
+ = zonkExpr 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))
-zonkExpr te ve (HsCon con tys vargs)
- = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
- mapNF_Tc (zonkExpr te ve) vargs `thenNF_Tc` \ new_vargs ->
- returnNF_Tc (HsCon con new_tys new_vargs)
-------------------------------------------------------------------------
-zonkArithSeq :: TyVarEnv Type -> IdEnv Id
- -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
-zonkArithSeq te ve (From e)
- = zonkExpr te ve e `thenNF_Tc` \ new_e ->
+zonkArithSeq (From e)
+ = zonkExpr 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 (FromThen e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr 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 (FromTo e1 e2)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr 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 (FromThenTo e1 e2 e3)
+ = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ zonkExpr e3 `thenNF_Tc` \ new_e3 ->
returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
-------------------------------------------------------------------------
-zonkQuals :: TyVarEnv Type -> IdEnv Id
- -> [TcQual s] -> NF_TcM s ([TypecheckedQual], IdEnv Id)
-
-zonkQuals te ve []
- = returnNF_Tc ([], ve)
-
-zonkQuals te ve (GeneratorQual pat expr : quals)
- = 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
- zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
- returnNF_Tc (GeneratorQual new_pat new_expr : new_quals, final_ve)
-
-zonkQuals te ve (FilterQual expr : quals)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkQuals te ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
- returnNF_Tc (FilterQual new_expr : new_quals, final_ve)
-
-zonkQuals te ve (LetQual binds : quals)
- = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) ->
- zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) ->
- returnNF_Tc (LetQual new_binds : new_quals, final_ve)
-
--------------------------------------------------------------------------
-zonkStmts :: TyVarEnv Type -> IdEnv Id
- -> [TcStmt s] -> NF_TcM s [TypecheckedStmt]
-
-zonkStmts te ve [] = returnNF_Tc []
-
-zonkStmts te ve [ExprStmt expr locn]
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- returnNF_Tc [ExprStmt new_expr locn]
-
-zonkStmts te ve (ExprStmtOut expr locn a b : stmts)
- = zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
- zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
- zonkStmts te ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : 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 ->
+zonkStmts :: [TcStmt]
+ -> NF_TcM [TypecheckedStmt]
+
+zonkStmts [] = returnNF_Tc []
+
+zonkStmts (ParStmtOut bndrstmtss : stmts)
+ = mapNF_Tc (mapNF_Tc zonkId) bndrss `thenNF_Tc` \ new_bndrss ->
+ let new_binders = concat new_bndrss in
+ mapNF_Tc zonkStmts stmtss `thenNF_Tc` \ new_stmtss ->
+ tcExtendGlobalValEnv new_binders $
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+ where (bndrss, stmtss) = unzip bndrstmtss
+
+zonkStmts (ResultStmt expr locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ResultStmt new_expr locn : new_stmts)
+
+zonkStmts (ExprStmt expr ty locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
+
+zonkStmts (LetStmt binds : stmts)
+ = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
+ tcSetEnv new_env $
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
returnNF_Tc (LetStmt new_binds : new_stmts)
-zonkStmts te ve (BindStmtOut pat expr locn a b : stmts)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
- zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
- zonkTcTypeToType te a `thenNF_Tc` \ new_a ->
- zonkTcTypeToType te b `thenNF_Tc` \ new_b ->
- let
- new_ve = extend_ve ve ids
- in
- zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts ->
- returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
+zonkStmts (BindStmt pat expr locn : stmts)
+ = zonkExpr expr `thenNF_Tc` \ new_expr ->
+ zonkPat pat `thenNF_Tc` \ (new_pat, new_ids) ->
+ tcExtendGlobalValEnv (bagToList new_ids) $
+ zonkStmts stmts `thenNF_Tc` \ new_stmts ->
+ returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
-------------------------------------------------------------------------
-zonkRbinds :: TyVarEnv Type -> IdEnv Id
- -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
-zonkRbinds te ve rbinds
+zonkRbinds 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 expr `thenNF_Tc` \ new_expr ->
+ zonkIdOcc field `thenNF_Tc` \ new_field ->
+ returnNF_Tc (new_field, new_expr, pun)
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
+mapIPNameTc f (Dupable n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
+mapIPNameTc f (Linear n) = f n `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
\end{code}
+
%************************************************************************
%* *
\subsection[BackSubst-Pats]{Patterns}
%************************************************************************
\begin{code}
-zonkPat :: TyVarEnv Type -> IdEnv Id
- -> TcPat s -> NF_TcM s (TypecheckedPat, [Id])
+zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
-zonkPat te ve (WildPat ty)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (WildPat new_ty, [])
+zonkPat (WildPat ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (WildPat new_ty, emptyBag)
-zonkPat te ve (VarPat v)
- = zonkIdBndr te v `thenNF_Tc` \ new_v ->
- returnNF_Tc (VarPat new_v, [new_v])
+zonkPat (VarPat v)
+ = zonkIdBndr v `thenNF_Tc` \ new_v ->
+ returnNF_Tc (VarPat new_v, unitBag new_v)
-zonkPat te ve (LazyPat pat)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+zonkPat (LazyPat pat)
+ = zonkPat 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 (AsPat n pat)
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
-zonkPat te ve (TuplePat pats)
- = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) ->
- returnNF_Tc (TuplePat new_pats, ids)
+zonkPat (ListPat ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (ListPat new_ty new_pats, ids)
-zonkPat te ve (RecPat n ty rpats)
- = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty ->
+zonkPat (PArrPat ty pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (PArrPat new_ty new_pats, ids)
+
+zonkPat (TuplePat pats boxed)
+ = zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (TuplePat new_pats boxed, ids)
+
+zonkPat (ConPat n ty tvs dicts pats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
+ zonkPats pats `thenNF_Tc` \ (new_pats, ids) ->
+ returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
+ listToBag new_dicts `unionBags` ids)
+
+zonkPat (RecPat n ty tvs dicts rpats)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ mapNF_Tc zonkTcTyVarToTyVar tvs `thenNF_Tc` \ new_tvs ->
+ mapNF_Tc zonkIdBndr dicts `thenNF_Tc` \ new_dicts ->
+ tcExtendGlobalValEnv new_dicts $
mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) ->
- returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s)
+ returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
+ listToBag new_dicts `unionBags` unionManyBags ids_s)
where
zonk_rpat (f, pat, pun)
- = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) ->
+ = zonkPat 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 (LitPat lit ty)
+ = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ returnNF_Tc (LitPat lit new_ty, emptyBag)
+
+zonkPat (SigPat pat ty expr)
+ = zonkPat pat `thenNF_Tc` \ (new_pat, ids) ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr expr `thenNF_Tc` \ new_expr ->
+ returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
+
+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, emptyBag)
+
+zonkPat (NPlusKPat n k ty e1 e2)
+ = zonkIdBndr n `thenNF_Tc` \ new_n ->
+ zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
+ zonkExpr e1 `thenNF_Tc` \ new_e1 ->
+ zonkExpr e2 `thenNF_Tc` \ new_e2 ->
+ returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
+
+zonkPat (DictPat ds ms)
+ = mapNF_Tc zonkIdBndr ds `thenNF_Tc` \ new_ds ->
+ mapNF_Tc zonkIdBndr ms `thenNF_Tc` \ new_ms ->
+ returnNF_Tc (DictPat new_ds new_ms,
+ listToBag new_ds `unionBags` listToBag new_ms)
+
+
+zonkPats []
+ = returnNF_Tc ([], emptyBag)
+
+zonkPats (pat:pats)
+ = zonkPat pat `thenNF_Tc` \ (pat', ids1) ->
+ zonkPats pats `thenNF_Tc` \ (pats', ids2) ->
+ returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
+\end{code}
-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)
+%************************************************************************
+%* *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%* *
+%************************************************************************
-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)
+\begin{code}
+zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
+zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
+zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
+zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
+ zonkIdOcc i `thenNF_Tc` \ i' ->
+ returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
\end{code}
+\begin{code}
+zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
+zonkRules rs = mapNF_Tc zonkRule rs
+
+zonkRule (HsRule name act vars lhs rhs loc)
+ = mapNF_Tc zonk_bndr vars `thenNF_Tc` \ new_bndrs ->
+ tcExtendGlobalValEnv (filter isId new_bndrs) $
+ -- Type variables don't need an envt
+ -- They are bound through the mutable mechanism
+ zonkExpr lhs `thenNF_Tc` \ new_lhs ->
+ zonkExpr rhs `thenNF_Tc` \ new_rhs ->
+ returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
+ -- I hate this map RuleBndr stuff
+ where
+ zonk_bndr (RuleBndr v)
+ | isId v = zonkIdBndr v
+ | otherwise = zonkTcTyVarToTyVar v
+
+zonkRule (IfaceRuleOut fun rule)
+ = zonkIdOcc fun `thenNF_Tc` \ fun' ->
+ returnNF_Tc (IfaceRuleOut fun' rule)
+\end{code}
projects / ghc-hetmet.git / blobdiff