[project @ 2003-03-27 08:18:21 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 00eb754..24dc515 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998

 %
 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
 
 %
 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
 

@@ -7,59 +7,74 @@ This module is an extension of @HsSyn@ syntax, for use in the type
 checker.
 
 \begin{code}
 checker.
 
 \begin{code}

-#include "HsVersions.h"
-

 module TcHsSyn (
 module TcHsSyn (

-       SYN_IE(TcIdBndr), TcIdOcc(..),
+       TcMonoBinds, TcHsBinds, TcPat,
+       TcExpr, TcGRHSs, TcGRHS, TcMatch,
+       TcStmt, TcArithSeqInfo, TcRecordBinds,
+       TcHsModule, TcDictBinds,
+       TcForeignDecl,

        
        

-       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(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
-       SYN_IE(TcHsModule),
-       
-       SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
-       SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
-       SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
-       SYN_IE(TypecheckedQual), SYN_IE(TypecheckedStmt),
-       SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
-       SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
-       SYN_IE(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,
+       hsLitType, hsPatType, 
+
+       -- Coercions
+       Coercion, ExprCoFn, PatCoFn, 
+       (<$>), (<.>), mkCoercion, 
+       idCoercion, isIdCoercion,
+
+       -- re-exported from TcMonad
+       TcId, TcIdSet,
+
+       zonkTopBinds, zonkTopDecls, zonkTopExpr,
+       zonkId, zonkTopBndrs

   ) where
 
   ) where
 

-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"

 
 -- friends:
 import HsSyn   -- oodles of it
 
 -- friends:
 import HsSyn   -- oodles of it

-import Id      ( GenId(..), IdDetails, -- Can meddle modestly with Ids
-                 SYN_IE(DictVar), idType,
-                 SYN_IE(IdEnv), growIdEnvList, lookupIdEnv
-               )

 
 -- others:
 
 -- others:

-import Name    ( Name{--O only-} )
-import TcMonad hiding ( rnMtoTcM )
-import TcType  ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
-                 zonkTcTypeToType, zonkTcTyVarToTyVar
-               )
-import Usage   ( SYN_IE(UVar) )
-import Util    ( zipEqual, panic, pprPanic, pprTrace )
-
-import PprType  ( GenType, GenTyVar )  -- instances
-import Type    ( mkTyVarTy, tyVarsOfType )
-import TyVar   ( GenTyVar {- instances -},
-                 SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
-import TysPrim ( voidTy )
-import Unique  ( Unique )              -- instances
-import UniqFM
-import PprStyle
-import Pretty
+import Id      ( idType, setIdType, Id )
+import DataCon ( dataConWrapId )       
+
+import TcRnMonad
+import Type      ( Type )
+import TcType    ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
+                   tcGetTyVar, isAnyTypeKind, mkTyConApp )
+import qualified  Type
+import TcMType   ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
+                   putTcTyVar )
+import TysPrim   ( charPrimTy, intPrimTy, floatPrimTy,
+                   doublePrimTy, addrPrimTy
+                 )
+import TysWiredIn ( charTy, stringTy, intTy, integerTy,
+                   mkListTy, mkPArrTy, mkTupleTy, unitTy,
+                   voidTy, listTyCon, tupleTyCon )
+import TyCon     ( mkPrimTyCon, tyConKind )
+import PrimRep   ( PrimRep(VoidRep) )
+import CoreSyn    ( CoreExpr )
+import Name      ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
+import Var       ( isId, isLocalVar, tyVarKind )
+import VarSet
+import VarEnv
+import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
+import Maybes    ( orElse )
+import Maybe     ( isNothing )
+import Unique    ( Uniquable(..) )
+import SrcLoc    ( noSrcLoc )
+import Bag
+import Outputable

 \end{code}
 
 
 \end{code}
 
 

@@ -74,37 +89,39 @@ At the end of type checking we zonk everything to @Typechecked...@ datatypes,
 which have immutable type variables in them.
 
 \begin{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
+type TcMonoBinds       = MonoBinds     TcId 
+type TcDictBinds       = TcMonoBinds 
+type TcPat             = OutPat        TcId
+type TcExpr            = HsExpr        TcId 
+type TcGRHSs           = GRHSs         TcId
+type TcGRHS            = GRHS          TcId
+type TcMatch           = Match         TcId
+type TcStmt            = Stmt          TcId
+type TcArithSeqInfo    = ArithSeqInfo  TcId
+type TcRecordBinds     = HsRecordBinds TcId
+type TcHsModule                = HsModule      TcId
+type TcForeignDecl      = ForeignDecl  TcId
+type TcRuleDecl        = RuleDecl     TcId
+
+type TypecheckedPat            = OutPat        Id
+type TypecheckedMonoBinds      = MonoBinds     Id
+type TypecheckedDictBinds      = TypecheckedMonoBinds
+type TypecheckedHsBinds                = HsBinds       Id
+type TypecheckedHsExpr         = HsExpr        Id
+type TypecheckedArithSeqInfo   = ArithSeqInfo  Id
+type TypecheckedStmt           = Stmt          Id
+type TypecheckedMatch          = Match         Id
+type TypecheckedGRHSs          = GRHSs         Id
+type TypecheckedGRHS           = GRHS          Id
+type TypecheckedRecordBinds    = HsRecordBinds Id
+type TypecheckedHsModule       = HsModule      Id
+type TypecheckedForeignDecl     = ForeignDecl   Id
+type TypecheckedRuleDecl       = RuleDecl      Id
+type TypecheckedCoreBind        = (Id, CoreExpr)
+
+type TypecheckedMatchContext   = HsMatchContext Name   -- Keeps consistency with 
+                                                       -- HsDo arg StmtContext

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -120,27 +137,88 @@ mkHsTyLam tyvars expr = TyLam tyvars expr
 mkHsDictLam []    expr = expr
 mkHsDictLam dicts expr = DictLam dicts expr
 
 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}
+

 
 

-tcIdTyVars (TcId id)  = tyVarsOfType (idType id)
-tcIdTyVars (RealId _) = emptyTyVarSet          -- Top level Ids have no free type variables
+%************************************************************************
+%*                                                                     *
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+%*                                                                     *
+%************************************************************************
+
+Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
+then something is wrong.
+\begin{code}
+hsPatType :: TypecheckedPat -> Type
+
+hsPatType (ParPat pat)           = hsPatType pat
+hsPatType (WildPat ty)           = ty
+hsPatType (VarPat var)           = idType var
+hsPatType (LazyPat pat)                  = hsPatType pat
+hsPatType (LitPat lit)           = hsLitType lit
+hsPatType (AsPat var pat)        = idType var
+hsPatType (ListPat _ ty)         = mkListTy ty
+hsPatType (PArrPat _ ty)         = mkPArrTy ty
+hsPatType (TuplePat pats box)    = mkTupleTy box (length pats) (map hsPatType pats)
+hsPatType (ConPatOut _ _ ty _ _)  = ty
+hsPatType (SigPatOut _ ty _)     = ty
+hsPatType (NPatOut lit ty _)     = ty
+hsPatType (NPlusKPatOut id _ _ _) = idType id
+hsPatType (DictPat ds ms)         = case (ds ++ ms) of
+                                      []  -> unitTy
+                                      [d] -> idType d
+                                      ds  -> mkTupleTy Boxed (length ds) (map idType ds)
+
+
+hsLitType :: HsLit -> TcType
+hsLitType (HsChar c)       = charTy
+hsLitType (HsCharPrim c)   = charPrimTy
+hsLitType (HsString str)   = stringTy
+hsLitType (HsStringPrim s) = addrPrimTy
+hsLitType (HsInt i)       = intTy
+hsLitType (HsIntPrim i)    = intPrimTy
+hsLitType (HsInteger i)    = integerTy
+hsLitType (HsRat _ ty)    = ty
+hsLitType (HsFloatPrim f)  = floatPrimTy
+hsLitType (HsDoublePrim d) = doublePrimTy
+hsLitType (HsLitLit _ ty)  = ty

 \end{code}
 
 \end{code}
 

+%************************************************************************
+%*                                                                     *
+\subsection{Coercion functions}
+%*                                                                     *
+%************************************************************************
+

 \begin{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
-  ppr sty (RealId id) = ppr sty id
-
-instance NamedThing (TcIdOcc s) where
-  getName (TcId id)   = getName id
-  getName (RealId id) = getName id
+type Coercion a = Maybe (a -> a)
+       -- Nothing => identity fn
+
+type ExprCoFn = Coercion TypecheckedHsExpr
+type PatCoFn  = Coercion TcPat
+
+(<.>) :: Coercion a -> Coercion a -> Coercion a        -- Composition
+Nothing <.> Nothing = Nothing
+Nothing <.> Just f  = Just f
+Just f  <.> Nothing = Just f
+Just f1 <.> Just f2 = Just (f1 . f2)
+
+(<$>) :: Coercion a -> a -> a
+Just f  <$> e = f e
+Nothing <$> e = e
+
+mkCoercion :: (a -> a) -> Coercion a
+mkCoercion f = Just f
+
+idCoercion :: Coercion a
+idCoercion = Nothing
+
+isIdCoercion :: Coercion a -> Bool
+isIdCoercion = isNothing

 \end{code}
 
 
 \end{code}
 
 

@@ -150,192 +228,235 @@ instance NamedThing (TcIdOcc s) where
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-This zonking pass runs over the bindings
+\begin{code}
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+  = zonkTcType (idType id) `thenM` \ ty' ->
+    returnM (setIdType id ty')
+\end{code}
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings

 
  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
  b) convert unbound TcTyVar to Void
 
  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
+
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.

 
 

-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 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.
 
 
 It's all pretty boring stuff, because HsSyn is such a large type, and 
 the environment manipulation is tiresome.
 

-

 \begin{code}
 \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]
+data ZonkEnv = ZonkEnv (TcType -> TcM Type)    -- How to zonk a type
+                       (IdEnv Id)              -- What variables are in scope
+       -- Maps an Id to its zonked version; both have the same Name
+       -- Is only consulted lazily; hence knot-tying
+
+emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
+
+extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
+extendZonkEnv (ZonkEnv zonk_ty env) ids 
+  = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
+
+setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
+setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
+
+mkZonkEnv :: [Id] -> ZonkEnv
+mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
+
+zonkIdOcc :: ZonkEnv -> TcId -> Id
+-- Ids defined in this module should be in the envt; 
+-- ignore others.  (Actually, data constructors are also
+-- not LocalVars, even when locally defined, but that is fine.)
+--
+-- Actually, Template Haskell works in 'chunks' of declarations, and
+-- an earlier chunk won't be in the 'env' that the zonking phase 
+-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
+-- zonked.  There's no point in looking it up there (except for error 
+-- checking), and it's not conveniently to hand; hence the simple
+-- 'orElse' case in the LocalVar branch.
+--
+-- Even without template splices, in module Main, the checking of
+-- 'main' is done as a separte chunk.
+zonkIdOcc (ZonkEnv zonk_ty env) id 
+  | isLocalVar id = lookupVarEnv env id `orElse` id
+  | otherwise    = id
+
+zonkIdOccs env ids = map (zonkIdOcc env) ids
+
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form.  The TyVarEnv give 
+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
+zonkIdBndr env id
+  = zonkTcTypeToType env (idType id)   `thenM` \ ty' ->
+    returnM (setIdType id ty')
+
+zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
+zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
+
+zonkTopBndrs :: [TcId] -> TcM [Id]
+zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids

 \end{code}
 
 \end{code}
 

+

 \begin{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)
+zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
+zonkTopExpr e = zonkExpr emptyZonkEnv e
+
+zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
+            -> TcM ([Id], 
+                       TypecheckedMonoBinds, 
+                       [TypecheckedForeignDecl],
+                       [TypecheckedRuleDecl])
+zonkTopDecls binds rules fords -- Top level is implicitly recursive
+  = fixM (\ ~(new_ids, _, _, _) ->
+       let
+          zonk_env = mkZonkEnv new_ids
+       in
+       zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
+       zonkRules zonk_env rules                `thenM` \ rules' ->
+       zonkForeignExports zonk_env fords       `thenM` \ fords' ->
+       
+       returnM (bagToList new_ids, binds', fords', rules')

     )
 
     )
 

-       -- The ..Local version assumes the caller has set up
-       -- a ve that contains all the things bound here
-zonkDictBindsLocal te ve [] = returnNF_Tc ([], [])
+zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
+zonkTopBinds binds
+  = fixM (\ ~(new_ids, _) ->
+       let
+          zonk_env = mkZonkEnv new_ids
+       in
+       zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
+       returnM (bagToList new_ids, binds')
+    )

 
 

-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}
+---------------------------------------------
+zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
+zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
+
+zonkBinds env (ThenBinds b1 b2)
+  = zonkBinds env b1   `thenM` \ (env1, b1') -> 
+    zonkBinds env1 b2  `thenM` \ (env2, b2') -> 
+    returnM (env2, b1' `ThenBinds` b2')
+
+zonkBinds env (MonoBind bind sigs is_rec)
+  = ASSERT( null sigs )
+    fixM (\ ~(_, _, new_ids) ->
+       let 
+          env1 = extendZonkEnv env (bagToList new_ids)
+       in
+       zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
+       returnM (env1, new_bind, new_ids)
+    )                          `thenM` \ (env1, new_bind, _) ->
+   returnM (env1, mkMonoBind is_rec new_bind)
+
+zonkBinds env (IPBinds binds is_with)
+  = mappM zonk_ip_bind binds   `thenM` \ new_binds ->
+    let
+       env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
+    in
+    returnM (env1, IPBinds new_binds is_with)
+  where
+    zonk_ip_bind (n, e)
+       = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
+         zonkExpr env e                        `thenM` \ e' ->
+         returnM (n', e')

 
 

-\begin{code}
-zonkBinds :: TyVarEnv Type -> IdEnv Id 
-         -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id)

 
 

-zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve)
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> TcMonoBinds
+             -> TcM (TypecheckedMonoBinds, Bag Id)

 
 

-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 env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)

 
 

-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 env (AndMonoBinds mbinds1 mbinds2)
+  = zonkMonoBinds env mbinds1          `thenM` \ (b1', ids1) ->
+    zonkMonoBinds env mbinds2          `thenM` \ (b2', ids2) ->
+    returnM (b1' `AndMonoBinds` b2', 
+            ids1 `unionBags` ids2)

 
 

-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}
+zonkMonoBinds env (PatMonoBind pat grhss locn)
+  = zonkPat env pat    `thenM` \ (new_pat, ids) ->
+    zonkGRHSs env grhss        `thenM` \ new_grhss ->
+    returnM (PatMonoBind new_pat new_grhss locn, ids)

 
 

-\begin{code}
--------------------------------------------------------------------------
-zonkBind :: TyVarEnv Type -> IdEnv Id 
-        -> TcBind s -> NF_TcM s (TypecheckedBind, [Id])
+zonkMonoBinds env (VarMonoBind var expr)
+  = zonkIdBndr env var         `thenM` \ new_var ->
+    zonkExpr env expr  `thenM` \ new_expr ->
+    returnM (VarMonoBind new_var new_expr, unitBag new_var)

 
 

-zonkBind te ve EmptyBind = returnNF_Tc (EmptyBind, [])
+zonkMonoBinds env (FunMonoBind var inf ms locn)
+  = zonkIdBndr env var                 `thenM` \ new_var ->
+    mappM (zonkMatch env) ms           `thenM` \ new_ms ->
+    returnM (FunMonoBind new_var inf new_ms locn, 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)

 
 

-zonkBind te ve (RecBind mbinds)
-  = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) ->
-    returnNF_Tc (RecBind new_mbinds, new_ids)
+zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
+  = mappM zonkTcTyVarToTyVar tyvars    `thenM` \ new_tyvars ->
+       -- No need to extend tyvar env: the effects are
+       -- propagated through binding the tyvars themselves

 
 

--------------------------------------------------------------------------
-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])
+    zonkIdBndrs env dicts              `thenM` \ new_dicts ->
+    fixM (\ ~(_, _, val_bind_ids) ->
+       let
+         env1 = extendZonkEnv (extendZonkEnv env new_dicts)
+                              (bagToList val_bind_ids)
+       in
+       zonkMonoBinds env1 val_bind             `thenM` \ (new_val_bind, val_bind_ids) ->
+        mappM (zonkExport env1) exports        `thenM` \ new_exports ->
+       returnM (new_val_bind, new_exports, val_bind_ids)
+    )                                          `thenM ` \ (new_val_bind, new_exports, _) ->
+    let
+       new_globals = listToBag [global | (_, global, local) <- new_exports]
+    in
+    returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
+                new_globals)
+  where
+    zonkExport env (tyvars, global, local)
+       = zonkTcTyVars tyvars           `thenM` \ 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 env global         `thenM` \ new_global ->
+         returnM (new_tyvars, new_global, zonkIdOcc env local)

 \end{code}
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 %************************************************************************
 %*                                                                     *

-\subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}

 %*                                                                     *
 %************************************************************************
 
 \begin{code}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}

-zonkMatch :: TyVarEnv Type -> IdEnv Id 
-         -> TcMatch s -> NF_TcM s TypecheckedMatch
+zonkMatch :: ZonkEnv -> TcMatch -> TcM 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 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 env (Match pats _ grhss)
+  = zonkPats env pats                                          `thenM` \ (new_pats, new_ids) ->
+    zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss    `thenM` \ new_grhss ->
+    returnM (Match new_pats Nothing new_grhss)

 
 -------------------------------------------------------------------------
 
 -------------------------------------------------------------------------

-zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id 
-                 -> TcGRHSsAndBinds s
-                 -> NF_TcM s TypecheckedGRHSsAndBinds
+zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs

 
 

-zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
-  = zonkBinds te ve binds              `thenNF_Tc` \ (new_binds, new_ve) ->
+zonkGRHSs env (GRHSs grhss binds ty)
+  = zonkBinds env binds        `thenM` \ (new_env, new_binds) ->

     let
     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 new_env guarded  `thenM` \ new_guarded ->
+           returnM (GRHS new_guarded locn)

     in
     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)
+    mappM zonk_grhs grhss      `thenM` \ new_grhss ->
+    zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    returnM (GRHSs new_grhss new_binds new_ty)

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -345,261 +466,281 @@ zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-zonkExpr :: TyVarEnv Type -> IdEnv Id 
-        -> 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 ve (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 ->
-    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 ->
-    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 te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
-zonkExpr te ve (HsPar _)    = panic "zonkExpr te ve:HsPar"
-
-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 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 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 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 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 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
+zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
+zonkExpr  :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr

 
 

-zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig"
-zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn"
+zonkExprs env exprs = mappM (zonkExpr env) exprs

 
 

-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 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 env (HsVar id)
+  = returnM (HsVar (zonkIdOcc env id))

 
 

-zonkExpr te ve (HsSCC label expr)
-  = zonkExpr te ve expr        `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsSCC label new_expr)
+zonkExpr env (HsIPVar id)
+  = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))

 
 

-zonkExpr te ve (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 ->
-    returnNF_Tc (TyLam new_tyvars new_expr)
+zonkExpr env (HsLit (HsRat f ty))
+  = zonkTcTypeToType env ty       `thenM` \ new_ty  ->
+    returnM (HsLit (HsRat f new_ty))

 
 

-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 env (HsLit (HsLitLit lit ty))
+  = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
+    returnM (HsLit (HsLitLit lit new_ty))

 
 

-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 env (HsLit lit)
+  = returnM (HsLit lit)

 
 

-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
+-- HsOverLit doesn't appear in typechecker output

 
 

-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 env (HsLam match)
+  = zonkMatch env match        `thenM` \ new_match ->
+    returnM (HsLam new_match)

 
 

-zonkExpr te ve (Dictionary dicts methods)
-  = returnNF_Tc (Dictionary new_dicts new_methods)
+zonkExpr env (HsApp e1 e2)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    returnM (HsApp new_e1 new_e2)
+
+zonkExpr env (HsBracketOut body bs) 
+  = mappM zonk_b bs    `thenM` \ bs' ->
+    returnM (HsBracketOut body bs')

   where
   where

-    new_dicts   = map (zonkIdOcc ve) dicts
-    new_methods = map (zonkIdOcc ve) methods
+    zonk_b (n,e) = zonkExpr env e      `thenM` \ e' ->
+                  returnM (n,e')
+
+zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
+                                               -- level things can be reified (for now)
+zonkExpr env (HsSplice n e loc) = WARN( True, ppr e )  -- Should not happen
+                                 returnM (HsSplice n e loc)
+
+zonkExpr env (OpApp e1 op fixity e2)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env op    `thenM` \ new_op ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    returnM (OpApp new_e1 new_op fixity new_e2)
+
+zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
+
+zonkExpr env (HsPar e)    
+  = zonkExpr env e     `thenM` \new_e ->
+    returnM (HsPar new_e)
+
+zonkExpr env (SectionL expr op)
+  = zonkExpr env expr  `thenM` \ new_expr ->
+    zonkExpr env op            `thenM` \ new_op ->
+    returnM (SectionL new_expr new_op)
+
+zonkExpr env (SectionR op expr)
+  = zonkExpr env op            `thenM` \ new_op ->
+    zonkExpr env expr          `thenM` \ new_expr ->
+    returnM (SectionR new_op new_expr)
+
+zonkExpr env (HsCase expr ms src_loc)
+  = zonkExpr env expr          `thenM` \ new_expr ->
+    mappM (zonkMatch env) ms   `thenM` \ new_ms ->
+    returnM (HsCase new_expr new_ms src_loc)
+
+zonkExpr env (HsIf e1 e2 e3 src_loc)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    zonkExpr env e3    `thenM` \ new_e3 ->
+    returnM (HsIf new_e1 new_e2 new_e3 src_loc)
+
+zonkExpr env (HsLet binds expr)
+  = zonkBinds env binds                `thenM` \ (new_env, new_binds) ->
+    zonkExpr new_env expr      `thenM` \ new_expr ->
+    returnM (HsLet new_binds new_expr)
+
+zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
+  = zonkStmts env stmts        `thenM` \ new_stmts ->
+    zonkTcTypeToType env ty    `thenM` \ new_ty   ->
+    returnM (HsDo do_or_lc new_stmts 
+                     (zonkIdOccs env ids) 
+                     new_ty src_loc)
+
+zonkExpr env (ExplicitList ty exprs)
+  = zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonkExprs env exprs                `thenM` \ new_exprs ->
+    returnM (ExplicitList new_ty new_exprs)
+
+zonkExpr env (ExplicitPArr ty exprs)
+  = zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonkExprs env exprs                `thenM` \ new_exprs ->
+    returnM (ExplicitPArr new_ty new_exprs)
+
+zonkExpr env (ExplicitTuple exprs boxed)
+  = zonkExprs env exprs        `thenM` \ new_exprs ->
+    returnM (ExplicitTuple new_exprs boxed)
+
+zonkExpr env (RecordConOut data_con con_expr rbinds)
+  = zonkExpr env con_expr      `thenM` \ new_con_expr ->
+    zonkRbinds env rbinds      `thenM` \ new_rbinds ->
+    returnM (RecordConOut data_con new_con_expr new_rbinds)
+
+zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
+
+zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
+  = zonkExpr env expr          `thenM` \ new_expr ->
+    zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
+    zonkTcTypeToType env out_ty        `thenM` \ new_out_ty ->
+    zonkRbinds env rbinds      `thenM` \ new_rbinds ->
+    returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
+
+zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
+zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
+zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
+
+zonkExpr env (ArithSeqOut expr info)
+  = zonkExpr env expr          `thenM` \ new_expr ->
+    zonkArithSeq env info      `thenM` \ new_info ->
+    returnM (ArithSeqOut new_expr new_info)
+
+zonkExpr env (PArrSeqOut expr info)
+  = zonkExpr env expr          `thenM` \ new_expr ->
+    zonkArithSeq env info      `thenM` \ new_info ->
+    returnM (PArrSeqOut new_expr new_info)
+
+zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
+  = zonkExprs env args                 `thenM` \ new_args ->
+    zonkTcTypeToType env result_ty     `thenM` \ new_result_ty ->
+    returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
+
+zonkExpr env (HsSCC lbl expr)
+  = zonkExpr env expr  `thenM` \ new_expr ->
+    returnM (HsSCC lbl new_expr)
+
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn lbl expr)
+  = zonkExpr env expr   `thenM` \ new_expr ->
+    returnM (HsCoreAnn lbl new_expr)
+
+zonkExpr env (TyLam tyvars expr)
+  = mappM zonkTcTyVarToTyVar tyvars    `thenM` \ new_tyvars ->
+       -- No need to extend tyvar env; see AbsBinds
+
+    zonkExpr env expr                  `thenM` \ new_expr ->
+    returnM (TyLam new_tyvars new_expr)
+
+zonkExpr env (TyApp expr tys)
+  = zonkExpr env expr                  `thenM` \ new_expr ->
+    mappM (zonkTcTypeToType env) tys   `thenM` \ new_tys ->
+    returnM (TyApp new_expr new_tys)
+
+zonkExpr env (DictLam dicts expr)
+  = zonkIdBndrs env dicts      `thenM` \ new_dicts ->
+    let
+       env1 = extendZonkEnv env new_dicts
+    in
+    zonkExpr env1 expr         `thenM` \ new_expr ->
+    returnM (DictLam new_dicts new_expr)
+
+zonkExpr env (DictApp expr dicts)
+  = zonkExpr env expr                  `thenM` \ new_expr ->
+    returnM (DictApp new_expr (zonkIdOccs env dicts))

 
 

-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 :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
+
+zonkArithSeq env (From e)
+  = zonkExpr env e             `thenM` \ new_e ->
+    returnM (From new_e)

 
 

-zonkArithSeq te ve (From e)
-  = zonkExpr te ve e           `thenNF_Tc` \ new_e ->
-    returnNF_Tc (From new_e)
+zonkArithSeq env (FromThen e1 e2)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    returnM (FromThen new_e1 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 env (FromTo e1 e2)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    returnM (FromTo 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 ->
-    returnNF_Tc (FromTo new_e1 new_e2)
+zonkArithSeq env (FromThenTo e1 e2 e3)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    zonkExpr env e3    `thenM` \ new_e3 ->
+    returnM (FromThenTo new_e1 new_e2 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 :: TyVarEnv Type -> IdEnv Id 
-         -> [TcQual s] -> NF_TcM s ([TypecheckedQual], IdEnv Id)
+zonkStmts  :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]

 
 

-zonkQuals te ve [] 
-  = returnNF_Tc ([], ve)
+zonkStmts env stmts = zonk_stmts env stmts     `thenM` \ (_, stmts) ->
+                     returnM stmts

 
 

-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)
+zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])

 
 

-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)
+zonk_stmts env [] = returnM (env, [])

 
 

-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)
+zonk_stmts env (ParStmtOut bndrstmtss : stmts)
+  = mappM (mappM zonkId) bndrss                `thenM` \ new_bndrss ->
+    mappM (zonkStmts env) stmtss       `thenM` \ new_stmtss ->
+    let 
+       new_binders = concat new_bndrss
+       env1 = extendZonkEnv env new_binders
+    in
+    zonk_stmts env1 stmts              `thenM` \ (env2, new_stmts) ->
+    returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+  where
+    (bndrss, stmtss) = unzip bndrstmtss

 
 

--------------------------------------------------------------------------
-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 ->
-    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     ->
+zonk_stmts env (RecStmt vs segStmts rets : stmts)
+  = mappM zonkId vs            `thenM` \ new_vs ->
+    let
+       env1 = extendZonkEnv env new_vs
+    in
+    zonk_stmts env1 segStmts   `thenM` \ (env2, new_segStmts) ->
+       -- Zonk the ret-expressions in an envt that 
+       -- has the polymorphic bindings in the envt
+    zonkExprs env2 rets                `thenM` \ new_rets ->
+    zonk_stmts env1 stmts      `thenM` \ (env3, new_stmts) ->
+    returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
+
+zonk_stmts env (ResultStmt expr locn : stmts)
+  = ASSERT( null stmts )
+    zonkExpr env expr  `thenM` \ new_expr ->
+    returnM (env, [ResultStmt new_expr locn])
+
+zonk_stmts env (ExprStmt expr ty locn : stmts)
+  = zonkExpr env expr          `thenM` \ new_expr ->
+    zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonk_stmts env stmts       `thenM` \ (env1, new_stmts) ->
+    returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
+
+zonk_stmts env (LetStmt binds : stmts)
+  = zonkBinds env binds                `thenM` \ (env1, new_binds) ->
+    zonk_stmts env1 stmts      `thenM` \ (env2, new_stmts) ->
+    returnM (env2, LetStmt new_binds : new_stmts)
+
+zonk_stmts env (BindStmt pat expr locn : stmts)
+  = zonkExpr env expr                  `thenM` \ new_expr ->
+    zonkPat env pat                    `thenM` \ (new_pat, new_ids) ->

     let
     let

-       new_ve = extend_ve ve ids
+       env1 = extendZonkEnv env (bagToList new_ids)

     in
     in

-    zonkStmts te new_ve stmts  `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts)
+    zonk_stmts env1 stmts              `thenM` \ (env2, new_stmts) ->
+    returnM (env2, BindStmt new_pat new_expr locn : new_stmts)

 
 
 
 -------------------------------------------------------------------------
 
 
 
 -------------------------------------------------------------------------

-zonkRbinds :: TyVarEnv Type -> IdEnv Id 
-          -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds

 
 

-zonkRbinds te ve rbinds
-  = mapNF_Tc zonk_rbind rbinds
+zonkRbinds env rbinds
+  = mappM zonk_rbind rbinds

   where
   where

-    zonk_rbind (field, expr, pun)
-      = zonkExpr te ve expr    `thenNF_Tc` \ new_expr ->
-       returnNF_Tc (zonkIdOcc ve field, new_expr, pun)
+    zonk_rbind (field, expr)
+      = zonkExpr env expr      `thenM` \ new_expr ->
+       returnM (zonkIdOcc env field, new_expr)
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
+mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
+mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)

 \end{code}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-Pats]{Patterns}
 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-Pats]{Patterns}

@@ -607,77 +748,259 @@ zonkRbinds te ve rbinds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-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)
+zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
+
+zonkPat env (ParPat p)
+  = zonkPat env p      `thenM` \ (new_p, ids) ->
+    returnM (ParPat new_p, ids)
+
+zonkPat env (WildPat ty)
+  = zonkTcTypeToType env ty   `thenM` \ new_ty ->
+    returnM (WildPat new_ty, emptyBag)
+
+zonkPat env (VarPat v)
+  = zonkIdBndr env v       `thenM` \ new_v ->
+    returnM (VarPat new_v, unitBag new_v)
+
+zonkPat env (LazyPat pat)
+  = zonkPat env pat        `thenM` \ (new_pat, ids) ->
+    returnM (LazyPat new_pat, ids)
+
+zonkPat env (AsPat n pat)
+  = zonkIdBndr env n       `thenM` \ new_n ->
+    zonkPat env pat        `thenM` \ (new_pat, ids) ->
+    returnM (AsPat new_n new_pat, new_n `consBag` ids)
+
+zonkPat env (ListPat pats ty)
+  = zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonkPats env pats          `thenM` \ (new_pats, ids) ->
+    returnM (ListPat new_pats new_ty, ids)
+
+zonkPat env (PArrPat pats ty)
+  = zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonkPats env pats          `thenM` \ (new_pats, ids) ->
+    returnM (PArrPat new_pats new_ty, ids)
+
+zonkPat env (TuplePat pats boxed)
+  = zonkPats env pats                  `thenM` \ (new_pats, ids) ->
+    returnM (TuplePat new_pats boxed, ids)
+
+zonkPat env (ConPatOut n stuff ty tvs dicts)
+  = zonkTcTypeToType env ty            `thenM` \ new_ty ->
+    mappM zonkTcTyVarToTyVar tvs       `thenM` \ new_tvs ->
+    zonkIdBndrs env dicts              `thenM` \ new_dicts ->
+    let
+       env1 = extendZonkEnv env new_dicts
+    in
+    zonkConStuff env stuff             `thenM` \ (new_stuff, ids) ->
+    returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, 
+                listToBag new_dicts `unionBags` ids)
+
+zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
+
+zonkPat env (SigPatOut pat ty expr)
+  = zonkPat env pat            `thenM` \ (new_pat, ids) ->
+    zonkTcTypeToType env ty    `thenM` \ new_ty  ->
+    zonkExpr env expr          `thenM` \ new_expr ->
+    returnM (SigPatOut new_pat new_ty new_expr, ids)
+
+zonkPat env (NPatOut lit ty expr)
+  = zonkTcTypeToType env ty    `thenM` \ new_ty   ->
+    zonkExpr env expr          `thenM` \ new_expr ->
+    returnM (NPatOut lit new_ty new_expr, emptyBag)
+
+zonkPat env (NPlusKPatOut n k e1 e2)
+  = zonkIdBndr env n           `thenM` \ new_n ->
+    zonkExpr env e1                    `thenM` \ new_e1 ->
+    zonkExpr env e2                    `thenM` \ new_e2 ->
+    returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
+
+zonkPat env (DictPat ds ms)
+  = zonkIdBndrs env ds      `thenM` \ new_ds ->
+    zonkIdBndrs env ms     `thenM` \ new_ms ->
+    returnM (DictPat new_ds new_ms,
+                listToBag new_ds `unionBags` listToBag new_ms)
+
+---------------------------
+zonkConStuff env (PrefixCon pats)
+  = zonkPats env pats          `thenM` \ (new_pats, ids) ->
+    returnM (PrefixCon new_pats, ids)
+
+zonkConStuff env (InfixCon p1 p2)
+  = zonkPat env p1             `thenM` \ (new_p1, ids1) ->
+    zonkPat env p2             `thenM` \ (new_p2, ids2) ->
+    returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
+
+zonkConStuff env (RecCon rpats)
+  = mapAndUnzipM zonk_rpat rpats       `thenM` \ (new_rpats, ids_s) ->
+    returnM (RecCon new_rpats, unionManyBags ids_s)

   where
   where

-    zonk_rpat (f, pat, pun)
-      = zonkPat te ve pat           `thenNF_Tc` \ (new_pat, ids) ->
-       returnNF_Tc ((f, new_pat, pun), ids)
+    zonk_rpat (f, pat)
+      = zonkPat env pat                `thenM` \ (new_pat, ids) ->
+       returnM ((f, new_pat), ids)
+
+---------------------------
+zonkPats env []
+  = returnM ([], emptyBag)
+
+zonkPats env (pat:pats) 
+  = zonkPat env pat    `thenM` \ (pat',  ids1) ->
+    zonkPats env pats  `thenM` \ (pats', ids2) ->
+    returnM (pat':pats', ids1 `unionBags` ids2)
+\end{code}

 
 

-zonkPat te ve (LitPat lit ty)
-  = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
-    returnNF_Tc (LitPat lit new_ty, [])
+%************************************************************************
+%*                                                                     *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%*                                                                     *
+%************************************************************************

 
 

-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 (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)
+\begin{code}
+zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
+zonkForeignExports env ls = mappM (zonkForeignExport env) ls
+
+zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
+zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
+   returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
+zonkForeignExport env for_imp 
+  = returnM for_imp    -- Foreign imports don't need zonking
+\end{code}
+
+\begin{code}
+zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
+zonkRules env rs = mappM (zonkRule env) rs

 
 

+zonkRule env (HsRule name act vars lhs rhs loc)
+  = mappM zonk_bndr vars               `thenM` \ new_bndrs ->
+    newMutVar emptyVarSet              `thenM` \ unbound_tv_set ->
+    let
+       env_rhs = extendZonkEnv env (filter isId new_bndrs)
+       -- Type variables don't need an envt
+       -- They are bound through the mutable mechanism
+
+       env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
+       -- We need to gather the type variables mentioned on the LHS so we can 
+       -- quantify over them.  Example:
+       --   data T a = C
+       -- 
+       --   foo :: T a -> Int
+       --   foo C = 1
+       --
+       --   {-# RULES "myrule"  foo C = 1 #-}
+       -- 
+       -- After type checking the LHS becomes (foo a (C a))
+       -- and we do not want to zap the unbound tyvar 'a' to (), because
+       -- that limits the applicability of the rule.  Instead, we
+       -- want to quantify over it!  
+       --
+       -- It's easiest to find the free tyvars here. Attempts to do so earlier
+       -- are tiresome, because (a) the data type is big and (b) finding the 
+       -- free type vars of an expression is necessarily monadic operation.
+       --      (consider /\a -> f @ b, where b is side-effected to a)
+    in
+    zonkExpr env_lhs lhs               `thenM` \ new_lhs ->
+    zonkExpr env_rhs rhs               `thenM` \ new_rhs ->

 
 

-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)
+    readMutVar unbound_tv_set          `thenM` \ unbound_tvs ->
+    let
+       final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
+       -- I hate this map RuleBndr stuff
+    in
+    returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
+  where
+   zonk_bndr (RuleBndr v) 
+       | isId v    = zonkIdBndr env v
+       | otherwise = zonkTcTyVarToTyVar v

 
 

+zonkRule env (IfaceRuleOut fun rule)
+  = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)

 \end{code}
 
 
 \end{code}
 
 

+%************************************************************************
+%*                                                                     *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
+
+zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
+-- This variant collects unbound type variables in a mutable variable
+zonkTypeCollecting unbound_tv_set
+  = zonkType zonk_unbound_tyvar
+  where
+    zonk_unbound_tyvar tv 
+       = zonkTcTyVarToTyVar tv                                 `thenM` \ tv' ->
+         readMutVar unbound_tv_set                             `thenM` \ tv_set ->
+         writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
+         return (mkTyVarTy tv')
+
+zonkTypeZapping :: TcType -> TcM Type
+-- This variant is used for everything except the LHS of rules
+-- It zaps unbound type variables to (), or some other arbitrary type
+zonkTypeZapping ty 
+  = zonkType zonk_unbound_tyvar ty
+  where
+       -- Zonk a mutable but unbound type variable to an arbitrary type
+       -- We know it's unbound even though we don't carry an environment,
+       -- because at the binding site for a type variable we bind the
+       -- mutable tyvar to a fresh immutable one.  So the mutable store
+       -- plays the role of an environment.  If we come across a mutable
+       -- type variable that isn't so bound, it must be completely free.
+    zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
+
+
+-- When the type checker finds a type variable with no binding,
+-- which means it can be instantiated with an arbitrary type, it
+-- usually instantiates it to Void.  Eg.
+-- 
+--     length []
+-- ===>
+--     length Void (Nil Void)
+-- 
+-- But in really obscure programs, the type variable might have
+-- a kind other than *, so we need to invent a suitably-kinded type.
+-- 
+-- This commit uses
+--     Void for kind *
+--     List for kind *->*
+--     Tuple for kind *->...*->*
+-- 
+-- which deals with most cases.  (Previously, it only dealt with
+-- kind *.)   
+-- 
+-- In the other cases, it just makes up a TyCon with a suitable
+-- kind.  If this gets into an interface file, anyone reading that
+-- file won't understand it.  This is fixable (by making the client
+-- of the interface file make up a TyCon too) but it is tiresome and
+-- never happens, so I am leaving it 
+
+mkArbitraryType :: TcTyVar -> Type
+-- Make up an arbitrary type whose kind is the same as the tyvar.
+-- We'll use this to instantiate the (unbound) tyvar.
+mkArbitraryType tv 
+  | isAnyTypeKind kind = voidTy                -- The vastly common case
+  | otherwise         = mkTyConApp tycon []
+  where
+    kind       = tyVarKind tv
+    (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
+
+    tycon | kind `eqKind` tyConKind listTyCon  -- *->*
+         = listTyCon                           -- No tuples this size
+
+         | all isTypeKind args && isTypeKind res
+         = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
+
+         | otherwise
+         = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
+           mkPrimTyCon tc_name kind 0 [] VoidRep
+               -- Same name as the tyvar, apart from making it start with a colon (sigh)
+               -- I dread to think what will happen if this gets out into an 
+               -- interface file.  Catastrophe likely.  Major sigh.
+
+    tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
+\end{code}