ghc/compiler/typecheck/TcHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   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 module TcHsSyn (
  11         TcMonoBinds, TcHsBinds, TcPat,
  12         TcExpr, TcGRHSs, TcGRHS, TcMatch,
  13         TcStmt, TcArithSeqInfo, TcRecordBinds,
  14         TcHsModule, TcCoreExpr, TcDictBinds,
  15         TcForeignExportDecl,
  16
  17         TypecheckedHsBinds, TypecheckedRuleDecl,
  18         TypecheckedMonoBinds, TypecheckedPat,
  19         TypecheckedHsExpr, TypecheckedArithSeqInfo,
  20         TypecheckedStmt, TypecheckedForeignDecl,
  21         TypecheckedMatch, TypecheckedHsModule,
  22         TypecheckedGRHSs, TypecheckedGRHS,
  23         TypecheckedRecordBinds, TypecheckedDictBinds,
  24         TypecheckedMatchContext,
  25
  26         mkHsTyApp, mkHsDictApp, mkHsConApp,
  27         mkHsTyLam, mkHsDictLam, mkHsLet,
  28
  29         -- re-exported from TcEnv
  30         TcId,
  31
  32         zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
  33         zonkForeignExports, zonkRules
  34   ) where
  35
  36 #include "HsVersions.h"
  37
  38 -- friends:
  39 import HsSyn    -- oodles of it
  40
  41 -- others:
  42 import Id       ( idName, idType, setIdType, Id )
  43 import DataCon  ( dataConWrapId )
  44 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
  45                   TcEnv, TcId
  46                 )
  47
  48 import TcMonad
  49 import TcType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
  50                 )
  51 import CoreSyn  ( Expr )
  52 import BasicTypes ( RecFlag(..) )
  53 import Bag
  54 import Outputable
  55 import HscTypes ( TyThing(..) )
  56 \end{code}
  57
  58
  59 Type definitions
  60 ~~~~~~~~~~~~~~~~
  61
  62 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  63 All the types in @Tc...@ things have mutable type-variables in them for
  64 unification.
  65
  66 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  67 which have immutable type variables in them.
  68
  69 \begin{code}
  70 type TcHsBinds          = HsBinds TcId TcPat
  71 type TcMonoBinds        = MonoBinds TcId TcPat
  72 type TcDictBinds        = TcMonoBinds
  73 type TcPat              = OutPat TcId
  74 type TcExpr             = HsExpr TcId TcPat
  75 type TcGRHSs            = GRHSs TcId TcPat
  76 type TcGRHS             = GRHS TcId TcPat
  77 type TcMatch            = Match TcId TcPat
  78 type TcStmt             = Stmt TcId TcPat
  79 type TcArithSeqInfo     = ArithSeqInfo TcId TcPat
  80 type TcRecordBinds      = HsRecordBinds TcId TcPat
  81 type TcHsModule = HsModule TcId TcPat
  82
  83 type TcCoreExpr = Expr TcId
  84 type TcForeignExportDecl = ForeignDecl TcId
  85 type TcRuleDecl          = RuleDecl    TcId TcPat
  86
  87 type TypecheckedPat             = OutPat        Id
  88 type TypecheckedMonoBinds       = MonoBinds     Id TypecheckedPat
  89 type TypecheckedDictBinds       = TypecheckedMonoBinds
  90 type TypecheckedHsBinds         = HsBinds       Id TypecheckedPat
  91 type TypecheckedHsExpr          = HsExpr        Id TypecheckedPat
  92 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id TypecheckedPat
  93 type TypecheckedStmt            = Stmt          Id TypecheckedPat
  94 type TypecheckedMatch           = Match         Id TypecheckedPat
  95 type TypecheckedMatchContext    = HsMatchContext Id
  96 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
  97 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
  98 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
  99 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
 100 type TypecheckedForeignDecl     = ForeignDecl Id
 101 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 102 \end{code}
 103
 104 \begin{code}
 105 mkHsTyApp expr []  = expr
 106 mkHsTyApp expr tys = TyApp expr tys
 107
 108 mkHsDictApp expr []      = expr
 109 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 110
 111 mkHsTyLam []     expr = expr
 112 mkHsTyLam tyvars expr = TyLam tyvars expr
 113
 114 mkHsDictLam []    expr = expr
 115 mkHsDictLam dicts expr = DictLam dicts expr
 116
 117 mkHsLet EmptyMonoBinds expr = expr
 118 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 119
 120 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 This zonking pass runs over the bindings
 130
 131  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 132  b) convert unbound TcTyVar to Void
 133  c) convert each TcId to an Id by zonking its type
 134
 135 The type variables are converted by binding mutable tyvars to immutable ones
 136 and then zonking as normal.
 137
 138 The Ids are converted by binding them in the normal Tc envt; that
 139 way we maintain sharing; eg an Id is zonked at its binding site and they
 140 all occurrences of that Id point to the common zonked copy
 141
 142 It's all pretty boring stuff, because HsSyn is such a large type, and
 143 the environment manipulation is tiresome.
 144
 145 \begin{code}
 146 -- zonkId is used *during* typechecking just to zonk the Id's type
 147 zonkId :: TcId -> NF_TcM TcId
 148 zonkId id
 149   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 150     returnNF_Tc (setIdType id ty')
 151
 152 -- zonkIdBndr is used *after* typechecking to get the Id's type
 153 -- to its final form.  The TyVarEnv give
 154 zonkIdBndr :: TcId -> NF_TcM Id
 155 zonkIdBndr id
 156   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 157     returnNF_Tc (setIdType id ty')
 158
 159 zonkIdOcc :: TcId -> NF_TcM Id
 160 zonkIdOcc id
 161   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 162         -- We're even look up up superclass selectors and constructors;
 163         -- even though zonking them is a no-op anyway, and the
 164         -- superclass selectors aren't in the environment anyway.
 165         -- But we don't want to call isLocalId to find out whether
 166         -- it's a superclass selector (for example) because that looks
 167         -- at the IdInfo field, which in turn be in a knot because of
 168         -- the big knot in typecheckModule
 169     let
 170         new_id = case maybe_id' of
 171                     Just (AnId id') -> id'
 172                     other           -> id -- WARN( isLocalId id, ppr id ) id
 173                                         -- Oops: the warning can give a black hole
 174                                         -- because it looks at the idinfo
 175     in
 176     returnNF_Tc new_id
 177 \end{code}
 178
 179
 180 \begin{code}
 181 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 182 zonkTopBinds binds      -- Top level is implicitly recursive
 183   = fixNF_Tc (\ ~(_, new_ids) ->
 184         tcExtendGlobalValEnv (bagToList new_ids)        $
 185         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 186         tcGetEnv                                `thenNF_Tc` \ env ->
 187         returnNF_Tc ((binds', env), new_ids)
 188     )                                   `thenNF_Tc` \ (stuff, _) ->
 189     returnNF_Tc stuff
 190
 191 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 192
 193 zonkBinds binds
 194   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 195                           returnNF_Tc (binds', env))
 196   where
 197     -- go :: TcHsBinds
 198     --    -> (TypecheckedHsBinds
 199     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 200     --       )
 201     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 202
 203     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 204                                         go b2   $ \ b2' ->
 205                                         thing_inside (b1' `ThenBinds` b2')
 206
 207     go EmptyBinds thing_inside = thing_inside EmptyBinds
 208
 209     go (MonoBind bind sigs is_rec) thing_inside
 210           = ASSERT( null sigs )
 211             fixNF_Tc (\ ~(_, new_ids) ->
 212                 tcExtendGlobalValEnv (bagToList new_ids)        $
 213                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 214                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 215                 returnNF_Tc (stuff, new_ids)
 216             )                                                   `thenNF_Tc` \ (stuff, _) ->
 217            returnNF_Tc stuff
 218 \end{code}
 219
 220 \begin{code}
 221 -------------------------------------------------------------------------
 222 zonkMonoBinds :: TcMonoBinds
 223               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 224
 225 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 226
 227 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 228   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 229     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 230     returnNF_Tc (b1' `AndMonoBinds` b2',
 231                  ids1 `unionBags` ids2)
 232
 233 zonkMonoBinds (PatMonoBind pat grhss locn)
 234   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 235     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 236     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 237
 238 zonkMonoBinds (VarMonoBind var expr)
 239   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 240     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 241     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 242
 243 zonkMonoBinds (CoreMonoBind var core_expr)
 244   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 245     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 246
 247 zonkMonoBinds (FunMonoBind var inf ms locn)
 248   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 249     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 250     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 251
 252
 253 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 254   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 255         -- No need to extend tyvar env: the effects are
 256         -- propagated through binding the tyvars themselves
 257
 258     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 259     tcExtendGlobalValEnv new_dicts                      $
 260
 261     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 262         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 263         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 264         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 265         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 266     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 267     let
 268             new_globals = listToBag [global | (_, global, local) <- new_exports]
 269     in
 270     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 271                  new_globals)
 272   where
 273     zonkExport (tyvars, global, local)
 274         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 275                 -- This isn't the binding occurrence of these tyvars
 276                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 277           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 278           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 279           returnNF_Tc (new_tyvars, new_global, new_local)
 280 \end{code}
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 \begin{code}
 289 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 290
 291 zonkMatch (Match _ pats _ grhss)
 292   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 293     tcExtendGlobalValEnv (bagToList new_ids)    $
 294     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 295     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 296
 297 -------------------------------------------------------------------------
 298 zonkGRHSs :: TcGRHSs
 299           -> NF_TcM TypecheckedGRHSs
 300
 301 zonkGRHSs (GRHSs grhss binds (Just ty))
 302   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 303     tcSetEnv new_env $
 304     let
 305         zonk_grhs (GRHS guarded locn)
 306           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 307             returnNF_Tc (GRHS new_guarded locn)
 308     in
 309     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 310     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 311     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 312 \end{code}
 313
 314 %************************************************************************
 315 %*                                                                      *
 316 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 317 %*                                                                      *
 318 %************************************************************************
 319
 320 \begin{code}
 321 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 322
 323 zonkExpr (HsVar id)
 324   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 325     returnNF_Tc (HsVar id')
 326
 327 zonkExpr (HsIPVar id)
 328   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 329     returnNF_Tc (HsIPVar id')
 330
 331 zonkExpr (HsLit (HsRat f ty))
 332   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 333     returnNF_Tc (HsLit (HsRat f new_ty))
 334
 335 zonkExpr (HsLit (HsLitLit lit ty))
 336   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 337     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 338
 339 zonkExpr (HsLit lit)
 340   = returnNF_Tc (HsLit lit)
 341
 342 -- HsOverLit doesn't appear in typechecker output
 343
 344 zonkExpr (HsLam match)
 345   = zonkMatch match     `thenNF_Tc` \ new_match ->
 346     returnNF_Tc (HsLam new_match)
 347
 348 zonkExpr (HsApp e1 e2)
 349   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 350     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 351     returnNF_Tc (HsApp new_e1 new_e2)
 352
 353 zonkExpr (OpApp e1 op fixity e2)
 354   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 355     zonkExpr op `thenNF_Tc` \ new_op ->
 356     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 357     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 358
 359 zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
 360 zonkExpr (HsPar _)  = panic "zonkExpr: HsPar"
 361
 362 zonkExpr (SectionL expr op)
 363   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 364     zonkExpr op         `thenNF_Tc` \ new_op ->
 365     returnNF_Tc (SectionL new_expr new_op)
 366
 367 zonkExpr (SectionR op expr)
 368   = zonkExpr op         `thenNF_Tc` \ new_op ->
 369     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 370     returnNF_Tc (SectionR new_op new_expr)
 371
 372 zonkExpr (HsCase expr ms src_loc)
 373   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 374     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 375     returnNF_Tc (HsCase new_expr new_ms src_loc)
 376
 377 zonkExpr (HsIf e1 e2 e3 src_loc)
 378   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 379     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 380     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 381     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 382
 383 zonkExpr (HsLet binds expr)
 384   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 385     tcSetEnv new_env            $
 386     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 387     returnNF_Tc (HsLet new_binds new_expr)
 388
 389 zonkExpr (HsWith expr binds)
 390   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 391     tcExtendGlobalValEnv (map fst new_binds)    $
 392     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 393     returnNF_Tc (HsWith new_expr new_binds)
 394     where
 395         zonkIPBinds = mapNF_Tc zonkIPBind
 396         zonkIPBind (n, e) =
 397             zonkIdBndr n        `thenNF_Tc` \ n' ->
 398             zonkExpr e          `thenNF_Tc` \ e' ->
 399             returnNF_Tc (n', e')
 400
 401 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 402
 403 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 404   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 405     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 406     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 407     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 408     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 409     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 410                          new_ty src_loc)
 411
 412 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 413
 414 zonkExpr (ExplicitListOut ty exprs)
 415   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 416     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 417     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 418
 419 zonkExpr (ExplicitTuple exprs boxed)
 420   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 421     returnNF_Tc (ExplicitTuple new_exprs boxed)
 422
 423 zonkExpr (RecordConOut data_con con_expr rbinds)
 424   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 425     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 426     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 427
 428 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 429
 430 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 431   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 432     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 433     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 434     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 435     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 436
 437 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 438 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 439
 440 zonkExpr (ArithSeqOut expr info)
 441   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 442     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 443     returnNF_Tc (ArithSeqOut new_expr new_info)
 444
 445 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 446   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 447     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 448     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 449
 450 zonkExpr (HsSCC lbl expr)
 451   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 452     returnNF_Tc (HsSCC lbl new_expr)
 453
 454 zonkExpr (TyLam tyvars expr)
 455   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 456         -- No need to extend tyvar env; see AbsBinds
 457
 458     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 459     returnNF_Tc (TyLam new_tyvars new_expr)
 460
 461 zonkExpr (TyApp expr tys)
 462   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 463     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 464     returnNF_Tc (TyApp new_expr new_tys)
 465
 466 zonkExpr (DictLam dicts expr)
 467   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 468     tcExtendGlobalValEnv new_dicts      $
 469     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 470     returnNF_Tc (DictLam new_dicts new_expr)
 471
 472 zonkExpr (DictApp expr dicts)
 473   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 474     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 475     returnNF_Tc (DictApp new_expr new_dicts)
 476
 477
 478
 479 -------------------------------------------------------------------------
 480 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 481
 482 zonkArithSeq (From e)
 483   = zonkExpr e          `thenNF_Tc` \ new_e ->
 484     returnNF_Tc (From new_e)
 485
 486 zonkArithSeq (FromThen e1 e2)
 487   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 488     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 489     returnNF_Tc (FromThen new_e1 new_e2)
 490
 491 zonkArithSeq (FromTo e1 e2)
 492   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 493     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 494     returnNF_Tc (FromTo new_e1 new_e2)
 495
 496 zonkArithSeq (FromThenTo e1 e2 e3)
 497   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 498     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 499     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 500     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 501
 502 -------------------------------------------------------------------------
 503 zonkStmts :: [TcStmt]
 504           -> NF_TcM [TypecheckedStmt]
 505
 506 zonkStmts [] = returnNF_Tc []
 507
 508 zonkStmts (ParStmtOut bndrstmtss : stmts)
 509   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 510     let new_binders = concat new_bndrss in
 511     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 512     tcExtendGlobalValEnv new_binders    $
 513     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 514     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 515   where (bndrss, stmtss) = unzip bndrstmtss
 516
 517 zonkStmts (ResultStmt expr locn : stmts)
 518   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 519     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 520     returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 521
 522 zonkStmts (ExprStmt expr locn : stmts)
 523   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 524     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 525     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 526
 527 zonkStmts (LetStmt binds : stmts)
 528   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 529     tcSetEnv new_env            $
 530     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 531     returnNF_Tc (LetStmt new_binds : new_stmts)
 532
 533 zonkStmts (BindStmt pat expr locn : stmts)
 534   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 535     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 536     tcExtendGlobalValEnv (bagToList new_ids)    $
 537     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 538     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 539
 540
 541
 542 -------------------------------------------------------------------------
 543 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 544
 545 zonkRbinds rbinds
 546   = mapNF_Tc zonk_rbind rbinds
 547   where
 548     zonk_rbind (field, expr, pun)
 549       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 550         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 551         returnNF_Tc (new_field, new_expr, pun)
 552 \end{code}
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsection[BackSubst-Pats]{Patterns}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 562
 563 zonkPat (WildPat ty)
 564   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 565     returnNF_Tc (WildPat new_ty, emptyBag)
 566
 567 zonkPat (VarPat v)
 568   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 569     returnNF_Tc (VarPat new_v, unitBag new_v)
 570
 571 zonkPat (LazyPat pat)
 572   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 573     returnNF_Tc (LazyPat new_pat, ids)
 574
 575 zonkPat (AsPat n pat)
 576   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 577     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 578     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 579
 580 zonkPat (ListPat ty pats)
 581   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 582     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 583     returnNF_Tc (ListPat new_ty new_pats, ids)
 584
 585 zonkPat (TuplePat pats boxed)
 586   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 587     returnNF_Tc (TuplePat new_pats boxed, ids)
 588
 589 zonkPat (ConPat n ty tvs dicts pats)
 590   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 591     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 592     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 593     tcExtendGlobalValEnv new_dicts      $
 594     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 595     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 596                  listToBag new_dicts `unionBags` ids)
 597
 598 zonkPat (RecPat n ty tvs dicts rpats)
 599   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 600     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 601     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 602     tcExtendGlobalValEnv new_dicts      $
 603     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 604     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 605                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 606   where
 607     zonk_rpat (f, pat, pun)
 608       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 609         returnNF_Tc ((f, new_pat, pun), ids)
 610
 611 zonkPat (LitPat lit ty)
 612   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 613     returnNF_Tc (LitPat lit new_ty, emptyBag)
 614
 615 zonkPat (NPat lit ty expr)
 616   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 617     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 618     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 619
 620 zonkPat (NPlusKPat n k ty e1 e2)
 621   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 622     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 623     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 624     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 625     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 626
 627 zonkPat (DictPat ds ms)
 628   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 629     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 630     returnNF_Tc (DictPat new_ds new_ms,
 631                  listToBag new_ds `unionBags` listToBag new_ms)
 632
 633
 634 zonkPats []
 635   = returnNF_Tc ([], emptyBag)
 636
 637 zonkPats (pat:pats)
 638   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 639     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 640     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 641 \end{code}
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsection[BackSubst-Foreign]{Foreign exports}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649
 650 \begin{code}
 651 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 652 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 653
 654 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 655 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
 656    zonkIdOcc i  `thenNF_Tc` \ i' ->
 657    returnNF_Tc (ForeignExport i' undefined spec src_loc)
 658 \end{code}
 659
 660 \begin{code}
 661 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 662 zonkRules rs = mapNF_Tc zonkRule rs
 663
 664 zonkRule (HsRule name tyvars vars lhs rhs loc)
 665   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 666     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 667     tcExtendGlobalValEnv new_bndrs                      $
 668     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 669     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 670     returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 671         -- I hate this map RuleBndr stuff
 672
 673 zonkRule (IfaceRuleOut fun rule)
 674   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 675     returnNF_Tc (IfaceRuleOut fun' rule)
 676 \end{code}