ghc/compiler/typecheck/TcHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
   5
   6 This module is an extension of @HsSyn@ syntax, for use in the type
   7 checker.
   8
   9 \begin{code}
  10 #include "HsVersions.h"
  11
  12 module TcHsSyn (
  13         SYN_IE(TcIdBndr), TcIdOcc(..),
  14
  15         SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcPat),
  16         SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
  17         SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
  18         SYN_IE(TcHsModule), SYN_IE(TcCoreExpr), SYN_IE(TcDictBinds),
  19
  20         SYN_IE(TypecheckedHsBinds),
  21         SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
  22         SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedArithSeqInfo),
  23         SYN_IE(TypecheckedStmt),
  24         SYN_IE(TypecheckedMatch), SYN_IE(TypecheckedHsModule),
  25         SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
  26         SYN_IE(TypecheckedRecordBinds), SYN_IE(TypecheckedDictBinds),
  27
  28         mkHsTyApp, mkHsDictApp,
  29         mkHsTyLam, mkHsDictLam,
  30         tcIdType, tcIdTyVars,
  31
  32         zonkTopBinds, zonkBinds, zonkMonoBinds
  33   ) where
  34
  35 IMP_Ubiq(){-uitous-}
  36
  37 -- friends:
  38 import HsSyn    -- oodles of it
  39 import Id       ( GenId(..), IdDetails, -- Can meddle modestly with Ids
  40                   SYN_IE(DictVar), idType,
  41                   SYN_IE(Id)
  42                 )
  43
  44 -- others:
  45 import Name     ( Name{--O only-}, NamedThing(..) )
  46 import BasicTypes ( IfaceFlavour )
  47 import TcEnv    ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv )
  48 import TcMonad
  49 import TcType   ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
  50                   zonkTcTypeToType, zonkTcTyVarToTyVar
  51                 )
  52 import Usage    ( SYN_IE(UVar) )
  53 import Util     ( zipEqual, panic,
  54                   pprPanic, pprTrace
  55 #ifdef DEBUG
  56                   , assertPanic
  57 #endif
  58                 )
  59
  60 import PprType  ( GenType, GenTyVar )   -- instances
  61 import Type     ( mkTyVarTy, tyVarsOfType, SYN_IE(Type) )
  62 import TyVar    ( GenTyVar {- instances -}, SYN_IE(TyVar),
  63                   SYN_IE(TyVarEnv), nullTyVarEnv, growTyVarEnvList, emptyTyVarSet )
  64 import TysPrim  ( voidTy )
  65 import CoreSyn  ( GenCoreExpr )
  66 import Unique   ( Unique )              -- instances
  67 import Bag
  68 import UniqFM
  69 import Outputable
  70 import Pretty
  71 \end{code}
  72
  73
  74 Type definitions
  75 ~~~~~~~~~~~~~~~~
  76
  77 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  78 All the types in @Tc...@ things have mutable type-variables in them for
  79 unification.
  80
  81 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  82 which have immutable type variables in them.
  83
  84 \begin{code}
  85 type TcIdBndr s = GenId  (TcType s)     -- Binders are all TcTypes
  86 data TcIdOcc  s = TcId   (TcIdBndr s)   -- Bindees may be either
  87                 | RealId Id
  88
  89 type TcHsBinds s        = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  90 type TcMonoBinds s      = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  91 type TcDictBinds s      = TcMonoBinds s
  92 type TcPat s            = OutPat (TcTyVar s) UVar (TcIdOcc s)
  93 type TcExpr s           = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  94 type TcGRHSsAndBinds s  = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  95 type TcGRHS s           = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  96 type TcMatch s          = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  97 type TcStmt s           = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  98 type TcArithSeqInfo s   = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
  99 type TcRecordBinds s    = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
 100 type TcHsModule s       = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
 101
 102 type TcCoreExpr s       = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar
 103
 104 type TypecheckedPat             = OutPat        TyVar UVar Id
 105 type TypecheckedMonoBinds       = MonoBinds     TyVar UVar Id TypecheckedPat
 106 type TypecheckedDictBinds       = TypecheckedMonoBinds
 107 type TypecheckedHsBinds         = HsBinds       TyVar UVar Id TypecheckedPat
 108 type TypecheckedHsExpr          = HsExpr        TyVar UVar Id TypecheckedPat
 109 type TypecheckedArithSeqInfo    = ArithSeqInfo  TyVar UVar Id TypecheckedPat
 110 type TypecheckedStmt            = Stmt          TyVar UVar Id TypecheckedPat
 111 type TypecheckedMatch           = Match         TyVar UVar Id TypecheckedPat
 112 type TypecheckedGRHSsAndBinds   = GRHSsAndBinds TyVar UVar Id TypecheckedPat
 113 type TypecheckedGRHS            = GRHS          TyVar UVar Id TypecheckedPat
 114 type TypecheckedRecordBinds     = HsRecordBinds TyVar UVar Id TypecheckedPat
 115 type TypecheckedHsModule        = HsModule      TyVar UVar Id TypecheckedPat
 116 \end{code}
 117
 118 \begin{code}
 119 mkHsTyApp expr []  = expr
 120 mkHsTyApp expr tys = TyApp expr tys
 121
 122 mkHsDictApp expr []      = expr
 123 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 124
 125 mkHsTyLam []     expr = expr
 126 mkHsTyLam tyvars expr = TyLam tyvars expr
 127
 128 mkHsDictLam []    expr = expr
 129 mkHsDictLam dicts expr = DictLam dicts expr
 130
 131 tcIdType :: TcIdOcc s -> TcType s
 132 tcIdType (TcId   id) = idType id
 133 tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id)
 134
 135 tcIdTyVars (TcId id)  = tyVarsOfType (idType id)
 136 tcIdTyVars (RealId _) = emptyTyVarSet           -- Top level Ids have no free type variables
 137 \end{code}
 138
 139 \begin{code}
 140 instance Eq (TcIdOcc s) where
 141   (TcId id1)   == (TcId id2)   = id1 == id2
 142   (RealId id1) == (RealId id2) = id1 == id2
 143   _            == _            = False
 144
 145 instance Outputable (TcIdOcc s) where
 146   ppr sty (TcId id)   = ppr sty id
 147   ppr sty (RealId id) = ppr sty id
 148
 149 instance NamedThing (TcIdOcc s) where
 150   getName (TcId id)   = getName id
 151   getName (RealId id) = getName id
 152 \end{code}
 153
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 This zonking pass runs over the bindings
 162
 163  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 164  b) convert unbound TcTyVar to Void
 165  c) convert each TcIdBndr to an Id by zonking its type
 166
 167 We pass an environment around so that
 168
 169  a) we know which TyVars are unbound
 170  b) we maintain sharing; eg an Id is zonked at its binding site and they
 171     all occurrences of that Id point to the common zonked copy
 172
 173 Actually, since this is all in the Tc monad, it's convenient to keep the
 174 mapping from TcIds to Ids in the GVE of the Tc monad.   (Those TcIds
 175 were previously in the LVE of the Tc monad.)
 176
 177 It's all pretty boring stuff, because HsSyn is such a large type, and
 178 the environment manipulation is tiresome.
 179
 180
 181 \begin{code}
 182 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
 183
 184 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
 185 zonkIdBndr te (TcId (Id u n ty details prags info))
 186   = zonkTcTypeToType te ty      `thenNF_Tc` \ ty' ->
 187     returnNF_Tc (Id u n ty' details prags info)
 188
 189 zonkIdBndr te (RealId id) = returnNF_Tc id
 190
 191 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
 192 zonkIdOcc (RealId id) = returnNF_Tc id
 193 zonkIdOcc (TcId id)
 194   = tcLookupGlobalValueMaybe (getName id)       `thenNF_Tc` \ maybe_id' ->
 195     let
 196         new_id = case maybe_id' of
 197                     Just id' -> id'
 198                     Nothing  -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $
 199                                     Id u n voidTy details prags info
 200                                 where
 201                                     Id u n _ details prags info = id
 202     in
 203     returnNF_Tc new_id
 204 \end{code}
 205
 206
 207 \begin{code}
 208 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
 209 zonkTopBinds binds      -- Top level is implicitly recursive
 210   = fixNF_Tc (\ ~(_, new_ids) ->
 211         tcExtendGlobalValEnv (bagToList new_ids)        $
 212         zonkMonoBinds nullTyVarEnv binds                `thenNF_Tc` \ (binds', new_ids) ->
 213         tcGetEnv                                        `thenNF_Tc` \ env ->
 214         returnNF_Tc ((binds', env), new_ids)
 215     )                                   `thenNF_Tc` \ (stuff, _) ->
 216     returnNF_Tc stuff
 217
 218
 219 zonkBinds :: TyVarEnv Type
 220           -> TcHsBinds s
 221           -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 222
 223 zonkBinds te binds
 224   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
 225   where
 226     -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
 227     --                   -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 228     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 229                                         go b2   $ \ b2' ->
 230                                         thing_inside (b1' `ThenBinds` b2')
 231
 232     go EmptyBinds thing_inside = thing_inside EmptyBinds
 233
 234     go (MonoBind bind sigs is_rec) thing_inside
 235           = ASSERT( null sigs )
 236             fixNF_Tc (\ ~(_, new_ids) ->
 237                 tcExtendGlobalValEnv (bagToList new_ids)        $
 238                 zonkMonoBinds te bind                           `thenNF_Tc` \ (new_bind, new_ids) ->
 239                 thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
 240                 returnNF_Tc (stuff, new_ids)
 241             )                                           `thenNF_Tc` \ (stuff, _) ->
 242            returnNF_Tc stuff
 243 \end{code}
 244
 245 \begin{code}
 246 -------------------------------------------------------------------------
 247 zonkMonoBinds :: TyVarEnv Type
 248               -> TcMonoBinds s
 249               -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
 250
 251 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 252
 253 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
 254   = zonkMonoBinds te mbinds1            `thenNF_Tc` \ (b1', ids1) ->
 255     zonkMonoBinds te mbinds2            `thenNF_Tc` \ (b2', ids2) ->
 256     returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
 257
 258 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
 259   = zonkPat te pat                              `thenNF_Tc` \ (new_pat, ids) ->
 260     zonkGRHSsAndBinds te grhss_w_binds          `thenNF_Tc` \ new_grhss_w_binds ->
 261     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
 262
 263 zonkMonoBinds te (VarMonoBind var expr)
 264   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 265     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 266     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 267
 268 zonkMonoBinds te (CoreMonoBind var core_expr)
 269   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 270     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 271
 272 zonkMonoBinds te (FunMonoBind var inf ms locn)
 273   = zonkIdBndr te var                   `thenNF_Tc` \ new_var ->
 274     mapNF_Tc (zonkMatch te) ms          `thenNF_Tc` \ new_ms ->
 275     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 276
 277
 278 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
 279   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 280     let
 281         new_te = extend_te te new_tyvars
 282     in
 283     mapNF_Tc (zonkIdBndr new_te) dicts          `thenNF_Tc` \ new_dicts ->
 284
 285     tcExtendGlobalValEnv new_dicts                      $
 286     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 287         tcExtendGlobalValEnv (bagToList val_bind_ids)           $
 288         zonkMonoBinds new_te val_bind           `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 289         mapNF_Tc (zonkExport new_te) exports    `thenNF_Tc` \ new_exports ->
 290         returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
 291     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 292     let
 293             new_globals = listToBag [global | (_, global, local) <- new_exports]
 294     in
 295     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
 296                  new_globals)
 297   where
 298     zonkExport te (tyvars, global, local)
 299         = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
 300           zonkIdBndr te global                  `thenNF_Tc` \ new_global ->
 301           zonkIdOcc local                       `thenNF_Tc` \ new_local ->
 302           returnNF_Tc (new_tyvars, new_global, new_local)
 303 \end{code}
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311 \begin{code}
 312 zonkMatch :: TyVarEnv Type
 313           -> TcMatch s -> NF_TcM s TypecheckedMatch
 314
 315 zonkMatch te (PatMatch pat match)
 316   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 317     tcExtendGlobalValEnv (bagToList ids)        $
 318     zonkMatch te match          `thenNF_Tc` \ new_match ->
 319     returnNF_Tc (PatMatch new_pat new_match)
 320
 321 zonkMatch te (GRHSMatch grhss_w_binds)
 322   = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
 323     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 324
 325 zonkMatch te (SimpleMatch expr)
 326   = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
 327     returnNF_Tc (SimpleMatch new_expr)
 328
 329 -------------------------------------------------------------------------
 330 zonkGRHSsAndBinds :: TyVarEnv Type
 331                   -> TcGRHSsAndBinds s
 332                   -> NF_TcM s TypecheckedGRHSsAndBinds
 333
 334 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
 335   = zonkBinds te binds                  `thenNF_Tc` \ (new_binds, new_env) ->
 336     tcSetEnv new_env $
 337     let
 338         zonk_grhs (GRHS guard expr locn)
 339           = zonkStmts te guard  `thenNF_Tc` \ (new_guard, new_env) ->
 340             tcSetEnv new_env $
 341             zonkExpr te expr    `thenNF_Tc` \ new_expr  ->
 342             returnNF_Tc (GRHS new_guard new_expr locn)
 343
 344         zonk_grhs (OtherwiseGRHS expr locn)
 345           = zonkExpr te expr    `thenNF_Tc` \ new_expr  ->
 346             returnNF_Tc (OtherwiseGRHS new_expr locn)
 347     in
 348     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 349     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 350     returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
 351 \end{code}
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 \begin{code}
 360 zonkExpr :: TyVarEnv Type
 361          -> TcExpr s -> NF_TcM s TypecheckedHsExpr
 362
 363 zonkExpr te (HsVar id)
 364   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 365     returnNF_Tc (HsVar id')
 366
 367 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
 368
 369 zonkExpr te (HsLitOut lit ty)
 370   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 371     returnNF_Tc (HsLitOut lit new_ty)
 372
 373 zonkExpr te (HsLam match)
 374   = zonkMatch te match  `thenNF_Tc` \ new_match ->
 375     returnNF_Tc (HsLam new_match)
 376
 377 zonkExpr te (HsApp e1 e2)
 378   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 379     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 380     returnNF_Tc (HsApp new_e1 new_e2)
 381
 382 zonkExpr te (OpApp e1 op fixity e2)
 383   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 384     zonkExpr te op      `thenNF_Tc` \ new_op ->
 385     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 386     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 387
 388 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
 389 zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"
 390
 391 zonkExpr te (SectionL expr op)
 392   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 393     zonkExpr te op              `thenNF_Tc` \ new_op ->
 394     returnNF_Tc (SectionL new_expr new_op)
 395
 396 zonkExpr te (SectionR op expr)
 397   = zonkExpr te op              `thenNF_Tc` \ new_op ->
 398     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 399     returnNF_Tc (SectionR new_op new_expr)
 400
 401 zonkExpr te (HsCase expr ms src_loc)
 402   = zonkExpr te expr                `thenNF_Tc` \ new_expr ->
 403     mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->
 404     returnNF_Tc (HsCase new_expr new_ms src_loc)
 405
 406 zonkExpr te (HsIf e1 e2 e3 src_loc)
 407   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 408     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 409     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 410     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 411
 412 zonkExpr te (HsLet binds expr)
 413   = zonkBinds te binds          `thenNF_Tc` \ (new_binds, new_env) ->
 414     tcSetEnv new_env            $
 415     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 416     returnNF_Tc (HsLet new_binds new_expr)
 417
 418 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
 419
 420 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 421   = zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, _) ->
 422     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 423     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 424     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 425     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 426     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 427                          new_ty src_loc)
 428
 429 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
 430
 431 zonkExpr te (ExplicitListOut ty exprs)
 432   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 433     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 434     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 435
 436 zonkExpr te (ExplicitTuple exprs)
 437   = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->
 438     returnNF_Tc (ExplicitTuple new_exprs)
 439
 440 zonkExpr te (RecordCon con rbinds)
 441   = zonkExpr te con             `thenNF_Tc` \ new_con ->
 442     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 443     returnNF_Tc (RecordCon new_con new_rbinds)
 444
 445 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
 446
 447 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
 448   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 449     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 450     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 451     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 452     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 453
 454 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
 455 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
 456
 457 zonkExpr te (ArithSeqOut expr info)
 458   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 459     zonkArithSeq te info        `thenNF_Tc` \ new_info ->
 460     returnNF_Tc (ArithSeqOut new_expr new_info)
 461
 462 zonkExpr te (CCall fun args may_gc is_casm result_ty)
 463   = mapNF_Tc (zonkExpr te) args         `thenNF_Tc` \ new_args ->
 464     zonkTcTypeToType te result_ty       `thenNF_Tc` \ new_result_ty ->
 465     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 466
 467 zonkExpr te (HsSCC label expr)
 468   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 469     returnNF_Tc (HsSCC label new_expr)
 470
 471 zonkExpr te (TyLam tyvars expr)
 472   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 473     let
 474         new_te = extend_te te new_tyvars
 475     in
 476     zonkExpr new_te expr                `thenNF_Tc` \ new_expr ->
 477     returnNF_Tc (TyLam new_tyvars new_expr)
 478
 479 zonkExpr te (TyApp expr tys)
 480   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 481     mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 482     returnNF_Tc (TyApp new_expr new_tys)
 483
 484 zonkExpr te (DictLam dicts expr)
 485   = mapNF_Tc (zonkIdBndr te) dicts      `thenNF_Tc` \ new_dicts ->
 486     tcExtendGlobalValEnv new_dicts      $
 487     zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 488     returnNF_Tc (DictLam new_dicts new_expr)
 489
 490 zonkExpr te (DictApp expr dicts)
 491   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 492     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 493     returnNF_Tc (DictApp new_expr new_dicts)
 494
 495 zonkExpr te (ClassDictLam dicts methods expr)
 496   = zonkExpr te expr                `thenNF_Tc` \ new_expr ->
 497     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 498     mapNF_Tc zonkIdOcc methods  `thenNF_Tc` \ new_methods ->
 499     returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
 500
 501 zonkExpr te (Dictionary dicts methods)
 502   = mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 503     mapNF_Tc zonkIdOcc methods  `thenNF_Tc` \ new_methods ->
 504     returnNF_Tc (Dictionary new_dicts new_methods)
 505
 506 zonkExpr te (SingleDict name)
 507   = zonkIdOcc name      `thenNF_Tc` \ name' ->
 508     returnNF_Tc (SingleDict name')
 509
 510
 511 -------------------------------------------------------------------------
 512 zonkArithSeq :: TyVarEnv Type
 513              -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 514
 515 zonkArithSeq te (From e)
 516   = zonkExpr te e               `thenNF_Tc` \ new_e ->
 517     returnNF_Tc (From new_e)
 518
 519 zonkArithSeq te (FromThen e1 e2)
 520   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 521     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 522     returnNF_Tc (FromThen new_e1 new_e2)
 523
 524 zonkArithSeq te (FromTo e1 e2)
 525   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 526     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 527     returnNF_Tc (FromTo new_e1 new_e2)
 528
 529 zonkArithSeq te (FromThenTo e1 e2 e3)
 530   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 531     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 532     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 533     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 534
 535 -------------------------------------------------------------------------
 536 zonkStmts :: TyVarEnv Type
 537           -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
 538
 539 zonkStmts te [] = tcGetEnv      `thenNF_Tc` \ env ->
 540                   returnNF_Tc ([], env)
 541
 542 zonkStmts te [ReturnStmt expr]
 543   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 544     tcGetEnv                    `thenNF_Tc` \ env ->
 545     returnNF_Tc ([ReturnStmt new_expr], env)
 546
 547 zonkStmts te (ExprStmt expr locn : stmts)
 548   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 549     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 550     returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
 551
 552 zonkStmts te (GuardStmt expr locn : stmts)
 553   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 554     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 555     returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
 556
 557 zonkStmts te (LetStmt binds : stmts)
 558   = zonkBinds te     binds      `thenNF_Tc` \ (new_binds, new_env) ->
 559     tcSetEnv new_env            $
 560     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env2) ->
 561     returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
 562
 563 zonkStmts te (BindStmt pat expr locn : stmts)
 564   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 565     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 566     tcExtendGlobalValEnv (bagToList ids)        $
 567     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env) ->
 568     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
 569
 570
 571
 572 -------------------------------------------------------------------------
 573 zonkRbinds :: TyVarEnv Type
 574            -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 575
 576 zonkRbinds te rbinds
 577   = mapNF_Tc zonk_rbind rbinds
 578   where
 579     zonk_rbind (field, expr, pun)
 580       = zonkExpr te expr        `thenNF_Tc` \ new_expr ->
 581         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 582         returnNF_Tc (new_field, new_expr, pun)
 583 \end{code}
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsection[BackSubst-Pats]{Patterns}
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 \begin{code}
 592 zonkPat :: TyVarEnv Type
 593         -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
 594
 595 zonkPat te (WildPat ty)
 596   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty ->
 597     returnNF_Tc (WildPat new_ty, emptyBag)
 598
 599 zonkPat te (VarPat v)
 600   = zonkIdBndr te v         `thenNF_Tc` \ new_v ->
 601     returnNF_Tc (VarPat new_v, unitBag new_v)
 602
 603 zonkPat te (LazyPat pat)
 604   = zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 605     returnNF_Tc (LazyPat new_pat, ids)
 606
 607 zonkPat te (AsPat n pat)
 608   = zonkIdBndr te n         `thenNF_Tc` \ new_n ->
 609     zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 610     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 611
 612 zonkPat te (ConPat n ty pats)
 613   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 614     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 615     returnNF_Tc (ConPat n new_ty new_pats, ids)
 616
 617 zonkPat te (ConOpPat pat1 op pat2 ty)
 618   = zonkPat te pat1         `thenNF_Tc` \ (new_pat1, ids1) ->
 619     zonkPat te pat2         `thenNF_Tc` \ (new_pat2, ids2) ->
 620     zonkTcTypeToType te ty  `thenNF_Tc` \ new_ty ->
 621     returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
 622
 623 zonkPat te (ListPat ty pats)
 624   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 625     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 626     returnNF_Tc (ListPat new_ty new_pats, ids)
 627
 628 zonkPat te (TuplePat pats)
 629   = zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 630     returnNF_Tc (TuplePat new_pats, ids)
 631
 632 zonkPat te (RecPat n ty rpats)
 633   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 634     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 635     returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
 636   where
 637     zonk_rpat (f, pat, pun)
 638       = zonkPat te pat       `thenNF_Tc` \ (new_pat, ids) ->
 639         returnNF_Tc ((f, new_pat, pun), ids)
 640
 641 zonkPat te (LitPat lit ty)
 642   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 643     returnNF_Tc (LitPat lit new_ty, emptyBag)
 644
 645 zonkPat te (NPat lit ty expr)
 646   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 647     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 648     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 649
 650 zonkPat te (NPlusKPat n k ty e1 e2)
 651   = zonkIdBndr te n             `thenNF_Tc` \ new_n ->
 652     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 653     zonkExpr te e1              `thenNF_Tc` \ new_e1 ->
 654     zonkExpr te e2              `thenNF_Tc` \ new_e2 ->
 655     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 656
 657 zonkPat te (DictPat ds ms)
 658   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
 659     mapNF_Tc (zonkIdBndr te) ms    `thenNF_Tc` \ new_ms ->
 660     returnNF_Tc (DictPat new_ds new_ms,
 661                  listToBag new_ds `unionBags` listToBag new_ms)
 662
 663
 664 zonkPats te []
 665   = returnNF_Tc ([], emptyBag)
 666 zonkPats te (pat:pats)
 667   = zonkPat te pat      `thenNF_Tc` \ (pat', ids1) ->
 668     zonkPats te pats    `thenNF_Tc` \ (pats', ids2) ->
 669     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 670 \end{code}
 671
 672