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