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