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