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         TypecheckedMatchContext,
  25
  26         mkHsTyApp, mkHsDictApp, mkHsConApp,
  27         mkHsTyLam, mkHsDictLam, mkHsLet,
  28
  29         collectTypedPatBinders, outPatType,
  30
  31         -- re-exported from TcEnv
  32         TcId,
  33
  34         zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
  35         zonkForeignExports, zonkRules
  36   ) where
  37
  38 #include "HsVersions.h"
  39
  40 -- friends:
  41 import HsSyn    -- oodles of it
  42
  43 -- others:
  44 import Id       ( idName, idType, setIdType, Id )
  45 import DataCon  ( dataConWrapId )
  46 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
  47
  48 import TcMonad
  49 import Type       ( Type )
  50 import TcMType    ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
  51 import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
  52 import CoreSyn    ( Expr )
  53 import Var        ( isId )
  54 import BasicTypes ( RecFlag(..), Boxity(..) )
  55 import Bag
  56 import Outputable
  57 import HscTypes ( TyThing(..) )
  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 TypecheckedMatchContext    = HsMatchContext Id
  98 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
  99 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
 100 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
 101 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
 102 type TypecheckedForeignDecl     = ForeignDecl Id
 103 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 104 \end{code}
 105
 106 \begin{code}
 107 mkHsTyApp expr []  = expr
 108 mkHsTyApp expr tys = TyApp expr tys
 109
 110 mkHsDictApp expr []      = expr
 111 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 112
 113 mkHsTyLam []     expr = expr
 114 mkHsTyLam tyvars expr = TyLam tyvars expr
 115
 116 mkHsDictLam []    expr = expr
 117 mkHsDictLam dicts expr = DictLam dicts expr
 118
 119 mkHsLet EmptyMonoBinds expr = expr
 120 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 121
 122 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 123 \end{code}
 124
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
 133 then something is wrong.
 134 \begin{code}
 135 outPatType :: TypecheckedPat -> Type
 136
 137 outPatType (WildPat ty)         = ty
 138 outPatType (VarPat var)         = idType var
 139 outPatType (LazyPat pat)        = outPatType pat
 140 outPatType (AsPat var pat)      = idType var
 141 outPatType (ConPat _ ty _ _ _)  = ty
 142 outPatType (ListPat ty _)       = mkListTy ty
 143 outPatType (TuplePat pats box)  = mkTupleTy box (length pats) (map outPatType pats)
 144 outPatType (RecPat _ ty _ _ _)  = ty
 145 outPatType (LitPat lit ty)      = ty
 146 outPatType (NPat lit ty _)      = ty
 147 outPatType (NPlusKPat _ _ ty _ _) = ty
 148 outPatType (DictPat ds ms)      = case (length ds_ms) of
 149                                     0 -> unitTy
 150                                     1 -> idType (head ds_ms)
 151                                     n -> mkTupleTy Boxed n (map idType ds_ms)
 152                                    where
 153                                     ds_ms = ds ++ ms
 154 \end{code}
 155
 156
 157 Nota bene: @DsBinds@ relies on the fact that at least for simple
 158 tuple patterns @collectTypedPatBinders@ returns the binders in
 159 the same order as they appear in the tuple.
 160
 161 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
 162
 163 \begin{code}
 164 collectTypedPatBinders :: TypecheckedPat -> [Id]
 165 collectTypedPatBinders (VarPat var)            = [var]
 166 collectTypedPatBinders (LazyPat pat)           = collectTypedPatBinders pat
 167 collectTypedPatBinders (AsPat a pat)           = a : collectTypedPatBinders pat
 168 collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
 169 collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
 170 collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
 171 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
 172                                                           fields)
 173 collectTypedPatBinders (DictPat ds ms)         = ds ++ ms
 174 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
 175 collectTypedPatBinders any_other_pat           = [ {-no binders-} ]
 176 \end{code}
 177
 178
 179 %************************************************************************
 180 %*                                                                      *
 181 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 182 %*                                                                      *
 183 %************************************************************************
 184
 185 This zonking pass runs over the bindings
 186
 187  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 188  b) convert unbound TcTyVar to Void
 189  c) convert each TcId to an Id by zonking its type
 190
 191 The type variables are converted by binding mutable tyvars to immutable ones
 192 and then zonking as normal.
 193
 194 The Ids are converted by binding them in the normal Tc envt; that
 195 way we maintain sharing; eg an Id is zonked at its binding site and they
 196 all occurrences of that Id point to the common zonked copy
 197
 198 It's all pretty boring stuff, because HsSyn is such a large type, and
 199 the environment manipulation is tiresome.
 200
 201 \begin{code}
 202 -- zonkId is used *during* typechecking just to zonk the Id's type
 203 zonkId :: TcId -> NF_TcM TcId
 204 zonkId id
 205   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 206     returnNF_Tc (setIdType id ty')
 207
 208 -- zonkIdBndr is used *after* typechecking to get the Id's type
 209 -- to its final form.  The TyVarEnv give
 210 zonkIdBndr :: TcId -> NF_TcM Id
 211 zonkIdBndr id
 212   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 213     returnNF_Tc (setIdType id ty')
 214
 215 zonkIdOcc :: TcId -> NF_TcM Id
 216 zonkIdOcc id
 217   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 218         -- We're even look up up superclass selectors and constructors;
 219         -- even though zonking them is a no-op anyway, and the
 220         -- superclass selectors aren't in the environment anyway.
 221         -- But we don't want to call isLocalId to find out whether
 222         -- it's a superclass selector (for example) because that looks
 223         -- at the IdInfo field, which in turn be in a knot because of
 224         -- the big knot in typecheckModule
 225     let
 226         new_id = case maybe_id' of
 227                     Just (AnId id') -> id'
 228                     other           -> id -- WARN( isLocalId id, ppr id ) id
 229                                         -- Oops: the warning can give a black hole
 230                                         -- because it looks at the idinfo
 231     in
 232     returnNF_Tc new_id
 233 \end{code}
 234
 235
 236 \begin{code}
 237 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 238 zonkTopBinds binds      -- Top level is implicitly recursive
 239   = fixNF_Tc (\ ~(_, new_ids) ->
 240         tcExtendGlobalValEnv (bagToList new_ids)        $
 241         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 242         tcGetEnv                                `thenNF_Tc` \ env ->
 243         returnNF_Tc ((binds', env), new_ids)
 244     )                                   `thenNF_Tc` \ (stuff, _) ->
 245     returnNF_Tc stuff
 246
 247 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 248
 249 zonkBinds binds
 250   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 251                           returnNF_Tc (binds', env))
 252   where
 253     -- go :: TcHsBinds
 254     --    -> (TypecheckedHsBinds
 255     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 256     --       )
 257     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 258
 259     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 260                                         go b2   $ \ b2' ->
 261                                         thing_inside (b1' `ThenBinds` b2')
 262
 263     go EmptyBinds thing_inside = thing_inside EmptyBinds
 264
 265     go (MonoBind bind sigs is_rec) thing_inside
 266           = ASSERT( null sigs )
 267             fixNF_Tc (\ ~(_, new_ids) ->
 268                 tcExtendGlobalValEnv (bagToList new_ids)        $
 269                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 270                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 271                 returnNF_Tc (stuff, new_ids)
 272             )                                                   `thenNF_Tc` \ (stuff, _) ->
 273            returnNF_Tc stuff
 274 \end{code}
 275
 276 \begin{code}
 277 -------------------------------------------------------------------------
 278 zonkMonoBinds :: TcMonoBinds
 279               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 280
 281 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 282
 283 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 284   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 285     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 286     returnNF_Tc (b1' `AndMonoBinds` b2',
 287                  ids1 `unionBags` ids2)
 288
 289 zonkMonoBinds (PatMonoBind pat grhss locn)
 290   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 291     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 292     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 293
 294 zonkMonoBinds (VarMonoBind var expr)
 295   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 296     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 297     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 298
 299 zonkMonoBinds (CoreMonoBind var core_expr)
 300   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 301     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 302
 303 zonkMonoBinds (FunMonoBind var inf ms locn)
 304   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 305     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 306     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 307
 308
 309 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 310   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 311         -- No need to extend tyvar env: the effects are
 312         -- propagated through binding the tyvars themselves
 313
 314     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 315     tcExtendGlobalValEnv new_dicts                      $
 316
 317     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 318         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 319         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 320         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 321         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 322     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 323     let
 324             new_globals = listToBag [global | (_, global, local) <- new_exports]
 325     in
 326     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 327                  new_globals)
 328   where
 329     zonkExport (tyvars, global, local)
 330         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 331                 -- This isn't the binding occurrence of these tyvars
 332                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 333           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 334           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 335           returnNF_Tc (new_tyvars, new_global, new_local)
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 \begin{code}
 345 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 346
 347 zonkMatch (Match pats _ grhss)
 348   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 349     tcExtendGlobalValEnv (bagToList new_ids)    $
 350     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 351     returnNF_Tc (Match new_pats Nothing new_grhss)
 352
 353 -------------------------------------------------------------------------
 354 zonkGRHSs :: TcGRHSs
 355           -> NF_TcM TypecheckedGRHSs
 356
 357 zonkGRHSs (GRHSs grhss binds ty)
 358   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 359     tcSetEnv new_env $
 360     let
 361         zonk_grhs (GRHS guarded locn)
 362           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 363             returnNF_Tc (GRHS new_guarded locn)
 364     in
 365     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 366     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 367     returnNF_Tc (GRHSs new_grhss new_binds new_ty)
 368 \end{code}
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 378
 379 zonkExpr (HsVar id)
 380   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 381     returnNF_Tc (HsVar id')
 382
 383 zonkExpr (HsIPVar id)
 384   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 385     returnNF_Tc (HsIPVar id')
 386
 387 zonkExpr (HsLit (HsRat f ty))
 388   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 389     returnNF_Tc (HsLit (HsRat f new_ty))
 390
 391 zonkExpr (HsLit (HsLitLit lit ty))
 392   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 393     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 394
 395 zonkExpr (HsLit lit)
 396   = returnNF_Tc (HsLit lit)
 397
 398 -- HsOverLit doesn't appear in typechecker output
 399
 400 zonkExpr (HsLam match)
 401   = zonkMatch match     `thenNF_Tc` \ new_match ->
 402     returnNF_Tc (HsLam new_match)
 403
 404 zonkExpr (HsApp e1 e2)
 405   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 406     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 407     returnNF_Tc (HsApp new_e1 new_e2)
 408
 409 zonkExpr (OpApp e1 op fixity e2)
 410   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 411     zonkExpr op `thenNF_Tc` \ new_op ->
 412     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 413     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 414
 415 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 416 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 417
 418 zonkExpr (SectionL expr op)
 419   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 420     zonkExpr op         `thenNF_Tc` \ new_op ->
 421     returnNF_Tc (SectionL new_expr new_op)
 422
 423 zonkExpr (SectionR op expr)
 424   = zonkExpr op         `thenNF_Tc` \ new_op ->
 425     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 426     returnNF_Tc (SectionR new_op new_expr)
 427
 428 zonkExpr (HsCase expr ms src_loc)
 429   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 430     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 431     returnNF_Tc (HsCase new_expr new_ms src_loc)
 432
 433 zonkExpr (HsIf e1 e2 e3 src_loc)
 434   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 435     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 436     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 437     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 438
 439 zonkExpr (HsLet binds expr)
 440   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 441     tcSetEnv new_env            $
 442     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 443     returnNF_Tc (HsLet new_binds new_expr)
 444
 445 zonkExpr (HsWith expr binds)
 446   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 447     tcExtendGlobalValEnv (map fst new_binds)    $
 448     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 449     returnNF_Tc (HsWith new_expr new_binds)
 450     where
 451         zonkIPBinds = mapNF_Tc zonkIPBind
 452         zonkIPBind (n, e) =
 453             zonkIdBndr n        `thenNF_Tc` \ n' ->
 454             zonkExpr e          `thenNF_Tc` \ e' ->
 455             returnNF_Tc (n', e')
 456
 457 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 458
 459 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 460   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 461     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 462     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 463     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 464     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 465     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 466                          new_ty src_loc)
 467
 468 zonkExpr (ExplicitList ty exprs)
 469   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 470     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 471     returnNF_Tc (ExplicitList new_ty new_exprs)
 472
 473 zonkExpr (ExplicitTuple exprs boxed)
 474   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 475     returnNF_Tc (ExplicitTuple new_exprs boxed)
 476
 477 zonkExpr (RecordConOut data_con con_expr rbinds)
 478   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 479     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 480     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 481
 482 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 483
 484 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
 485   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 486     zonkTcTypeToType in_ty      `thenNF_Tc` \ new_in_ty ->
 487     zonkTcTypeToType out_ty     `thenNF_Tc` \ new_out_ty ->
 488     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 489     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 490     returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
 491
 492 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 493 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 494
 495 zonkExpr (ArithSeqOut expr info)
 496   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 497     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 498     returnNF_Tc (ArithSeqOut new_expr new_info)
 499
 500 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 501   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 502     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 503     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 504
 505 zonkExpr (HsSCC lbl expr)
 506   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 507     returnNF_Tc (HsSCC lbl new_expr)
 508
 509 zonkExpr (TyLam tyvars expr)
 510   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 511         -- No need to extend tyvar env; see AbsBinds
 512
 513     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 514     returnNF_Tc (TyLam new_tyvars new_expr)
 515
 516 zonkExpr (TyApp expr tys)
 517   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 518     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 519     returnNF_Tc (TyApp new_expr new_tys)
 520
 521 zonkExpr (DictLam dicts expr)
 522   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 523     tcExtendGlobalValEnv new_dicts      $
 524     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 525     returnNF_Tc (DictLam new_dicts new_expr)
 526
 527 zonkExpr (DictApp expr dicts)
 528   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 529     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 530     returnNF_Tc (DictApp new_expr new_dicts)
 531
 532
 533
 534 -------------------------------------------------------------------------
 535 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 536
 537 zonkArithSeq (From e)
 538   = zonkExpr e          `thenNF_Tc` \ new_e ->
 539     returnNF_Tc (From new_e)
 540
 541 zonkArithSeq (FromThen e1 e2)
 542   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 543     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 544     returnNF_Tc (FromThen new_e1 new_e2)
 545
 546 zonkArithSeq (FromTo e1 e2)
 547   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 548     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 549     returnNF_Tc (FromTo new_e1 new_e2)
 550
 551 zonkArithSeq (FromThenTo e1 e2 e3)
 552   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 553     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 554     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 555     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 556
 557 -------------------------------------------------------------------------
 558 zonkStmts :: [TcStmt]
 559           -> NF_TcM [TypecheckedStmt]
 560
 561 zonkStmts [] = returnNF_Tc []
 562
 563 zonkStmts (ParStmtOut bndrstmtss : stmts)
 564   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 565     let new_binders = concat new_bndrss in
 566     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 567     tcExtendGlobalValEnv new_binders    $
 568     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 569     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 570   where (bndrss, stmtss) = unzip bndrstmtss
 571
 572 zonkStmts (ResultStmt expr locn : stmts)
 573   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 574     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 575     returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 576
 577 zonkStmts (ExprStmt expr ty locn : stmts)
 578   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 579     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 580     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 581     returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
 582
 583 zonkStmts (LetStmt binds : stmts)
 584   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 585     tcSetEnv new_env            $
 586     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 587     returnNF_Tc (LetStmt new_binds : new_stmts)
 588
 589 zonkStmts (BindStmt pat expr locn : stmts)
 590   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 591     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 592     tcExtendGlobalValEnv (bagToList new_ids)    $
 593     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 594     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 595
 596
 597
 598 -------------------------------------------------------------------------
 599 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 600
 601 zonkRbinds rbinds
 602   = mapNF_Tc zonk_rbind rbinds
 603   where
 604     zonk_rbind (field, expr, pun)
 605       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 606         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 607         returnNF_Tc (new_field, new_expr, pun)
 608 \end{code}
 609
 610 %************************************************************************
 611 %*                                                                      *
 612 \subsection[BackSubst-Pats]{Patterns}
 613 %*                                                                      *
 614 %************************************************************************
 615
 616 \begin{code}
 617 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 618
 619 zonkPat (WildPat ty)
 620   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 621     returnNF_Tc (WildPat new_ty, emptyBag)
 622
 623 zonkPat (VarPat v)
 624   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 625     returnNF_Tc (VarPat new_v, unitBag new_v)
 626
 627 zonkPat (LazyPat pat)
 628   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 629     returnNF_Tc (LazyPat new_pat, ids)
 630
 631 zonkPat (AsPat n pat)
 632   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 633     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 634     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 635
 636 zonkPat (ListPat ty pats)
 637   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 638     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 639     returnNF_Tc (ListPat new_ty new_pats, ids)
 640
 641 zonkPat (TuplePat pats boxed)
 642   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 643     returnNF_Tc (TuplePat new_pats boxed, ids)
 644
 645 zonkPat (ConPat n ty tvs dicts pats)
 646   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 647     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 648     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 649     tcExtendGlobalValEnv new_dicts      $
 650     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 651     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 652                  listToBag new_dicts `unionBags` ids)
 653
 654 zonkPat (RecPat n ty tvs dicts rpats)
 655   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 656     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 657     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 658     tcExtendGlobalValEnv new_dicts      $
 659     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 660     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 661                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 662   where
 663     zonk_rpat (f, pat, pun)
 664       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 665         returnNF_Tc ((f, new_pat, pun), ids)
 666
 667 zonkPat (LitPat lit ty)
 668   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 669     returnNF_Tc (LitPat lit new_ty, emptyBag)
 670
 671 zonkPat (NPat lit ty expr)
 672   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 673     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 674     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 675
 676 zonkPat (NPlusKPat n k ty e1 e2)
 677   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 678     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 679     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 680     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 681     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 682
 683 zonkPat (DictPat ds ms)
 684   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 685     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 686     returnNF_Tc (DictPat new_ds new_ms,
 687                  listToBag new_ds `unionBags` listToBag new_ms)
 688
 689
 690 zonkPats []
 691   = returnNF_Tc ([], emptyBag)
 692
 693 zonkPats (pat:pats)
 694   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 695     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 696     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 697 \end{code}
 698
 699 %************************************************************************
 700 %*                                                                      *
 701 \subsection[BackSubst-Foreign]{Foreign exports}
 702 %*                                                                      *
 703 %************************************************************************
 704
 705
 706 \begin{code}
 707 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 708 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 709
 710 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 711 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
 712    zonkIdOcc i  `thenNF_Tc` \ i' ->
 713    returnNF_Tc (ForeignExport i' undefined spec src_loc)
 714 \end{code}
 715
 716 \begin{code}
 717 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 718 zonkRules rs = mapNF_Tc zonkRule rs
 719
 720 zonkRule (HsRule name act vars lhs rhs loc)
 721   = mapNF_Tc zonk_bndr vars                             `thenNF_Tc` \ new_bndrs ->
 722     tcExtendGlobalValEnv (filter isId new_bndrs)        $
 723         -- Type variables don't need an envt
 724         -- They are bound through the mutable mechanism
 725     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 726     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 727     returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 728         -- I hate this map RuleBndr stuff
 729   where
 730    zonk_bndr (RuleBndr v)
 731         | isId v    = zonkIdBndr v
 732         | otherwise = zonkTcTyVarToTyVar v
 733
 734 zonkRule (IfaceRuleOut fun rule)
 735   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 736     returnNF_Tc (IfaceRuleOut fun' rule)
 737 \end{code}