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