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, zonkTcTyVarBndr, zonkTcType
  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         = mapNF_Tc zonkTcTyVarBndr tyvars       `thenNF_Tc` \ new_tyvars ->
 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 s 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 s 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 s 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 _) = panic "zonkExpr:HsLit"
 335
 336 zonkExpr (HsLitOut lit ty)
 337   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 338     returnNF_Tc (HsLitOut lit new_ty)
 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   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 387     zonkIPBinds binds           `thenNF_Tc` \ new_binds ->
 388     returnNF_Tc (HsWith new_expr new_binds)
 389     where
 390         zonkIPBinds = mapNF_Tc zonkIPBind
 391         zonkIPBind (n, e) =
 392             zonkExpr e          `thenNF_Tc` \ e' ->
 393             returnNF_Tc (n, e')
 394
 395 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 396
 397 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 398   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 399     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 400     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 401     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 402     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 403     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 404                          new_ty src_loc)
 405
 406 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 407
 408 zonkExpr (ExplicitListOut ty exprs)
 409   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 410     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 411     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 412
 413 zonkExpr (ExplicitTuple exprs boxed)
 414   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 415     returnNF_Tc (ExplicitTuple new_exprs boxed)
 416
 417 zonkExpr (RecordConOut data_con con_expr rbinds)
 418   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 419     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 420     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 421
 422 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 423
 424 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 425   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 426     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 427     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 428     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 429     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 430
 431 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 432 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 433
 434 zonkExpr (ArithSeqOut expr info)
 435   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 436     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 437     returnNF_Tc (ArithSeqOut new_expr new_info)
 438
 439 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 440   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 441     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 442     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 443
 444 zonkExpr (HsSCC lbl expr)
 445   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 446     returnNF_Tc (HsSCC lbl new_expr)
 447
 448 zonkExpr (TyLam tyvars expr)
 449   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 450         -- No need to extend tyvar env; see AbsBinds
 451
 452     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 453     returnNF_Tc (TyLam new_tyvars new_expr)
 454
 455 zonkExpr (TyApp expr tys)
 456   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 457     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 458     returnNF_Tc (TyApp new_expr new_tys)
 459
 460 zonkExpr (DictLam dicts expr)
 461   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 462     tcExtendGlobalValEnv new_dicts      $
 463     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 464     returnNF_Tc (DictLam new_dicts new_expr)
 465
 466 zonkExpr (DictApp expr dicts)
 467   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 468     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 469     returnNF_Tc (DictApp new_expr new_dicts)
 470
 471
 472
 473 -------------------------------------------------------------------------
 474 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
 475
 476 zonkArithSeq (From e)
 477   = zonkExpr e          `thenNF_Tc` \ new_e ->
 478     returnNF_Tc (From new_e)
 479
 480 zonkArithSeq (FromThen e1 e2)
 481   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 482     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 483     returnNF_Tc (FromThen new_e1 new_e2)
 484
 485 zonkArithSeq (FromTo e1 e2)
 486   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 487     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 488     returnNF_Tc (FromTo new_e1 new_e2)
 489
 490 zonkArithSeq (FromThenTo e1 e2 e3)
 491   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 492     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 493     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 494     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 495
 496 -------------------------------------------------------------------------
 497 zonkStmts :: [TcStmt]
 498           -> NF_TcM s [TypecheckedStmt]
 499
 500 zonkStmts [] = returnNF_Tc []
 501
 502 zonkStmts [ReturnStmt expr]
 503   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 504     returnNF_Tc [ReturnStmt new_expr]
 505
 506 zonkStmts (ExprStmt expr locn : stmts)
 507   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 508     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 509     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 510
 511 zonkStmts (GuardStmt expr locn : stmts)
 512   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 513     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 514     returnNF_Tc (GuardStmt new_expr locn : new_stmts)
 515
 516 zonkStmts (LetStmt binds : stmts)
 517   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 518     tcSetEnv new_env            $
 519     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 520     returnNF_Tc (LetStmt new_binds : new_stmts)
 521
 522 zonkStmts (BindStmt pat expr locn : stmts)
 523   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 524     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 525     tcExtendGlobalValEnv (bagToList new_ids)    $
 526     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 527     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 528
 529
 530
 531 -------------------------------------------------------------------------
 532 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
 533
 534 zonkRbinds rbinds
 535   = mapNF_Tc zonk_rbind rbinds
 536   where
 537     zonk_rbind (field, expr, pun)
 538       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 539         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 540         returnNF_Tc (new_field, new_expr, pun)
 541 \end{code}
 542
 543 %************************************************************************
 544 %*                                                                      *
 545 \subsection[BackSubst-Pats]{Patterns}
 546 %*                                                                      *
 547 %************************************************************************
 548
 549 \begin{code}
 550 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
 551
 552 zonkPat (WildPat ty)
 553   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 554     returnNF_Tc (WildPat new_ty, emptyBag)
 555
 556 zonkPat (VarPat v)
 557   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 558     returnNF_Tc (VarPat new_v, unitBag new_v)
 559
 560 zonkPat (LazyPat pat)
 561   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 562     returnNF_Tc (LazyPat new_pat, ids)
 563
 564 zonkPat (AsPat n pat)
 565   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 566     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 567     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 568
 569 zonkPat (ListPat ty pats)
 570   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 571     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 572     returnNF_Tc (ListPat new_ty new_pats, ids)
 573
 574 zonkPat (TuplePat pats boxed)
 575   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 576     returnNF_Tc (TuplePat new_pats boxed, ids)
 577
 578 zonkPat (ConPat n ty tvs dicts pats)
 579   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 580     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 581     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 582     tcExtendGlobalValEnv new_dicts      $
 583     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 584     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 585                  listToBag new_dicts `unionBags` ids)
 586
 587 zonkPat (RecPat n ty tvs dicts rpats)
 588   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 589     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 590     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 591     tcExtendGlobalValEnv new_dicts      $
 592     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 593     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 594                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 595   where
 596     zonk_rpat (f, pat, pun)
 597       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 598         returnNF_Tc ((f, new_pat, pun), ids)
 599
 600 zonkPat (LitPat lit ty)
 601   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 602     returnNF_Tc (LitPat lit new_ty, emptyBag)
 603
 604 zonkPat (NPat lit ty expr)
 605   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 606     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 607     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 608
 609 zonkPat (NPlusKPat n k ty e1 e2)
 610   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 611     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 612     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 613     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 614     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 615
 616 zonkPat (DictPat ds ms)
 617   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 618     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 619     returnNF_Tc (DictPat new_ds new_ms,
 620                  listToBag new_ds `unionBags` listToBag new_ms)
 621
 622
 623 zonkPats []
 624   = returnNF_Tc ([], emptyBag)
 625
 626 zonkPats (pat:pats)
 627   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 628     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 629     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 630 \end{code}
 631
 632 %************************************************************************
 633 %*                                                                      *
 634 \subsection[BackSubst-Foreign]{Foreign exports}
 635 %*                                                                      *
 636 %************************************************************************
 637
 638
 639 \begin{code}
 640 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
 641 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 642
 643 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
 644 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 645    zonkIdOcc i  `thenNF_Tc` \ i' ->
 646    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 647 \end{code}
 648
 649 \begin{code}
 650 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
 651 zonkRules rs = mapNF_Tc zonkRule rs
 652
 653 zonkRule (HsRule name tyvars vars lhs rhs loc)
 654   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 655     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 656     tcExtendGlobalValEnv new_bndrs                      $
 657     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 658     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 659     returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 660         -- I hate this map RuleBndr stuff
 661
 662 zonkRule (IfaceRuleOut fun rule)
 663   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 664     returnNF_Tc (IfaceRuleOut fun' rule)
 665 \end{code}