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, isLocalId, idUnfolding, setIdType, isIP, Id )
  43 import DataCon  ( dataConWrapId )
  44 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
  45                   TcEnv, TcId, tcInstId
  46                 )
  47
  48 import TcMonad
  49 import TcType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
  50                 )
  51 import CoreSyn  ( Expr )
  52 import CoreUnfold( unfoldingTemplate )
  53 import BasicTypes ( RecFlag(..) )
  54 import Bag
  55 import Outputable
  56 import HscTypes ( TyThing(..) )
  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 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 Id
 161 zonkIdBndr id
 162   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 163     returnNF_Tc (setIdType id ty')
 164
 165 zonkIdOcc :: TcId -> NF_TcM Id
 166 zonkIdOcc id
 167   | not (isLocalId id) || isIP id
 168         -- We're avoiding looking up superclass selectors
 169         -- and constructors; zonking them is a no-op anyway, and the
 170         -- superclass selectors aren't in the environment anyway.
 171   = returnNF_Tc id
 172   | otherwise
 173   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 174     let
 175         new_id = case maybe_id' of
 176                     Just (AnId id') -> id'
 177                     other  -> pprTrace "zonkIdOcc:" (ppr id) id
 178     in
 179     returnNF_Tc new_id
 180 \end{code}
 181
 182
 183 \begin{code}
 184 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 185 zonkTopBinds binds      -- Top level is implicitly recursive
 186   = fixNF_Tc (\ ~(_, new_ids) ->
 187         tcExtendGlobalValEnv (bagToList new_ids)        $
 188         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 189         tcGetEnv                                `thenNF_Tc` \ env ->
 190         returnNF_Tc ((binds', env), new_ids)
 191     )                                   `thenNF_Tc` \ (stuff, _) ->
 192     returnNF_Tc stuff
 193
 194 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 195
 196 zonkBinds binds
 197   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 198                           returnNF_Tc (binds', env))
 199   where
 200     -- go :: TcHsBinds
 201     --    -> (TypecheckedHsBinds
 202     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 203     --       )
 204     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 205
 206     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 207                                         go b2   $ \ b2' ->
 208                                         thing_inside (b1' `ThenBinds` b2')
 209
 210     go EmptyBinds thing_inside = thing_inside EmptyBinds
 211
 212     go (MonoBind bind sigs is_rec) thing_inside
 213           = ASSERT( null sigs )
 214             fixNF_Tc (\ ~(_, new_ids) ->
 215                 tcExtendGlobalValEnv (bagToList new_ids)        $
 216                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 217                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 218                 returnNF_Tc (stuff, new_ids)
 219             )                                                   `thenNF_Tc` \ (stuff, _) ->
 220            returnNF_Tc stuff
 221 \end{code}
 222
 223 \begin{code}
 224 -------------------------------------------------------------------------
 225 zonkMonoBinds :: TcMonoBinds
 226               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 227
 228 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 229
 230 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 231   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 232     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 233     returnNF_Tc (b1' `AndMonoBinds` b2',
 234                  ids1 `unionBags` ids2)
 235
 236 zonkMonoBinds (PatMonoBind pat grhss locn)
 237   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 238     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 239     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 240
 241 zonkMonoBinds (VarMonoBind var expr)
 242   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 243     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 244     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 245
 246 zonkMonoBinds (CoreMonoBind var core_expr)
 247   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 248     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 249
 250 zonkMonoBinds (FunMonoBind var inf ms locn)
 251   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 252     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 253     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 254
 255
 256 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 257   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 258         -- No need to extend tyvar env: the effects are
 259         -- propagated through binding the tyvars themselves
 260
 261     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 262     tcExtendGlobalValEnv new_dicts                      $
 263
 264     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 265         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 266         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 267         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 268         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 269     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 270     let
 271             new_globals = listToBag [global | (_, global, local) <- new_exports]
 272     in
 273     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 274                  new_globals)
 275   where
 276     zonkExport (tyvars, global, local)
 277         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 278                 -- This isn't the binding occurrence of these tyvars
 279                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 280           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 281           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 282           returnNF_Tc (new_tyvars, new_global, new_local)
 283 \end{code}
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 293
 294 zonkMatch (Match _ pats _ grhss)
 295   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 296     tcExtendGlobalValEnv (bagToList new_ids)    $
 297     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 298     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 299
 300 -------------------------------------------------------------------------
 301 zonkGRHSs :: TcGRHSs
 302           -> NF_TcM TypecheckedGRHSs
 303
 304 zonkGRHSs (GRHSs grhss binds (Just ty))
 305   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 306     tcSetEnv new_env $
 307     let
 308         zonk_grhs (GRHS guarded locn)
 309           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 310             returnNF_Tc (GRHS new_guarded locn)
 311     in
 312     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 313     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 314     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 315 \end{code}
 316
 317 %************************************************************************
 318 %*                                                                      *
 319 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 320 %*                                                                      *
 321 %************************************************************************
 322
 323 \begin{code}
 324 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 325
 326 zonkExpr (HsVar id)
 327   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 328     returnNF_Tc (HsVar id')
 329
 330 zonkExpr (HsIPVar id)
 331   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 332     returnNF_Tc (HsIPVar id')
 333
 334 zonkExpr (HsLit (HsRat f ty))
 335   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 336     returnNF_Tc (HsLit (HsRat f new_ty))
 337
 338 zonkExpr (HsLit (HsLitLit lit ty))
 339   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 340     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 341
 342 zonkExpr (HsLit lit)
 343   = returnNF_Tc (HsLit lit)
 344
 345 -- HsOverLit doesn't appear in typechecker output
 346
 347 zonkExpr (HsLam match)
 348   = zonkMatch match     `thenNF_Tc` \ new_match ->
 349     returnNF_Tc (HsLam new_match)
 350
 351 zonkExpr (HsApp e1 e2)
 352   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 353     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 354     returnNF_Tc (HsApp new_e1 new_e2)
 355
 356 zonkExpr (OpApp e1 op fixity e2)
 357   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 358     zonkExpr op `thenNF_Tc` \ new_op ->
 359     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 360     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 361
 362 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 363 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 364
 365 zonkExpr (SectionL expr op)
 366   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 367     zonkExpr op         `thenNF_Tc` \ new_op ->
 368     returnNF_Tc (SectionL new_expr new_op)
 369
 370 zonkExpr (SectionR op expr)
 371   = zonkExpr op         `thenNF_Tc` \ new_op ->
 372     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 373     returnNF_Tc (SectionR new_op new_expr)
 374
 375 zonkExpr (HsCase expr ms src_loc)
 376   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 377     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 378     returnNF_Tc (HsCase new_expr new_ms src_loc)
 379
 380 zonkExpr (HsIf e1 e2 e3 src_loc)
 381   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 382     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 383     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 384     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 385
 386 zonkExpr (HsLet binds expr)
 387   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 388     tcSetEnv new_env            $
 389     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 390     returnNF_Tc (HsLet new_binds new_expr)
 391
 392 zonkExpr (HsWith expr binds)
 393   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 394     tcExtendGlobalValEnv (map fst new_binds)    $
 395     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 396     returnNF_Tc (HsWith new_expr new_binds)
 397     where
 398         zonkIPBinds = mapNF_Tc zonkIPBind
 399         zonkIPBind (n, e) =
 400             zonkIdBndr n        `thenNF_Tc` \ n' ->
 401             zonkExpr e          `thenNF_Tc` \ e' ->
 402             returnNF_Tc (n', e')
 403
 404 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 405
 406 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 407   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 408     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 409     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 410     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 411     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 412     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 413                          new_ty src_loc)
 414
 415 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 416
 417 zonkExpr (ExplicitListOut ty exprs)
 418   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 419     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 420     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 421
 422 zonkExpr (ExplicitTuple exprs boxed)
 423   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 424     returnNF_Tc (ExplicitTuple new_exprs boxed)
 425
 426 zonkExpr (RecordConOut data_con con_expr rbinds)
 427   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 428     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 429     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 430
 431 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 432
 433 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 434   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 435     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 436     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 437     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 438     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 439
 440 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 441 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 442
 443 zonkExpr (ArithSeqOut expr info)
 444   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 445     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 446     returnNF_Tc (ArithSeqOut new_expr new_info)
 447
 448 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 449   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 450     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 451     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 452
 453 zonkExpr (HsSCC lbl expr)
 454   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 455     returnNF_Tc (HsSCC lbl new_expr)
 456
 457 zonkExpr (TyLam tyvars expr)
 458   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 459         -- No need to extend tyvar env; see AbsBinds
 460
 461     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 462     returnNF_Tc (TyLam new_tyvars new_expr)
 463
 464 zonkExpr (TyApp expr tys)
 465   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 466     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 467     returnNF_Tc (TyApp new_expr new_tys)
 468
 469 zonkExpr (DictLam dicts expr)
 470   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 471     tcExtendGlobalValEnv new_dicts      $
 472     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 473     returnNF_Tc (DictLam new_dicts new_expr)
 474
 475 zonkExpr (DictApp expr dicts)
 476   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 477     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 478     returnNF_Tc (DictApp new_expr new_dicts)
 479
 480
 481
 482 -------------------------------------------------------------------------
 483 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 484
 485 zonkArithSeq (From e)
 486   = zonkExpr e          `thenNF_Tc` \ new_e ->
 487     returnNF_Tc (From new_e)
 488
 489 zonkArithSeq (FromThen e1 e2)
 490   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 491     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 492     returnNF_Tc (FromThen new_e1 new_e2)
 493
 494 zonkArithSeq (FromTo e1 e2)
 495   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 496     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 497     returnNF_Tc (FromTo new_e1 new_e2)
 498
 499 zonkArithSeq (FromThenTo e1 e2 e3)
 500   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 501     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 502     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 503     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 504
 505 -------------------------------------------------------------------------
 506 zonkStmts :: [TcStmt]
 507           -> NF_TcM [TypecheckedStmt]
 508
 509 zonkStmts [] = returnNF_Tc []
 510
 511 zonkStmts (ParStmtOut bndrstmtss : stmts)
 512   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 513     let new_binders = concat new_bndrss in
 514     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 515     tcExtendGlobalValEnv new_binders    $
 516     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 517     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 518   where (bndrss, stmtss) = unzip bndrstmtss
 519
 520 zonkStmts [ReturnStmt expr]
 521   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 522     returnNF_Tc [ReturnStmt new_expr]
 523
 524 zonkStmts (ExprStmt expr locn : stmts)
 525   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 526     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 527     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 528
 529 zonkStmts (GuardStmt expr locn : stmts)
 530   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 531     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 532     returnNF_Tc (GuardStmt new_expr locn : new_stmts)
 533
 534 zonkStmts (LetStmt binds : stmts)
 535   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 536     tcSetEnv new_env            $
 537     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 538     returnNF_Tc (LetStmt new_binds : new_stmts)
 539
 540 zonkStmts (BindStmt pat expr locn : stmts)
 541   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 542     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 543     tcExtendGlobalValEnv (bagToList new_ids)    $
 544     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 545     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 546
 547
 548
 549 -------------------------------------------------------------------------
 550 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 551
 552 zonkRbinds rbinds
 553   = mapNF_Tc zonk_rbind rbinds
 554   where
 555     zonk_rbind (field, expr, pun)
 556       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 557         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 558         returnNF_Tc (new_field, new_expr, pun)
 559 \end{code}
 560
 561 %************************************************************************
 562 %*                                                                      *
 563 \subsection[BackSubst-Pats]{Patterns}
 564 %*                                                                      *
 565 %************************************************************************
 566
 567 \begin{code}
 568 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 569
 570 zonkPat (WildPat ty)
 571   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 572     returnNF_Tc (WildPat new_ty, emptyBag)
 573
 574 zonkPat (VarPat v)
 575   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 576     returnNF_Tc (VarPat new_v, unitBag new_v)
 577
 578 zonkPat (LazyPat pat)
 579   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 580     returnNF_Tc (LazyPat new_pat, ids)
 581
 582 zonkPat (AsPat n pat)
 583   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 584     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 585     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 586
 587 zonkPat (ListPat ty pats)
 588   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 589     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 590     returnNF_Tc (ListPat new_ty new_pats, ids)
 591
 592 zonkPat (TuplePat pats boxed)
 593   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 594     returnNF_Tc (TuplePat new_pats boxed, ids)
 595
 596 zonkPat (ConPat n ty tvs dicts pats)
 597   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 598     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 599     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 600     tcExtendGlobalValEnv new_dicts      $
 601     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 602     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 603                  listToBag new_dicts `unionBags` ids)
 604
 605 zonkPat (RecPat n ty tvs dicts rpats)
 606   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 607     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 608     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 609     tcExtendGlobalValEnv new_dicts      $
 610     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 611     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 612                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 613   where
 614     zonk_rpat (f, pat, pun)
 615       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 616         returnNF_Tc ((f, new_pat, pun), ids)
 617
 618 zonkPat (LitPat lit ty)
 619   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 620     returnNF_Tc (LitPat lit new_ty, emptyBag)
 621
 622 zonkPat (NPat lit ty expr)
 623   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 624     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 625     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 626
 627 zonkPat (NPlusKPat n k ty e1 e2)
 628   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 629     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 630     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 631     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 632     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 633
 634 zonkPat (DictPat ds ms)
 635   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 636     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 637     returnNF_Tc (DictPat new_ds new_ms,
 638                  listToBag new_ds `unionBags` listToBag new_ms)
 639
 640
 641 zonkPats []
 642   = returnNF_Tc ([], emptyBag)
 643
 644 zonkPats (pat:pats)
 645   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 646     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 647     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 648 \end{code}
 649
 650 %************************************************************************
 651 %*                                                                      *
 652 \subsection[BackSubst-Foreign]{Foreign exports}
 653 %*                                                                      *
 654 %************************************************************************
 655
 656
 657 \begin{code}
 658 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 659 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 660
 661 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 662 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 663    zonkIdOcc i  `thenNF_Tc` \ i' ->
 664    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 665 \end{code}
 666
 667 \begin{code}
 668 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 669 zonkRules rs = mapNF_Tc zonkRule rs
 670
 671 zonkRule (HsRule name tyvars vars lhs rhs loc)
 672   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 673     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 674     tcExtendGlobalValEnv new_bndrs                      $
 675     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 676     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 677     returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 678         -- I hate this map RuleBndr stuff
 679
 680 zonkRule (IfaceRuleOut fun rule)
 681   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 682     returnNF_Tc (IfaceRuleOut fun' rule)
 683 \end{code}