[project @ 2003-04-10 15:46:11 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 c993c2d..24dc515 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -9,29 +9,34 @@ checker.
 \begin{code}
 module TcHsSyn (
        TcMonoBinds, TcHsBinds, TcPat,
 \begin{code}
 module TcHsSyn (
        TcMonoBinds, TcHsBinds, TcPat,

-       TcExpr, TcGRHSsAndBinds, TcGRHS, TcMatch,
+       TcExpr, TcGRHSs, TcGRHS, TcMatch,

        TcStmt, TcArithSeqInfo, TcRecordBinds,
        TcStmt, TcArithSeqInfo, TcRecordBinds,

-       TcHsModule, TcCoreExpr, TcDictBinds,
-       TcForeignExportDecl,
+       TcHsModule, TcDictBinds,
+       TcForeignDecl,

        
        

-       TypecheckedHsBinds, 
+       TypecheckedHsBinds, TypecheckedRuleDecl,

        TypecheckedMonoBinds, TypecheckedPat,
        TypecheckedHsExpr, TypecheckedArithSeqInfo,
        TypecheckedStmt, TypecheckedForeignDecl,
        TypecheckedMatch, TypecheckedHsModule,
        TypecheckedMonoBinds, TypecheckedPat,
        TypecheckedHsExpr, TypecheckedArithSeqInfo,
        TypecheckedStmt, TypecheckedForeignDecl,
        TypecheckedMatch, TypecheckedHsModule,

-       TypecheckedGRHSsAndBinds, TypecheckedGRHS,
+       TypecheckedGRHSs, TypecheckedGRHS,

        TypecheckedRecordBinds, TypecheckedDictBinds,
        TypecheckedRecordBinds, TypecheckedDictBinds,

+       TypecheckedMatchContext, TypecheckedCoreBind,

 
 

-       mkHsTyApp, mkHsDictApp,
-       mkHsTyLam, mkHsDictLam,
+       mkHsTyApp, mkHsDictApp, mkHsConApp,
+       mkHsTyLam, mkHsDictLam, mkHsLet,
+       hsLitType, hsPatType, 

 
 

-       -- re-exported from TcEnv
-       TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
+       -- Coercions
+       Coercion, ExprCoFn, PatCoFn, 
+       (<$>), (<.>), mkCoercion, 
+       idCoercion, isIdCoercion,

 
 

-       maybeBoxedPrimType,
+       -- re-exported from TcMonad
+       TcId, TcIdSet,

 
 

-       zonkTopBinds, zonkTcId, zonkId,
-       zonkForeignExports
+       zonkTopBinds, zonkTopDecls, zonkTopExpr,
+       zonkId, zonkTopBndrs

   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"

@@ -41,26 +46,34 @@ import HsSyn        -- oodles of it
 
 -- others:
 import Id      ( idType, setIdType, Id )
 
 -- others:
 import Id      ( idType, setIdType, Id )

-import DataCon ( DataCon, dataConArgTys )      
-import Name    ( NamedThing(..) )
-import BasicTypes ( Unused )
-import TcEnv   ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv,
-                 TcIdOcc(..), TcIdBndr, GlobalValueEnv,
-                 tcIdType, tcIdTyVars, tcInstId
-               )
-
-import TcMonad
-import TcType  ( TcType, TcTyVar, TcBox,
-                 zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
-               )
-import TyCon   ( isDataTyCon )
-import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
-import Var     ( TyVar )
-import VarEnv  ( TyVarEnv, emptyVarEnv, extendVarEnvList )
-import TysWiredIn      ( voidTy )
-import CoreSyn  ( Expr )
+import 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 Bag

-import UniqFM

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -76,35 +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 TcHsBinds s       = HsBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcMonoBinds s     = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcDictBinds s     = TcMonoBinds s
-type TcPat s           = OutPat (TcBox s) (TcIdOcc s)
-type TcExpr s          = HsExpr (TcBox s) (TcIdOcc s) (TcPat s)
-type TcGRHSsAndBinds s = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcGRHS s          = GRHS (TcBox s) (TcIdOcc s) (TcPat s)
-type TcMatch s         = Match (TcBox s) (TcIdOcc s) (TcPat s)
-type TcStmt s          = Stmt (TcBox s) (TcIdOcc s) (TcPat s)
-type TcArithSeqInfo s  = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
-type TcRecordBinds s   = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
-type TcHsModule s      = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
-
-type TcCoreExpr s      = Expr (TcIdOcc s) (TcBox s)
-type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
-
-type TypecheckedPat            = OutPat        Unused Id
-type TypecheckedMonoBinds      = MonoBinds     Unused Id TypecheckedPat
+type 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 TypecheckedDictBinds      = TypecheckedMonoBinds

-type TypecheckedHsBinds                = HsBinds       Unused Id TypecheckedPat
-type TypecheckedHsExpr         = HsExpr        Unused Id TypecheckedPat
-type TypecheckedArithSeqInfo   = ArithSeqInfo  Unused Id TypecheckedPat
-type TypecheckedStmt           = Stmt          Unused Id TypecheckedPat
-type TypecheckedMatch          = Match         Unused Id TypecheckedPat
-type TypecheckedGRHSsAndBinds  = GRHSsAndBinds Unused Id TypecheckedPat
-type TypecheckedGRHS           = GRHS          Unused Id TypecheckedPat
-type TypecheckedRecordBinds    = HsRecordBinds Unused Id TypecheckedPat
-type TypecheckedHsModule       = HsModule      Unused Id TypecheckedPat
-type TypecheckedForeignDecl     = ForeignDecl Id
+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}

@@ -119,253 +136,327 @@ mkHsTyLam tyvars expr = TyLam tyvars expr
 
 mkHsDictLam []    expr = expr
 mkHsDictLam dicts expr = DictLam dicts expr
 
 mkHsDictLam []    expr = expr
 mkHsDictLam dicts expr = DictLam dicts expr

+
+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}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 %************************************************************************
 %*                                                                     *

-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+\subsection[mkFailurePair]{Code for pattern-matching and other failures}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Some gruesome hackery for desugaring ccalls. It's here because if we put it
-in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
-DsCCall.lhs.
+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}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Coercion functions}
+%*                                                                     *
+%************************************************************************

 
 \begin{code}
 
 \begin{code}

-maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
-maybeBoxedPrimType ty
-  = case splitAlgTyConApp_maybe ty of                                  -- Data type,
-      Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon        -- with exactly one constructor
-        -> case (dataConArgTys data_con tys_applied) of
-            [data_con_arg_ty]                          -- Applied to exactly one type,
-               | isUnLiftedType data_con_arg_ty        -- which is primitive
-               -> Just (data_con, data_con_arg_ty)
-            other_cases -> Nothing
-      other_cases -> Nothing
+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}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 %*                                                                     *
 %************************************************************************
 
 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 %*                                                                     *
 %************************************************************************
 

-@zonkTcId@ just works on TcIdOccs.  It's used when zonking Method insts.
-

 \begin{code}
 \begin{code}

-zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
-zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
-zonkTcId (TcId id)
-  = zonkId id `thenNF_Tc` \id ->
-    returnNF_Tc (TcId id)
-
-zonkId :: TcIdBndr s -> NF_TcM s (TcIdBndr s)
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId

 zonkId id
 zonkId id

-  = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
-    returnNF_Tc (setIdType id ty')
+  = zonkTcType (idType id) `thenM` \ ty' ->
+    returnM (setIdType id ty')

 \end{code}
 
 \end{code}
 

-
-This zonking pass runs over the bindings
+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 TcIdBndr to an Id by zonking its type
-
-We pass an environment around so that
+ c) convert each TcId to an Id by zonking its type

 
 

- 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.

 
 

-Actually, since this is all in the Tc monad, it's convenient to keep the
-mapping from TcIds to Ids in the GVE of the Tc monad.   (Those TcIds
-were previously in the LVE of the Tc monad.)   The type variables, though,
-we carry round in a separate environment.
+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}
 
 It's all pretty boring stuff, because HsSyn is such a large type, and 
 the environment manipulation is tiresome.
 
 \begin{code}

-extend_te te tyvars = extendVarEnvList 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}

 
 

-zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
-zonkIdBndr te (RealId id) = returnNF_Tc id
-zonkIdBndr te (TcId id)
-  = zonkTcTypeToType te (idType id)    `thenNF_Tc` \ ty' ->
-    returnNF_Tc (setIdType id ty')

 
 

+\begin{code}
+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')
+    )

 
 

-zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
-zonkIdOcc (RealId id) = returnNF_Tc id
-zonkIdOcc (TcId id)   
-  = tcLookupGlobalValueMaybe (getName id)      `thenNF_Tc` \ maybe_id' ->
+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')
+    )
+
+---------------------------------------------
+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
     let

-       new_id = case maybe_id' of
-                   Just id' -> id'
-                   Nothing  -> pprTrace "zonkIdOcc: " (ppr id) $
-                                   setIdType id voidTy
+       env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)

     in
     in

-    returnNF_Tc new_id
-\end{code}
-
-
-\begin{code}
-zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv)
-zonkTopBinds binds     -- Top level is implicitly recursive
-  = fixNF_Tc (\ ~(_, new_ids) ->
-       tcExtendGlobalValEnv (bagToList new_ids)        $
-       zonkMonoBinds emptyVarEnv binds                 `thenNF_Tc` \ (binds', _, new_ids) ->
-               -- No top-level existential type variables
-       tcGetGlobalValEnv                               `thenNF_Tc` \ env ->
-       returnNF_Tc ((binds', env), new_ids)
-    )                                  `thenNF_Tc` \ (stuff, _) ->
-    returnNF_Tc stuff
-
-
-zonkBinds :: TyVarEnv Type
-         -> TcHsBinds s
-         -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
-
-zonkBinds te binds 
-  = go binds te (\ binds' te' -> tcGetEnv `thenNF_Tc` \ env -> 
-                                returnNF_Tc (binds', te', env))
+    returnM (env1, IPBinds new_binds is_with)

   where
   where

-    -- go :: TcHsBinds s
-    --    -> (TypecheckedHsBinds
-    --        -> TyVarEnv Type
-    --       -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
-    --       ) 
-    --   -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
-    go (ThenBinds b1 b2) te thing_inside = go b1 te    $ \ b1' te1 -> 
-                                          go b2 te1    $ \ b2' te2 ->
-                                          thing_inside (b1' `ThenBinds` b2') te2
-
-    go EmptyBinds te thing_inside = thing_inside EmptyBinds te
-
-    go (MonoBind bind sigs is_rec) te thing_inside
-         = ASSERT( null sigs )
-           fixNF_Tc (\ ~(_, new_tvs, new_ids) ->
-               let
-                  new_te = extend_te te (bagToList new_tvs)
-               in
-               tcExtendGlobalValEnv (bagToList new_ids)                $
-               zonkMonoBinds new_te bind                               `thenNF_Tc` \ (new_bind, new_tvs, new_ids) ->
-               thing_inside (MonoBind new_bind [] is_rec) new_te       `thenNF_Tc` \ stuff ->
-               returnNF_Tc (stuff, new_tvs, new_ids)
-           )                                                   `thenNF_Tc` \ (stuff, _, _) ->
-          returnNF_Tc stuff
-\end{code}
+    zonk_ip_bind (n, e)
+       = mapIPNameTc (zonkIdBndr env) n        `thenM` \ n' ->
+         zonkExpr env e                        `thenM` \ e' ->
+         returnM (n', e')

 
 

-\begin{code}
--------------------------------------------------------------------------
-zonkMonoBinds :: TyVarEnv Type
-             -> TcMonoBinds s 
-             -> NF_TcM s (TypecheckedMonoBinds, Bag TyVar, Bag Id)

 
 

-zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag, emptyBag)
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> TcMonoBinds
+             -> TcM (TypecheckedMonoBinds, Bag Id)

 
 

-zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
-  = zonkMonoBinds te mbinds1           `thenNF_Tc` \ (b1', tvs1, ids1) ->
-    zonkMonoBinds te mbinds2           `thenNF_Tc` \ (b2', tvs2, ids2) ->
-    returnNF_Tc (b1' `AndMonoBinds` b2', 
-                tvs1 `unionBags` tvs2,
-                ids1 `unionBags` ids2)
+zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)

 
 

-zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
-  = zonkPat te pat                             `thenNF_Tc` \ (new_pat, tvs, ids) ->
-    zonkGRHSsAndBinds te grhss_w_binds         `thenNF_Tc` \ new_grhss_w_binds ->
-    returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, tvs, ids)
+zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
+  = zonkMonoBinds env mbinds1          `thenM` \ (b1', ids1) ->
+    zonkMonoBinds env mbinds2          `thenM` \ (b2', ids2) ->
+    returnM (b1' `AndMonoBinds` b2', 
+            ids1 `unionBags` ids2)

 
 

-zonkMonoBinds te (VarMonoBind var expr)
-  = zonkIdBndr te var          `thenNF_Tc` \ new_var ->
-    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (VarMonoBind new_var new_expr, emptyBag, unitBag new_var)
+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)

 
 

-zonkMonoBinds te (CoreMonoBind var core_expr)
-  = zonkIdBndr te var          `thenNF_Tc` \ new_var ->
-    returnNF_Tc (CoreMonoBind new_var core_expr, emptyBag, unitBag new_var)
+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)

 
 

-zonkMonoBinds te (FunMonoBind var inf ms locn)
-  = zonkIdBndr te var                  `thenNF_Tc` \ new_var ->
-    mapNF_Tc (zonkMatch te) ms         `thenNF_Tc` \ new_ms ->
-    returnNF_Tc (FunMonoBind new_var inf new_ms locn, emptyBag, unitBag new_var)
+zonkMonoBinds 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)

 
 
 
 

-zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
-  = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
-    let
-       new_te = extend_te te new_tyvars
-    in
-    mapNF_Tc (zonkIdBndr new_te) dicts         `thenNF_Tc` \ new_dicts ->
+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

 
 

-    tcExtendGlobalValEnv new_dicts                     $
-    fixNF_Tc (\ ~(_, _, val_bind_tvs, val_bind_ids) ->
+    zonkIdBndrs env dicts              `thenM` \ new_dicts ->
+    fixM (\ ~(_, _, val_bind_ids) ->

        let
        let

-          new_te2 = extend_te new_te (bagToList val_bind_tvs)
+         env1 = extendZonkEnv (extendZonkEnv env new_dicts)
+                              (bagToList val_bind_ids)

        in
        in

-       tcExtendGlobalValEnv (bagToList val_bind_ids)           $
-       zonkMonoBinds new_te2 val_bind          `thenNF_Tc` \ (new_val_bind, val_bind_tvs, val_bind_ids) ->
-        mapNF_Tc (zonkExport new_te2) exports  `thenNF_Tc` \ new_exports ->
-       returnNF_Tc (new_val_bind, new_exports, val_bind_tvs, val_bind_ids)
-    )                                          `thenNF_Tc ` \ (new_val_bind, new_exports, _, _) ->
+       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
     let

-           new_globals = listToBag [global | (_, global, local) <- new_exports]
+       new_globals = listToBag [global | (_, global, local) <- new_exports]

     in
     in

-    returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
-                emptyBag,      -- For now.
+    returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,

                 new_globals)
   where
                 new_globals)
   where

-    zonkExport te (tyvars, global, local)
-       = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
-         zonkIdBndr te global                  `thenNF_Tc` \ new_global ->
-         zonkIdOcc local                       `thenNF_Tc` \ new_local -> 
-         returnNF_Tc (new_tyvars, new_global, new_local)
+    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
-         -> TcMatch s -> NF_TcM s TypecheckedMatch
-
-zonkMatch te (PatMatch pat match)
-  = zonkPat te pat             `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
-    let
-       new_te = extend_te te (bagToList new_tvs)
-    in
-    tcExtendGlobalValEnv (bagToList new_ids)   $
-    zonkMatch new_te match     `thenNF_Tc` \ new_match ->
-    returnNF_Tc (PatMatch new_pat new_match)
-
-zonkMatch te (GRHSMatch grhss_w_binds)
-  = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
-    returnNF_Tc (GRHSMatch new_grhss_w_binds)
+zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch

 
 

-zonkMatch te (SimpleMatch expr)
-  = zonkExpr te 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
-                 -> TcGRHSsAndBinds s
-                 -> NF_TcM s TypecheckedGRHSsAndBinds
+zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs

 
 

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

     let
        zonk_grhs (GRHS guarded locn)
     let
        zonk_grhs (GRHS guarded locn)

-         = zonkStmts new_te guarded  `thenNF_Tc` \ new_guarded ->
-           returnNF_Tc (GRHS new_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 new_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}
 
 %************************************************************************

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

-zonkExpr :: TyVarEnv Type
-        -> TcExpr s -> NF_TcM s TypecheckedHsExpr
-
-zonkExpr te (HsVar id)
-  = zonkIdOcc id       `thenNF_Tc` \ id' ->
-    returnNF_Tc (HsVar id')
-
-zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
-
-zonkExpr te (HsLitOut lit ty)
-  = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
-    returnNF_Tc (HsLitOut lit new_ty)
-
-zonkExpr te (HsLam match)
-  = zonkMatch te match `thenNF_Tc` \ new_match ->
-    returnNF_Tc (HsLam new_match)
-
-zonkExpr te (HsApp e1 e2)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (HsApp new_e1 new_e2)
-
-zonkExpr te (OpApp e1 op fixity e2)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te op     `thenNF_Tc` \ new_op ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
-
-zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
-zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"
-
-zonkExpr te (SectionL expr op)
-  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
-    zonkExpr te op             `thenNF_Tc` \ new_op ->
-    returnNF_Tc (SectionL new_expr new_op)
-
-zonkExpr te (SectionR op expr)
-  = zonkExpr te op             `thenNF_Tc` \ new_op ->
-    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (SectionR new_op new_expr)
-
-zonkExpr te (HsCase expr ms src_loc)
-  = zonkExpr te expr               `thenNF_Tc` \ new_expr ->
-    mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->
-    returnNF_Tc (HsCase new_expr new_ms src_loc)
-
-zonkExpr te (HsIf e1 e2 e3 src_loc)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    zonkExpr te e3     `thenNF_Tc` \ new_e3 ->
-    returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
-
-zonkExpr te (HsLet binds expr)
-  = zonkBinds te binds         `thenNF_Tc` \ (new_binds, new_te, new_env) ->
-    tcSetEnv new_env           $
-    zonkExpr new_te expr       `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsLet new_binds new_expr)
-
-zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
-
-zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
-  = zonkStmts te stmts                 `thenNF_Tc` \ new_stmts ->
-    zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->
-    zonkIdOcc return_id                `thenNF_Tc` \ new_return_id ->
-    zonkIdOcc then_id          `thenNF_Tc` \ new_then_id ->
-    zonkIdOcc zero_id          `thenNF_Tc` \ new_zero_id ->
-    returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
-                        new_ty src_loc)
-
-zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
-
-zonkExpr te (ExplicitListOut ty exprs)
-  = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
-    mapNF_Tc (zonkExpr te) exprs       `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (ExplicitListOut new_ty new_exprs)
-
-zonkExpr te (ExplicitTuple exprs boxed)
-  = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (ExplicitTuple new_exprs boxed)
-
-zonkExpr te (HsCon data_con tys exprs)
-  = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
-    mapNF_Tc (zonkExpr te) exprs       `thenNF_Tc` \ new_exprs ->
-    returnNF_Tc (HsCon data_con new_tys new_exprs)
-
-zonkExpr te (RecordConOut data_con con_expr rbinds)
-  = zonkExpr te con_expr       `thenNF_Tc` \ new_con_expr ->
-    zonkRbinds te rbinds       `thenNF_Tc` \ new_rbinds ->
-    returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
-
-zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
-
-zonkExpr te (RecordUpdOut expr ty dicts rbinds)
-  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
-    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
-    zonkRbinds te rbinds       `thenNF_Tc` \ new_rbinds ->
-    returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
-
-zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
-zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
-
-zonkExpr te (ArithSeqOut expr info)
-  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
-    zonkArithSeq te info       `thenNF_Tc` \ new_info ->
-    returnNF_Tc (ArithSeqOut new_expr new_info)
-
-zonkExpr te (CCall fun args may_gc is_casm result_ty)
-  = mapNF_Tc (zonkExpr te) args        `thenNF_Tc` \ new_args ->
-    zonkTcTypeToType te result_ty      `thenNF_Tc` \ new_result_ty ->
-    returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
-
-zonkExpr te (HsSCC label expr)
-  = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsSCC label new_expr)
-
-zonkExpr te (TyLam tyvars expr)
-  = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
+zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
+zonkExpr  :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
+
+zonkExprs env exprs = mappM (zonkExpr env) exprs
+
+
+zonkExpr env (HsVar id)
+  = returnM (HsVar (zonkIdOcc env id))
+
+zonkExpr env (HsIPVar id)
+  = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
+
+zonkExpr env (HsLit (HsRat f ty))
+  = zonkTcTypeToType env ty       `thenM` \ new_ty  ->
+    returnM (HsLit (HsRat f new_ty))
+
+zonkExpr env (HsLit (HsLitLit lit ty))
+  = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
+    returnM (HsLit (HsLitLit lit new_ty))
+
+zonkExpr env (HsLit lit)
+  = returnM (HsLit lit)
+
+-- HsOverLit doesn't appear in typechecker output
+
+zonkExpr env (HsLam match)
+  = zonkMatch env match        `thenM` \ new_match ->
+    returnM (HsLam new_match)
+
+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
+    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
     let

-       new_te = extend_te te new_tyvars
+       env1 = extendZonkEnv env new_dicts

     in
     in

-    zonkExpr new_te expr               `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (TyLam new_tyvars new_expr)
+    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 (TyApp expr tys)
-  = zonkExpr te expr                   `thenNF_Tc` \ new_expr ->
-    mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys ->
-    returnNF_Tc (TyApp new_expr new_tys)

 
 

-zonkExpr te (DictLam dicts expr)
-  = mapNF_Tc (zonkIdBndr te) dicts     `thenNF_Tc` \ new_dicts ->
-    tcExtendGlobalValEnv new_dicts     $
-    zonkExpr te expr                   `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (DictLam new_dicts new_expr)

 
 

-zonkExpr te (DictApp expr dicts)
-  = zonkExpr te expr                   `thenNF_Tc` \ new_expr ->
-    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
-    returnNF_Tc (DictApp new_expr new_dicts)
+-------------------------------------------------------------------------
+zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo

 
 

+zonkArithSeq env (From e)
+  = zonkExpr env e             `thenM` \ new_e ->
+    returnM (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 env (FromTo e1 e2)
+  = zonkExpr env e1    `thenM` \ new_e1 ->
+    zonkExpr env e2    `thenM` \ new_e2 ->
+    returnM (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 :: TyVarEnv Type
-            -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
+zonkStmts  :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]

 
 

-zonkArithSeq te (From e)
-  = zonkExpr te e              `thenNF_Tc` \ new_e ->
-    returnNF_Tc (From new_e)
+zonkStmts env stmts = zonk_stmts env stmts     `thenM` \ (_, stmts) ->
+                     returnM stmts

 
 

-zonkArithSeq te (FromThen e1 e2)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (FromThen new_e1 new_e2)
+zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])

 
 

-zonkArithSeq te (FromTo e1 e2)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (FromTo new_e1 new_e2)
+zonk_stmts env [] = returnM (env, [])

 
 

-zonkArithSeq te (FromThenTo e1 e2 e3)
-  = zonkExpr te e1     `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2     `thenNF_Tc` \ new_e2 ->
-    zonkExpr te e3     `thenNF_Tc` \ new_e3 ->
-    returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
+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
-         -> [TcStmt s]
-         -> NF_TcM s [TypecheckedStmt]
-
-zonkStmts te [] = returnNF_Tc []
-
-zonkStmts te [ReturnStmt expr]
-  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    returnNF_Tc [ReturnStmt new_expr]
-
-zonkStmts te (ExprStmt expr locn : stmts)
-  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    zonkStmts te       stmts   `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (ExprStmt new_expr locn : new_stmts)
-
-zonkStmts te (GuardStmt expr locn : stmts)
-  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    zonkStmts te       stmts   `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (GuardStmt new_expr locn : new_stmts)
-
-zonkStmts te (LetStmt binds : stmts)
-  = zonkBinds te binds         `thenNF_Tc` \ (new_binds, new_te, new_env) ->
-    tcSetEnv new_env           $
-    zonkStmts new_te stmts     `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (LetStmt new_binds : new_stmts)
-
-zonkStmts te (BindStmt pat expr locn : stmts)
-  = zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    zonkPat te pat             `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
+zonk_stmts env (RecStmt vs segStmts rets : stmts)
+  = mappM zonkId vs            `thenM` \ new_vs ->

     let
     let

-       new_te = extend_te te (bagToList new_tvs)
+       env1 = extendZonkEnv env new_vs

     in
     in

-    tcExtendGlobalValEnv (bagToList new_ids)   $ 
-    zonkStmts new_te stmts     `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
+    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
+       env1 = extendZonkEnv env (bagToList new_ids)
+    in
+    zonk_stmts env1 stmts              `thenM` \ (env2, new_stmts) ->
+    returnM (env2, BindStmt new_pat new_expr locn : new_stmts)

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

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

 
 

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

   where
   where

-    zonk_rbind (field, expr, pun)
-      = zonkExpr te expr       `thenNF_Tc` \ new_expr ->
-       zonkIdOcc field         `thenNF_Tc` \ new_field ->
-       returnNF_Tc (new_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}

@@ -600,116 +748,259 @@ zonkRbinds te rbinds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-zonkPat :: TyVarEnv Type
-       -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id)
-
-zonkPat te (WildPat ty)
-  = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty ->
-    returnNF_Tc (WildPat new_ty, emptyBag, emptyBag)
-
-zonkPat te (VarPat v)
-  = zonkIdBndr te v        `thenNF_Tc` \ new_v ->
-    returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v)
-
-zonkPat te (LazyPat pat)
-  = zonkPat te pat         `thenNF_Tc` \ (new_pat, tvs, ids) ->
-    returnNF_Tc (LazyPat new_pat, tvs, ids)
-
-zonkPat te (AsPat n pat)
-  = zonkIdBndr te n        `thenNF_Tc` \ new_n ->
-    zonkPat te pat         `thenNF_Tc` \ (new_pat, tvs, ids) ->
-    returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids)
-
-zonkPat te (ListPat ty pats)
-  = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
-    zonkPats te pats           `thenNF_Tc` \ (new_pats, tvs, ids) ->
-    returnNF_Tc (ListPat new_ty new_pats, tvs, ids)
-
-zonkPat te (TuplePat pats boxed)
-  = zonkPats te pats                   `thenNF_Tc` \ (new_pats, tvs, ids) ->
-    returnNF_Tc (TuplePat new_pats boxed, tvs, ids)
-
-zonkPat te (ConPat n ty tvs dicts pats)
-  = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
-    mapNF_Tc zonkTcTyVarToTyVar tvs    `thenNF_Tc` \ new_tvs ->
+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
     let

-       new_te = extend_te te new_tvs
+       env1 = extendZonkEnv env new_dicts

     in
     in

-    mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts ->
-    tcExtendGlobalValEnv new_dicts     $
-    
-    zonkPats new_te pats               `thenNF_Tc` \ (new_pats, tvs, ids) ->
-
-    returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats, 
-                listToBag new_tvs `unionBags` tvs,
+    zonkConStuff env stuff             `thenM` \ (new_stuff, ids) ->
+    returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, 

                 listToBag new_dicts `unionBags` ids)
 
                 listToBag new_dicts `unionBags` ids)
 

-zonkPat te (RecPat n ty tvs dicts rpats)
-  = zonkTcTypeToType te ty             `thenNF_Tc` \ new_ty ->
-    mapNF_Tc zonkTcTyVarToTyVar tvs    `thenNF_Tc` \ new_tvs ->
+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
+    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}
+
+%************************************************************************
+%*                                                                     *
+\subsection[BackSubst-Foreign]{Foreign exports}
+%*                                                                     *
+%************************************************************************
+
+
+\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
     let

-       new_te = extend_te te new_tvs
+       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
     in

-    mapNF_Tc (zonkIdBndr new_te) dicts         `thenNF_Tc` \ new_dicts ->
-    tcExtendGlobalValEnv new_dicts             $
-    mapNF_Tc (zonk_rpat new_te) rpats          `thenNF_Tc` \ stuff ->
+    zonkExpr env_lhs lhs               `thenM` \ new_lhs ->
+    zonkExpr env_rhs rhs               `thenM` \ new_rhs ->
+
+    readMutVar unbound_tv_set          `thenM` \ unbound_tvs ->

     let
     let

-       (new_rpats, tvs_s, ids_s) = unzip3 stuff
+       final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
+       -- I hate this map RuleBndr stuff

     in
     in

-    returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats, 
-                listToBag new_tvs   `unionBags` unionManyBags tvs_s,
-                listToBag new_dicts `unionBags` unionManyBags ids_s)
+    returnM (HsRule name act final_bndrs new_lhs new_rhs loc)

   where
   where

-    zonk_rpat te (f, pat, pun)
-      = zonkPat te pat         `thenNF_Tc` \ (new_pat, tvs, ids) ->
-       returnNF_Tc ((f, new_pat, pun), tvs, ids)
-
-zonkPat te (LitPat lit ty)
-  = zonkTcTypeToType te ty         `thenNF_Tc` \ new_ty  ->
-    returnNF_Tc (LitPat lit new_ty, emptyBag, emptyBag)
-
-zonkPat te (NPat lit ty expr)
-  = zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty   ->
-    zonkExpr te expr           `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (NPat lit new_ty new_expr, emptyBag, emptyBag)
-
-zonkPat te (NPlusKPat n k ty e1 e2)
-  = zonkIdBndr te n            `thenNF_Tc` \ new_n ->
-    zonkTcTypeToType te ty     `thenNF_Tc` \ new_ty ->
-    zonkExpr te e1             `thenNF_Tc` \ new_e1 ->
-    zonkExpr te e2             `thenNF_Tc` \ new_e2 ->
-    returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, emptyBag, unitBag new_n)
-
-zonkPat te (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, emptyBag,
-                listToBag new_ds `unionBags` listToBag new_ms)
-
+   zonk_bndr (RuleBndr v) 
+       | isId v    = zonkIdBndr env v
+       | otherwise = zonkTcTyVarToTyVar v

 
 

-zonkPats te []
-  = returnNF_Tc ([], emptyBag, emptyBag)
-
-zonkPats te (pat:pats) 
-  = zonkPat te pat     `thenNF_Tc` \ (pat',  tvs1, ids1) ->
-    zonkPats te pats   `thenNF_Tc` \ (pats', tvs2, ids2) ->
-    returnNF_Tc (pat':pats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2)
+zonkRule env (IfaceRuleOut fun rule)
+  = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)

 \end{code}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-Foreign]{Foreign exports}
 %*                                                                     *
 %************************************************************************
 
 %************************************************************************
 %*                                                                     *
 \subsection[BackSubst-Foreign]{Foreign exports}
 %*                                                                     *
 %************************************************************************
 

-

 \begin{code}
 \begin{code}

-zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
-zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
+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)      -- *-> ... ->*->*

 
 

-zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
-zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
-   zonkIdOcc i `thenNF_Tc` \ i' ->
-   returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
+         | 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}
 \end{code}