ghc/compiler/typecheck/TcHsSyn.lhs

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