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