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    ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
  45                   ValueEnv, 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 \end{code}
  58
  59
  60 Type definitions
  61 ~~~~~~~~~~~~~~~~
  62
  63 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  64 All the types in @Tc...@ things have mutable type-variables in them for
  65 unification.
  66
  67 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  68 which have immutable type variables in them.
  69
  70 \begin{code}
  71 type TcHsBinds          = HsBinds TcId TcPat
  72 type TcMonoBinds        = MonoBinds TcId TcPat
  73 type TcDictBinds        = TcMonoBinds
  74 type TcPat              = OutPat TcId
  75 type TcExpr             = HsExpr TcId TcPat
  76 type TcGRHSs            = GRHSs TcId TcPat
  77 type TcGRHS             = GRHS TcId TcPat
  78 type TcMatch            = Match TcId TcPat
  79 type TcStmt             = Stmt TcId TcPat
  80 type TcArithSeqInfo     = ArithSeqInfo TcId TcPat
  81 type TcRecordBinds      = HsRecordBinds TcId TcPat
  82 type TcHsModule = HsModule TcId TcPat
  83
  84 type TcCoreExpr = Expr TcId
  85 type TcForeignExportDecl = ForeignDecl TcId
  86 type TcRuleDecl          = RuleDecl    TcId TcPat
  87
  88 type TypecheckedPat             = OutPat        Id
  89 type TypecheckedMonoBinds       = MonoBinds     Id TypecheckedPat
  90 type TypecheckedDictBinds       = TypecheckedMonoBinds
  91 type TypecheckedHsBinds         = HsBinds       Id TypecheckedPat
  92 type TypecheckedHsExpr          = HsExpr        Id TypecheckedPat
  93 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id TypecheckedPat
  94 type TypecheckedStmt            = Stmt          Id TypecheckedPat
  95 type TypecheckedMatch           = Match         Id TypecheckedPat
  96 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
  97 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
  98 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
  99 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
 100 type TypecheckedForeignDecl     = ForeignDecl Id
 101 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 102 \end{code}
 103
 104 \begin{code}
 105 mkHsTyApp expr []  = expr
 106 mkHsTyApp expr tys = TyApp expr tys
 107
 108 mkHsDictApp expr []      = expr
 109 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 110
 111 mkHsTyLam []     expr = expr
 112 mkHsTyLam tyvars expr = TyLam tyvars expr
 113
 114 mkHsDictLam []    expr = expr
 115 mkHsDictLam dicts expr = DictLam dicts expr
 116
 117 mkHsLet EmptyMonoBinds expr = expr
 118 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 119
 120 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 121
 122 idsToMonoBinds :: [Id] -> TcMonoBinds
 123 idsToMonoBinds ids
 124   = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
 125                     | id <- ids
 126                     ]
 127 \end{code}
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 This zonking pass runs over the bindings
 136
 137  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 138  b) convert unbound TcTyVar to Void
 139  c) convert each TcId to an Id by zonking its type
 140
 141 The type variables are converted by binding mutable tyvars to immutable ones
 142 and then zonking as normal.
 143
 144 The Ids are converted by binding them in the normal Tc envt; that
 145 way we maintain sharing; eg an Id is zonked at its binding site and they
 146 all occurrences of that Id point to the common zonked copy
 147
 148 It's all pretty boring stuff, because HsSyn is such a large type, and
 149 the environment manipulation is tiresome.
 150
 151 \begin{code}
 152 -- zonkId is used *during* typechecking just to zonk the Id's type
 153 zonkId :: TcId -> NF_TcM s TcId
 154 zonkId id
 155   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 156     returnNF_Tc (setIdType id ty')
 157
 158 -- zonkIdBndr is used *after* typechecking to get the Id's type
 159 -- to its final form.  The TyVarEnv give
 160 zonkIdBndr :: TcId -> NF_TcM s Id
 161 zonkIdBndr id
 162   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 163     returnNF_Tc (setIdType id ty')
 164
 165 zonkIdOcc :: TcId -> NF_TcM s Id
 166 zonkIdOcc id
 167   | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
 168         -- The omitIfaceSigForId thing may look wierd but it's quite
 169         -- sensible really.  We're avoiding looking up superclass selectors
 170         -- and constructors; zonking them is a no-op anyway, and the
 171         -- superclass selectors aren't in the environment anyway.
 172   = returnNF_Tc id
 173   | otherwise
 174   = tcLookupValueMaybe (idName id)      `thenNF_Tc` \ maybe_id' ->
 175     let
 176         new_id = case maybe_id' of
 177                     Just id' -> id'
 178                     Nothing  -> pprTrace "zonkIdOcc: " (ppr id) id
 179     in
 180     returnNF_Tc new_id
 181 \end{code}
 182
 183
 184 \begin{code}
 185 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
 186 zonkTopBinds binds      -- Top level is implicitly recursive
 187   = fixNF_Tc (\ ~(_, new_ids) ->
 188         tcExtendGlobalValEnv (bagToList new_ids)        $
 189         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 190         tcGetValueEnv                           `thenNF_Tc` \ env ->
 191         returnNF_Tc ((binds', env), new_ids)
 192     )                                   `thenNF_Tc` \ (stuff, _) ->
 193     returnNF_Tc stuff
 194
 195 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 196
 197 zonkBinds binds
 198   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 199                           returnNF_Tc (binds', env))
 200   where
 201     -- go :: TcHsBinds
 202     --    -> (TypecheckedHsBinds
 203     --        -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 204     --       )
 205     --    -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 206
 207     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 208                                         go b2   $ \ b2' ->
 209                                         thing_inside (b1' `ThenBinds` b2')
 210
 211     go EmptyBinds thing_inside = thing_inside EmptyBinds
 212
 213     go (MonoBind bind sigs is_rec) thing_inside
 214           = ASSERT( null sigs )
 215             fixNF_Tc (\ ~(_, new_ids) ->
 216                 tcExtendGlobalValEnv (bagToList new_ids)        $
 217                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 218                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 219                 returnNF_Tc (stuff, new_ids)
 220             )                                                   `thenNF_Tc` \ (stuff, _) ->
 221            returnNF_Tc stuff
 222 \end{code}
 223
 224 \begin{code}
 225 -------------------------------------------------------------------------
 226 zonkMonoBinds :: TcMonoBinds
 227               -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
 228
 229 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 230
 231 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 232   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 233     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 234     returnNF_Tc (b1' `AndMonoBinds` b2',
 235                  ids1 `unionBags` ids2)
 236
 237 zonkMonoBinds (PatMonoBind pat grhss locn)
 238   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 239     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 240     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 241
 242 zonkMonoBinds (VarMonoBind var expr)
 243   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 244     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 245     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 246
 247 zonkMonoBinds (CoreMonoBind var core_expr)
 248   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 249     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 250
 251 zonkMonoBinds (FunMonoBind var inf ms locn)
 252   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 253     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 254     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 255
 256
 257 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 258   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 259         -- No need to extend tyvar env: the effects are
 260         -- propagated through binding the tyvars themselves
 261
 262     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 263     tcExtendGlobalValEnv new_dicts                      $
 264
 265     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 266         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 267         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 268         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 269         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 270     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 271     let
 272             new_globals = listToBag [global | (_, global, local) <- new_exports]
 273     in
 274     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 275                  new_globals)
 276   where
 277     zonkExport (tyvars, global, local)
 278         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 279                 -- This isn't the binding occurrence of these tyvars
 280                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 281           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 282           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 283           returnNF_Tc (new_tyvars, new_global, new_local)
 284 \end{code}
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
 294
 295 zonkMatch (Match _ pats _ grhss)
 296   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 297     tcExtendGlobalValEnv (bagToList new_ids)    $
 298     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 299     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 300
 301 -------------------------------------------------------------------------
 302 zonkGRHSs :: TcGRHSs
 303           -> NF_TcM s TypecheckedGRHSs
 304
 305 zonkGRHSs (GRHSs grhss binds (Just ty))
 306   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 307     tcSetEnv new_env $
 308     let
 309         zonk_grhs (GRHS guarded locn)
 310           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 311             returnNF_Tc (GRHS new_guarded locn)
 312     in
 313     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 314     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 315     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 316 \end{code}
 317
 318 %************************************************************************
 319 %*                                                                      *
 320 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 321 %*                                                                      *
 322 %************************************************************************
 323
 324 \begin{code}
 325 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
 326
 327 zonkExpr (HsVar id)
 328   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 329     returnNF_Tc (HsVar id')
 330
 331 zonkExpr (HsIPVar id)
 332   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 333     returnNF_Tc (HsIPVar id')
 334
 335 zonkExpr (HsLit (HsRat f ty))
 336   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 337     returnNF_Tc (HsLit (HsRat f new_ty))
 338
 339 zonkExpr (HsLit (HsLitLit lit ty))
 340   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 341     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 342
 343 zonkExpr (HsLit lit)
 344   = returnNF_Tc (HsLit lit)
 345
 346 -- HsOverLit doesn't appear in typechecker output
 347
 348 zonkExpr (HsLam match)
 349   = zonkMatch match     `thenNF_Tc` \ new_match ->
 350     returnNF_Tc (HsLam new_match)
 351
 352 zonkExpr (HsApp e1 e2)
 353   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 354     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 355     returnNF_Tc (HsApp new_e1 new_e2)
 356
 357 zonkExpr (OpApp e1 op fixity e2)
 358   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 359     zonkExpr op `thenNF_Tc` \ new_op ->
 360     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 361     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 362
 363 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 364 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 365
 366 zonkExpr (SectionL expr op)
 367   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 368     zonkExpr op         `thenNF_Tc` \ new_op ->
 369     returnNF_Tc (SectionL new_expr new_op)
 370
 371 zonkExpr (SectionR op expr)
 372   = zonkExpr op         `thenNF_Tc` \ new_op ->
 373     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 374     returnNF_Tc (SectionR new_op new_expr)
 375
 376 zonkExpr (HsCase expr ms src_loc)
 377   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 378     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 379     returnNF_Tc (HsCase new_expr new_ms src_loc)
 380
 381 zonkExpr (HsIf e1 e2 e3 src_loc)
 382   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 383     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 384     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 385     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 386
 387 zonkExpr (HsLet binds expr)
 388   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 389     tcSetEnv new_env            $
 390     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 391     returnNF_Tc (HsLet new_binds new_expr)
 392
 393 zonkExpr (HsWith expr binds)
 394   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 395     tcExtendGlobalValEnv (map fst new_binds)    $
 396     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 397     returnNF_Tc (HsWith new_expr new_binds)
 398     where
 399         zonkIPBinds = mapNF_Tc zonkIPBind
 400         zonkIPBind (n, e) =
 401             zonkIdBndr n        `thenNF_Tc` \ n' ->
 402             zonkExpr e          `thenNF_Tc` \ e' ->
 403             returnNF_Tc (n', e')
 404
 405 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 406
 407 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 408   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 409     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 410     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 411     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 412     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 413     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 414                          new_ty src_loc)
 415
 416 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 417
 418 zonkExpr (ExplicitListOut ty exprs)
 419   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 420     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 421     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 422
 423 zonkExpr (ExplicitTuple exprs boxed)
 424   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 425     returnNF_Tc (ExplicitTuple new_exprs boxed)
 426
 427 zonkExpr (RecordConOut data_con con_expr rbinds)
 428   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 429     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 430     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 431
 432 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 433
 434 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 435   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 436     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 437     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 438     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 439     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 440
 441 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 442 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 443
 444 zonkExpr (ArithSeqOut expr info)
 445   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 446     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 447     returnNF_Tc (ArithSeqOut new_expr new_info)
 448
 449 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 450   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 451     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 452     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 453
 454 zonkExpr (HsSCC lbl expr)
 455   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 456     returnNF_Tc (HsSCC lbl new_expr)
 457
 458 zonkExpr (TyLam tyvars expr)
 459   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 460         -- No need to extend tyvar env; see AbsBinds
 461
 462     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 463     returnNF_Tc (TyLam new_tyvars new_expr)
 464
 465 zonkExpr (TyApp expr tys)
 466   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 467     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 468     returnNF_Tc (TyApp new_expr new_tys)
 469
 470 zonkExpr (DictLam dicts expr)
 471   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 472     tcExtendGlobalValEnv new_dicts      $
 473     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 474     returnNF_Tc (DictLam new_dicts new_expr)
 475
 476 zonkExpr (DictApp expr dicts)
 477   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 478     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 479     returnNF_Tc (DictApp new_expr new_dicts)
 480
 481
 482
 483 -------------------------------------------------------------------------
 484 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
 485
 486 zonkArithSeq (From e)
 487   = zonkExpr e          `thenNF_Tc` \ new_e ->
 488     returnNF_Tc (From new_e)
 489
 490 zonkArithSeq (FromThen e1 e2)
 491   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 492     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 493     returnNF_Tc (FromThen new_e1 new_e2)
 494
 495 zonkArithSeq (FromTo e1 e2)
 496   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 497     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 498     returnNF_Tc (FromTo new_e1 new_e2)
 499
 500 zonkArithSeq (FromThenTo e1 e2 e3)
 501   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 502     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 503     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 504     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 505
 506 -------------------------------------------------------------------------
 507 zonkStmts :: [TcStmt]
 508           -> NF_TcM s [TypecheckedStmt]
 509
 510 zonkStmts [] = returnNF_Tc []
 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 s 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 s (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 s [TypecheckedForeignDecl]
 651 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 652
 653 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (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 s [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}