ghc/compiler/typecheck/TcHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
   5
   6 This module is an extension of @HsSyn@ syntax, for use in the type
   7 checker.
   8
   9 \begin{code}
  10 module TcHsSyn (
  11         TcMonoBinds, TcHsBinds, TcPat,
  12         TcExpr, TcGRHSs, TcGRHS, TcMatch,
  13         TcStmt, TcArithSeqInfo, TcRecordBinds,
  14         TcHsModule, TcCoreExpr, TcDictBinds,
  15         TcForeignExportDecl,
  16
  17         TypecheckedHsBinds, TypecheckedRuleDecl,
  18         TypecheckedMonoBinds, TypecheckedPat,
  19         TypecheckedHsExpr, TypecheckedArithSeqInfo,
  20         TypecheckedStmt, TypecheckedForeignDecl,
  21         TypecheckedMatch, TypecheckedHsModule,
  22         TypecheckedGRHSs, TypecheckedGRHS,
  23         TypecheckedRecordBinds, TypecheckedDictBinds,
  24
  25         mkHsTyApp, mkHsDictApp, mkHsConApp,
  26         mkHsTyLam, mkHsDictLam, mkHsLet,
  27
  28         -- re-exported from TcEnv
  29         TcId,
  30
  31         zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
  32         zonkForeignExports, zonkRules
  33   ) where
  34
  35 #include "HsVersions.h"
  36
  37 -- friends:
  38 import HsSyn    -- oodles of it
  39
  40 -- others:
  41 import Id       ( idName, idType, isLocalId, setIdType, Id )
  42 import DataCon  ( dataConWrapId )
  43 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
  44                   TcEnv, TcId
  45                 )
  46
  47 import TcMonad
  48 import TcType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
  49                 )
  50 import CoreSyn  ( Expr )
  51 import BasicTypes ( RecFlag(..) )
  52 import Bag
  53 import Outputable
  54 import HscTypes ( TyThing(..) )
  55 \end{code}
  56
  57
  58 Type definitions
  59 ~~~~~~~~~~~~~~~~
  60
  61 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  62 All the types in @Tc...@ things have mutable type-variables in them for
  63 unification.
  64
  65 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  66 which have immutable type variables in them.
  67
  68 \begin{code}
  69 type TcHsBinds          = HsBinds TcId TcPat
  70 type TcMonoBinds        = MonoBinds TcId TcPat
  71 type TcDictBinds        = TcMonoBinds
  72 type TcPat              = OutPat TcId
  73 type TcExpr             = HsExpr TcId TcPat
  74 type TcGRHSs            = GRHSs TcId TcPat
  75 type TcGRHS             = GRHS TcId TcPat
  76 type TcMatch            = Match TcId TcPat
  77 type TcStmt             = Stmt TcId TcPat
  78 type TcArithSeqInfo     = ArithSeqInfo TcId TcPat
  79 type TcRecordBinds      = HsRecordBinds TcId TcPat
  80 type TcHsModule = HsModule TcId TcPat
  81
  82 type TcCoreExpr = Expr TcId
  83 type TcForeignExportDecl = ForeignDecl TcId
  84 type TcRuleDecl          = RuleDecl    TcId TcPat
  85
  86 type TypecheckedPat             = OutPat        Id
  87 type TypecheckedMonoBinds       = MonoBinds     Id TypecheckedPat
  88 type TypecheckedDictBinds       = TypecheckedMonoBinds
  89 type TypecheckedHsBinds         = HsBinds       Id TypecheckedPat
  90 type TypecheckedHsExpr          = HsExpr        Id TypecheckedPat
  91 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id TypecheckedPat
  92 type TypecheckedStmt            = Stmt          Id TypecheckedPat
  93 type TypecheckedMatch           = Match         Id TypecheckedPat
  94 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
  95 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
  96 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
  97 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
  98 type TypecheckedForeignDecl     = ForeignDecl Id
  99 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 100 \end{code}
 101
 102 \begin{code}
 103 mkHsTyApp expr []  = expr
 104 mkHsTyApp expr tys = TyApp expr tys
 105
 106 mkHsDictApp expr []      = expr
 107 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 108
 109 mkHsTyLam []     expr = expr
 110 mkHsTyLam tyvars expr = TyLam tyvars expr
 111
 112 mkHsDictLam []    expr = expr
 113 mkHsDictLam dicts expr = DictLam dicts expr
 114
 115 mkHsLet EmptyMonoBinds expr = expr
 116 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 117
 118 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 119 \end{code}
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 This zonking pass runs over the bindings
 128
 129  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 130  b) convert unbound TcTyVar to Void
 131  c) convert each TcId to an Id by zonking its type
 132
 133 The type variables are converted by binding mutable tyvars to immutable ones
 134 and then zonking as normal.
 135
 136 The Ids are converted by binding them in the normal Tc envt; that
 137 way we maintain sharing; eg an Id is zonked at its binding site and they
 138 all occurrences of that Id point to the common zonked copy
 139
 140 It's all pretty boring stuff, because HsSyn is such a large type, and
 141 the environment manipulation is tiresome.
 142
 143 \begin{code}
 144 -- zonkId is used *during* typechecking just to zonk the Id's type
 145 zonkId :: TcId -> NF_TcM TcId
 146 zonkId id
 147   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 148     returnNF_Tc (setIdType id ty')
 149
 150 -- zonkIdBndr is used *after* typechecking to get the Id's type
 151 -- to its final form.  The TyVarEnv give
 152 zonkIdBndr :: TcId -> NF_TcM Id
 153 zonkIdBndr id
 154   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 155     returnNF_Tc (setIdType id ty')
 156
 157 zonkIdOcc :: TcId -> NF_TcM Id
 158 zonkIdOcc id
 159   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 160         -- We're even look up up superclass selectors and constructors;
 161         -- even though zonking them is a no-op anyway, and the
 162         -- superclass selectors aren't in the environment anyway.
 163         -- But we don't want to call isLocalId to find out whether
 164         -- it's a superclass selector (for example) because that looks
 165         -- at the IdInfo field, which in turn be in a knot because of
 166         -- the big knot in typecheckModule
 167     let
 168         new_id = case maybe_id' of
 169                     Just (AnId id') -> id'
 170                     other           -> id -- WARN( isLocalId id, ppr id ) id
 171                                         -- Oops: the warning can give a black hole
 172                                         -- because it looks at the idinfo
 173     in
 174     returnNF_Tc new_id
 175 \end{code}
 176
 177
 178 \begin{code}
 179 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 180 zonkTopBinds binds      -- Top level is implicitly recursive
 181   = fixNF_Tc (\ ~(_, new_ids) ->
 182         tcExtendGlobalValEnv (bagToList new_ids)        $
 183         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 184         tcGetEnv                                `thenNF_Tc` \ env ->
 185         returnNF_Tc ((binds', env), new_ids)
 186     )                                   `thenNF_Tc` \ (stuff, _) ->
 187     returnNF_Tc stuff
 188
 189 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 190
 191 zonkBinds binds
 192   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 193                           returnNF_Tc (binds', env))
 194   where
 195     -- go :: TcHsBinds
 196     --    -> (TypecheckedHsBinds
 197     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 198     --       )
 199     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 200
 201     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 202                                         go b2   $ \ b2' ->
 203                                         thing_inside (b1' `ThenBinds` b2')
 204
 205     go EmptyBinds thing_inside = thing_inside EmptyBinds
 206
 207     go (MonoBind bind sigs is_rec) thing_inside
 208           = ASSERT( null sigs )
 209             fixNF_Tc (\ ~(_, new_ids) ->
 210                 tcExtendGlobalValEnv (bagToList new_ids)        $
 211                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 212                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 213                 returnNF_Tc (stuff, new_ids)
 214             )                                                   `thenNF_Tc` \ (stuff, _) ->
 215            returnNF_Tc stuff
 216 \end{code}
 217
 218 \begin{code}
 219 -------------------------------------------------------------------------
 220 zonkMonoBinds :: TcMonoBinds
 221               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 222
 223 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 224
 225 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 226   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 227     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 228     returnNF_Tc (b1' `AndMonoBinds` b2',
 229                  ids1 `unionBags` ids2)
 230
 231 zonkMonoBinds (PatMonoBind pat grhss locn)
 232   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 233     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 234     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 235
 236 zonkMonoBinds (VarMonoBind var expr)
 237   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 238     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 239     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 240
 241 zonkMonoBinds (CoreMonoBind var core_expr)
 242   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 243     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 244
 245 zonkMonoBinds (FunMonoBind var inf ms locn)
 246   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 247     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 248     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 249
 250
 251 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 252   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 253         -- No need to extend tyvar env: the effects are
 254         -- propagated through binding the tyvars themselves
 255
 256     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 257     tcExtendGlobalValEnv new_dicts                      $
 258
 259     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 260         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 261         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 262         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 263         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 264     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 265     let
 266             new_globals = listToBag [global | (_, global, local) <- new_exports]
 267     in
 268     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 269                  new_globals)
 270   where
 271     zonkExport (tyvars, global, local)
 272         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 273                 -- This isn't the binding occurrence of these tyvars
 274                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 275           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 276           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 277           returnNF_Tc (new_tyvars, new_global, new_local)
 278 \end{code}
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 288
 289 zonkMatch (Match _ pats _ grhss)
 290   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 291     tcExtendGlobalValEnv (bagToList new_ids)    $
 292     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 293     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 294
 295 -------------------------------------------------------------------------
 296 zonkGRHSs :: TcGRHSs
 297           -> NF_TcM TypecheckedGRHSs
 298
 299 zonkGRHSs (GRHSs grhss binds (Just ty))
 300   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 301     tcSetEnv new_env $
 302     let
 303         zonk_grhs (GRHS guarded locn)
 304           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 305             returnNF_Tc (GRHS new_guarded locn)
 306     in
 307     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 308     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 309     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 320
 321 zonkExpr (HsVar id)
 322   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 323     returnNF_Tc (HsVar id')
 324
 325 zonkExpr (HsIPVar id)
 326   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 327     returnNF_Tc (HsIPVar id')
 328
 329 zonkExpr (HsLit (HsRat f ty))
 330   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 331     returnNF_Tc (HsLit (HsRat f new_ty))
 332
 333 zonkExpr (HsLit (HsLitLit lit ty))
 334   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 335     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 336
 337 zonkExpr (HsLit lit)
 338   = returnNF_Tc (HsLit lit)
 339
 340 -- HsOverLit doesn't appear in typechecker output
 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   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 389     tcExtendGlobalValEnv (map fst new_binds)    $
 390     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 391     returnNF_Tc (HsWith new_expr new_binds)
 392     where
 393         zonkIPBinds = mapNF_Tc zonkIPBind
 394         zonkIPBind (n, e) =
 395             zonkIdBndr n        `thenNF_Tc` \ n' ->
 396             zonkExpr e          `thenNF_Tc` \ e' ->
 397             returnNF_Tc (n', e')
 398
 399 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 400
 401 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 402   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 403     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 404     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 405     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 406     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 407     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 408                          new_ty src_loc)
 409
 410 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 411
 412 zonkExpr (ExplicitListOut ty exprs)
 413   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 414     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 415     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 416
 417 zonkExpr (ExplicitTuple exprs boxed)
 418   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 419     returnNF_Tc (ExplicitTuple new_exprs boxed)
 420
 421 zonkExpr (RecordConOut data_con con_expr rbinds)
 422   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 423     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 424     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 425
 426 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 427
 428 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 429   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 430     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 431     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 432     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 433     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 434
 435 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 436 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 437
 438 zonkExpr (ArithSeqOut expr info)
 439   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 440     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 441     returnNF_Tc (ArithSeqOut new_expr new_info)
 442
 443 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 444   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 445     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 446     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 447
 448 zonkExpr (HsSCC lbl expr)
 449   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 450     returnNF_Tc (HsSCC lbl new_expr)
 451
 452 zonkExpr (TyLam tyvars expr)
 453   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 454         -- No need to extend tyvar env; see AbsBinds
 455
 456     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 457     returnNF_Tc (TyLam new_tyvars new_expr)
 458
 459 zonkExpr (TyApp expr tys)
 460   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 461     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 462     returnNF_Tc (TyApp new_expr new_tys)
 463
 464 zonkExpr (DictLam dicts expr)
 465   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 466     tcExtendGlobalValEnv new_dicts      $
 467     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 468     returnNF_Tc (DictLam new_dicts new_expr)
 469
 470 zonkExpr (DictApp expr dicts)
 471   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 472     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 473     returnNF_Tc (DictApp new_expr new_dicts)
 474
 475
 476
 477 -------------------------------------------------------------------------
 478 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 479
 480 zonkArithSeq (From e)
 481   = zonkExpr e          `thenNF_Tc` \ new_e ->
 482     returnNF_Tc (From new_e)
 483
 484 zonkArithSeq (FromThen e1 e2)
 485   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 486     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 487     returnNF_Tc (FromThen new_e1 new_e2)
 488
 489 zonkArithSeq (FromTo e1 e2)
 490   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 491     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 492     returnNF_Tc (FromTo new_e1 new_e2)
 493
 494 zonkArithSeq (FromThenTo e1 e2 e3)
 495   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 496     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 497     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 498     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 499
 500 -------------------------------------------------------------------------
 501 zonkStmts :: [TcStmt]
 502           -> NF_TcM [TypecheckedStmt]
 503
 504 zonkStmts [] = returnNF_Tc []
 505
 506 zonkStmts (ParStmtOut bndrstmtss : stmts)
 507   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 508     let new_binders = concat new_bndrss in
 509     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 510     tcExtendGlobalValEnv new_binders    $
 511     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 512     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 513   where (bndrss, stmtss) = unzip bndrstmtss
 514
 515 zonkStmts (ExprStmt expr locn : stmts)
 516   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 517     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 518     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 519
 520 zonkStmts (LetStmt binds : stmts)
 521   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 522     tcSetEnv new_env            $
 523     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 524     returnNF_Tc (LetStmt new_binds : new_stmts)
 525
 526 zonkStmts (BindStmt pat expr locn : stmts)
 527   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 528     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 529     tcExtendGlobalValEnv (bagToList new_ids)    $
 530     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 531     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 532
 533
 534
 535 -------------------------------------------------------------------------
 536 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 537
 538 zonkRbinds rbinds
 539   = mapNF_Tc zonk_rbind rbinds
 540   where
 541     zonk_rbind (field, expr, pun)
 542       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 543         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 544         returnNF_Tc (new_field, new_expr, pun)
 545 \end{code}
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection[BackSubst-Pats]{Patterns}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 554 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 555
 556 zonkPat (WildPat ty)
 557   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 558     returnNF_Tc (WildPat new_ty, emptyBag)
 559
 560 zonkPat (VarPat v)
 561   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 562     returnNF_Tc (VarPat new_v, unitBag new_v)
 563
 564 zonkPat (LazyPat pat)
 565   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 566     returnNF_Tc (LazyPat new_pat, ids)
 567
 568 zonkPat (AsPat n pat)
 569   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 570     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 571     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 572
 573 zonkPat (ListPat ty pats)
 574   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 575     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 576     returnNF_Tc (ListPat new_ty new_pats, ids)
 577
 578 zonkPat (TuplePat pats boxed)
 579   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 580     returnNF_Tc (TuplePat new_pats boxed, ids)
 581
 582 zonkPat (ConPat n ty tvs dicts pats)
 583   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 584     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 585     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 586     tcExtendGlobalValEnv new_dicts      $
 587     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 588     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 589                  listToBag new_dicts `unionBags` ids)
 590
 591 zonkPat (RecPat n ty tvs dicts rpats)
 592   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 593     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 594     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 595     tcExtendGlobalValEnv new_dicts      $
 596     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 597     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 598                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 599   where
 600     zonk_rpat (f, pat, pun)
 601       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 602         returnNF_Tc ((f, new_pat, pun), ids)
 603
 604 zonkPat (LitPat lit ty)
 605   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 606     returnNF_Tc (LitPat lit new_ty, emptyBag)
 607
 608 zonkPat (NPat lit ty expr)
 609   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 610     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 611     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 612
 613 zonkPat (NPlusKPat n k ty e1 e2)
 614   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 615     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 616     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 617     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 618     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 619
 620 zonkPat (DictPat ds ms)
 621   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 622     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 623     returnNF_Tc (DictPat new_ds new_ms,
 624                  listToBag new_ds `unionBags` listToBag new_ms)
 625
 626
 627 zonkPats []
 628   = returnNF_Tc ([], emptyBag)
 629
 630 zonkPats (pat:pats)
 631   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 632     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 633     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 634 \end{code}
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection[BackSubst-Foreign]{Foreign exports}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642
 643 \begin{code}
 644 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 645 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 646
 647 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 648 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 649    zonkIdOcc i  `thenNF_Tc` \ i' ->
 650    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 651 \end{code}
 652
 653 \begin{code}
 654 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 655 zonkRules rs = mapNF_Tc zonkRule rs
 656
 657 zonkRule (HsRule name tyvars vars lhs rhs loc)
 658   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 659     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 660     tcExtendGlobalValEnv new_bndrs                      $
 661     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 662     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 663     returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 664         -- I hate this map RuleBndr stuff
 665
 666 zonkRule (IfaceRuleOut fun rule)
 667   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 668     returnNF_Tc (IfaceRuleOut fun' rule)
 669 \end{code}