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