ghc/compiler/typecheck/TcHsSyn.lhs

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