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,
  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, Id )
  42 import DataCon  ( dataConWrapId )
  43 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
  44                   TcEnv, TcId
  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   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 160         -- We're even look up up superclass selectors and constructors;
 161         -- even though zonking them is a no-op anyway, and the
 162         -- superclass selectors aren't in the environment anyway.
 163         -- But we don't want to call isLocalId to find out whether
 164         -- it's a superclass selector (for example) because that looks
 165         -- at the IdInfo field, which in turn be in a knot because of
 166         -- the big knot in typecheckModule
 167     let
 168         new_id = case maybe_id' of
 169                     Just (AnId id') -> id'
 170                     other           -> WARN( isLocalId id, ppr id ) id
 171     in
 172     returnNF_Tc new_id
 173 \end{code}
 174
 175
 176 \begin{code}
 177 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 178 zonkTopBinds binds      -- Top level is implicitly recursive
 179   = fixNF_Tc (\ ~(_, new_ids) ->
 180         tcExtendGlobalValEnv (bagToList new_ids)        $
 181         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 182         tcGetEnv                                `thenNF_Tc` \ env ->
 183         returnNF_Tc ((binds', env), new_ids)
 184     )                                   `thenNF_Tc` \ (stuff, _) ->
 185     returnNF_Tc stuff
 186
 187 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 188
 189 zonkBinds binds
 190   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 191                           returnNF_Tc (binds', env))
 192   where
 193     -- go :: TcHsBinds
 194     --    -> (TypecheckedHsBinds
 195     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 196     --       )
 197     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 198
 199     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 200                                         go b2   $ \ b2' ->
 201                                         thing_inside (b1' `ThenBinds` b2')
 202
 203     go EmptyBinds thing_inside = thing_inside EmptyBinds
 204
 205     go (MonoBind bind sigs is_rec) thing_inside
 206           = ASSERT( null sigs )
 207             fixNF_Tc (\ ~(_, new_ids) ->
 208                 tcExtendGlobalValEnv (bagToList new_ids)        $
 209                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 210                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 211                 returnNF_Tc (stuff, new_ids)
 212             )                                                   `thenNF_Tc` \ (stuff, _) ->
 213            returnNF_Tc stuff
 214 \end{code}
 215
 216 \begin{code}
 217 -------------------------------------------------------------------------
 218 zonkMonoBinds :: TcMonoBinds
 219               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 220
 221 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 222
 223 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 224   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 225     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 226     returnNF_Tc (b1' `AndMonoBinds` b2',
 227                  ids1 `unionBags` ids2)
 228
 229 zonkMonoBinds (PatMonoBind pat grhss locn)
 230   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 231     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 232     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 233
 234 zonkMonoBinds (VarMonoBind var expr)
 235   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 236     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 237     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 238
 239 zonkMonoBinds (CoreMonoBind var core_expr)
 240   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 241     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 242
 243 zonkMonoBinds (FunMonoBind var inf ms locn)
 244   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 245     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 246     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 247
 248
 249 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 250   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 251         -- No need to extend tyvar env: the effects are
 252         -- propagated through binding the tyvars themselves
 253
 254     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 255     tcExtendGlobalValEnv new_dicts                      $
 256
 257     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 258         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 259         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 260         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 261         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 262     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 263     let
 264             new_globals = listToBag [global | (_, global, local) <- new_exports]
 265     in
 266     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 267                  new_globals)
 268   where
 269     zonkExport (tyvars, global, local)
 270         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 271                 -- This isn't the binding occurrence of these tyvars
 272                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 273           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 274           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 275           returnNF_Tc (new_tyvars, new_global, new_local)
 276 \end{code}
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 \begin{code}
 285 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 286
 287 zonkMatch (Match _ pats _ grhss)
 288   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 289     tcExtendGlobalValEnv (bagToList new_ids)    $
 290     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 291     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 292
 293 -------------------------------------------------------------------------
 294 zonkGRHSs :: TcGRHSs
 295           -> NF_TcM TypecheckedGRHSs
 296
 297 zonkGRHSs (GRHSs grhss binds (Just ty))
 298   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 299     tcSetEnv new_env $
 300     let
 301         zonk_grhs (GRHS guarded locn)
 302           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 303             returnNF_Tc (GRHS new_guarded locn)
 304     in
 305     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 306     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 307     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 308 \end{code}
 309
 310 %************************************************************************
 311 %*                                                                      *
 312 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 313 %*                                                                      *
 314 %************************************************************************
 315
 316 \begin{code}
 317 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 318
 319 zonkExpr (HsVar id)
 320   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 321     returnNF_Tc (HsVar id')
 322
 323 zonkExpr (HsIPVar id)
 324   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 325     returnNF_Tc (HsIPVar id')
 326
 327 zonkExpr (HsLit (HsRat f ty))
 328   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 329     returnNF_Tc (HsLit (HsRat f new_ty))
 330
 331 zonkExpr (HsLit (HsLitLit lit ty))
 332   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 333     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 334
 335 zonkExpr (HsLit lit)
 336   = returnNF_Tc (HsLit lit)
 337
 338 -- HsOverLit doesn't appear in typechecker output
 339
 340 zonkExpr (HsLam match)
 341   = zonkMatch match     `thenNF_Tc` \ new_match ->
 342     returnNF_Tc (HsLam new_match)
 343
 344 zonkExpr (HsApp e1 e2)
 345   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 346     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 347     returnNF_Tc (HsApp new_e1 new_e2)
 348
 349 zonkExpr (OpApp e1 op fixity e2)
 350   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 351     zonkExpr op `thenNF_Tc` \ new_op ->
 352     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 353     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 354
 355 zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
 356 zonkExpr (HsPar _)  = panic "zonkExpr: HsPar"
 357
 358 zonkExpr (SectionL expr op)
 359   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 360     zonkExpr op         `thenNF_Tc` \ new_op ->
 361     returnNF_Tc (SectionL new_expr new_op)
 362
 363 zonkExpr (SectionR op expr)
 364   = zonkExpr op         `thenNF_Tc` \ new_op ->
 365     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 366     returnNF_Tc (SectionR new_op new_expr)
 367
 368 zonkExpr (HsCase expr ms src_loc)
 369   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 370     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 371     returnNF_Tc (HsCase new_expr new_ms src_loc)
 372
 373 zonkExpr (HsIf e1 e2 e3 src_loc)
 374   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 375     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 376     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 377     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 378
 379 zonkExpr (HsLet binds expr)
 380   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 381     tcSetEnv new_env            $
 382     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 383     returnNF_Tc (HsLet new_binds new_expr)
 384
 385 zonkExpr (HsWith expr binds)
 386   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 387     tcExtendGlobalValEnv (map fst new_binds)    $
 388     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 389     returnNF_Tc (HsWith new_expr new_binds)
 390     where
 391         zonkIPBinds = mapNF_Tc zonkIPBind
 392         zonkIPBind (n, e) =
 393             zonkIdBndr n        `thenNF_Tc` \ n' ->
 394             zonkExpr e          `thenNF_Tc` \ e' ->
 395             returnNF_Tc (n', e')
 396
 397 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 398
 399 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 400   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 401     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 402     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 403     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 404     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 405     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 406                          new_ty src_loc)
 407
 408 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 409
 410 zonkExpr (ExplicitListOut ty exprs)
 411   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 412     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 413     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 414
 415 zonkExpr (ExplicitTuple exprs boxed)
 416   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 417     returnNF_Tc (ExplicitTuple new_exprs boxed)
 418
 419 zonkExpr (RecordConOut data_con con_expr rbinds)
 420   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 421     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 422     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 423
 424 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 425
 426 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 427   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 428     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 429     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 430     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 431     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 432
 433 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 434 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 435
 436 zonkExpr (ArithSeqOut expr info)
 437   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 438     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 439     returnNF_Tc (ArithSeqOut new_expr new_info)
 440
 441 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 442   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 443     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 444     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 445
 446 zonkExpr (HsSCC lbl expr)
 447   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 448     returnNF_Tc (HsSCC lbl new_expr)
 449
 450 zonkExpr (TyLam tyvars expr)
 451   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 452         -- No need to extend tyvar env; see AbsBinds
 453
 454     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 455     returnNF_Tc (TyLam new_tyvars new_expr)
 456
 457 zonkExpr (TyApp expr tys)
 458   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 459     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 460     returnNF_Tc (TyApp new_expr new_tys)
 461
 462 zonkExpr (DictLam dicts expr)
 463   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 464     tcExtendGlobalValEnv new_dicts      $
 465     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 466     returnNF_Tc (DictLam new_dicts new_expr)
 467
 468 zonkExpr (DictApp expr dicts)
 469   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 470     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 471     returnNF_Tc (DictApp new_expr new_dicts)
 472
 473
 474
 475 -------------------------------------------------------------------------
 476 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 477
 478 zonkArithSeq (From e)
 479   = zonkExpr e          `thenNF_Tc` \ new_e ->
 480     returnNF_Tc (From new_e)
 481
 482 zonkArithSeq (FromThen e1 e2)
 483   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 484     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 485     returnNF_Tc (FromThen new_e1 new_e2)
 486
 487 zonkArithSeq (FromTo e1 e2)
 488   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 489     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 490     returnNF_Tc (FromTo new_e1 new_e2)
 491
 492 zonkArithSeq (FromThenTo e1 e2 e3)
 493   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 494     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 495     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 496     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 497
 498 -------------------------------------------------------------------------
 499 zonkStmts :: [TcStmt]
 500           -> NF_TcM [TypecheckedStmt]
 501
 502 zonkStmts [] = returnNF_Tc []
 503
 504 zonkStmts (ParStmtOut bndrstmtss : stmts)
 505   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 506     let new_binders = concat new_bndrss in
 507     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 508     tcExtendGlobalValEnv new_binders    $
 509     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 510     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 511   where (bndrss, stmtss) = unzip bndrstmtss
 512
 513 zonkStmts [ReturnStmt expr]
 514   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 515     returnNF_Tc [ReturnStmt new_expr]
 516
 517 zonkStmts (ExprStmt expr locn : stmts)
 518   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 519     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 520     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 521
 522 zonkStmts (GuardStmt expr locn : stmts)
 523   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 524     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 525     returnNF_Tc (GuardStmt 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 (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 656    zonkIdOcc i  `thenNF_Tc` \ i' ->
 657    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv 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}