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, isIP, 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 || isIP 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 (mkMonoBind 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 (HsIPVar id)
 350   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 351     returnNF_Tc (HsIPVar id')
 352
 353 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
 354
 355 zonkExpr (HsLitOut lit ty)
 356   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 357     returnNF_Tc (HsLitOut lit new_ty)
 358
 359 zonkExpr (HsLam match)
 360   = zonkMatch match     `thenNF_Tc` \ new_match ->
 361     returnNF_Tc (HsLam new_match)
 362
 363 zonkExpr (HsApp e1 e2)
 364   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 365     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 366     returnNF_Tc (HsApp new_e1 new_e2)
 367
 368 zonkExpr (OpApp e1 op fixity e2)
 369   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 370     zonkExpr op `thenNF_Tc` \ new_op ->
 371     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 372     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 373
 374 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 375 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 376
 377 zonkExpr (SectionL expr op)
 378   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 379     zonkExpr op         `thenNF_Tc` \ new_op ->
 380     returnNF_Tc (SectionL new_expr new_op)
 381
 382 zonkExpr (SectionR op expr)
 383   = zonkExpr op         `thenNF_Tc` \ new_op ->
 384     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 385     returnNF_Tc (SectionR new_op new_expr)
 386
 387 zonkExpr (HsCase expr ms src_loc)
 388   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 389     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 390     returnNF_Tc (HsCase new_expr new_ms src_loc)
 391
 392 zonkExpr (HsIf e1 e2 e3 src_loc)
 393   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 394     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 395     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 396     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 397
 398 zonkExpr (HsLet binds expr)
 399   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 400     tcSetEnv new_env            $
 401     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 402     returnNF_Tc (HsLet new_binds new_expr)
 403
 404 zonkExpr (HsWith expr binds)
 405   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 406     zonkIPBinds binds           `thenNF_Tc` \ new_binds ->
 407     returnNF_Tc (HsWith new_expr new_binds)
 408     where
 409         zonkIPBinds = mapNF_Tc zonkIPBind
 410         zonkIPBind (n, e) =
 411             zonkExpr e          `thenNF_Tc` \ e' ->
 412             returnNF_Tc (n, e')
 413
 414 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 415
 416 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 417   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 418     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 419     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 420     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 421     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 422     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 423                          new_ty src_loc)
 424
 425 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 426
 427 zonkExpr (ExplicitListOut ty exprs)
 428   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 429     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 430     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 431
 432 zonkExpr (ExplicitTuple exprs boxed)
 433   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 434     returnNF_Tc (ExplicitTuple new_exprs boxed)
 435
 436 zonkExpr (HsCon data_con tys exprs)
 437   = mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 438     mapNF_Tc zonkExpr exprs             `thenNF_Tc` \ new_exprs ->
 439     returnNF_Tc (HsCon data_con new_tys new_exprs)
 440
 441 zonkExpr (RecordConOut data_con con_expr rbinds)
 442   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 443     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 444     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 445
 446 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 447
 448 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 449   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 450     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 451     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 452     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 453     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 454
 455 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 456 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 457
 458 zonkExpr (ArithSeqOut expr info)
 459   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 460     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 461     returnNF_Tc (ArithSeqOut new_expr new_info)
 462
 463 zonkExpr (CCall fun args may_gc is_casm result_ty)
 464   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 465     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 466     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 467
 468 zonkExpr (HsSCC lbl expr)
 469   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 470     returnNF_Tc (HsSCC lbl new_expr)
 471
 472 zonkExpr (TyLam tyvars expr)
 473   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 474         -- No need to extend tyvar env; see AbsBinds
 475
 476     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 477     returnNF_Tc (TyLam new_tyvars new_expr)
 478
 479 zonkExpr (TyApp expr tys)
 480   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 481     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 482     returnNF_Tc (TyApp new_expr new_tys)
 483
 484 zonkExpr (DictLam dicts expr)
 485   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 486     tcExtendGlobalValEnv new_dicts      $
 487     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 488     returnNF_Tc (DictLam new_dicts new_expr)
 489
 490 zonkExpr (DictApp expr dicts)
 491   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 492     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 493     returnNF_Tc (DictApp new_expr new_dicts)
 494
 495
 496
 497 -------------------------------------------------------------------------
 498 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
 499
 500 zonkArithSeq (From e)
 501   = zonkExpr e          `thenNF_Tc` \ new_e ->
 502     returnNF_Tc (From new_e)
 503
 504 zonkArithSeq (FromThen e1 e2)
 505   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 506     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 507     returnNF_Tc (FromThen new_e1 new_e2)
 508
 509 zonkArithSeq (FromTo e1 e2)
 510   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 511     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 512     returnNF_Tc (FromTo new_e1 new_e2)
 513
 514 zonkArithSeq (FromThenTo e1 e2 e3)
 515   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 516     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 517     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 518     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 519
 520 -------------------------------------------------------------------------
 521 zonkStmts :: [TcStmt]
 522           -> NF_TcM s [TypecheckedStmt]
 523
 524 zonkStmts [] = returnNF_Tc []
 525
 526 zonkStmts [ReturnStmt expr]
 527   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 528     returnNF_Tc [ReturnStmt new_expr]
 529
 530 zonkStmts (ExprStmt expr locn : stmts)
 531   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 532     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 533     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 534
 535 zonkStmts (GuardStmt expr locn : stmts)
 536   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 537     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 538     returnNF_Tc (GuardStmt new_expr locn : new_stmts)
 539
 540 zonkStmts (LetStmt binds : stmts)
 541   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 542     tcSetEnv new_env            $
 543     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 544     returnNF_Tc (LetStmt new_binds : new_stmts)
 545
 546 zonkStmts (BindStmt pat expr locn : stmts)
 547   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 548     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 549     tcExtendGlobalValEnv (bagToList new_ids)    $
 550     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 551     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 552
 553
 554
 555 -------------------------------------------------------------------------
 556 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
 557
 558 zonkRbinds rbinds
 559   = mapNF_Tc zonk_rbind rbinds
 560   where
 561     zonk_rbind (field, expr, pun)
 562       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 563         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 564         returnNF_Tc (new_field, new_expr, pun)
 565 \end{code}
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsection[BackSubst-Pats]{Patterns}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
 575
 576 zonkPat (WildPat ty)
 577   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 578     returnNF_Tc (WildPat new_ty, emptyBag)
 579
 580 zonkPat (VarPat v)
 581   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 582     returnNF_Tc (VarPat new_v, unitBag new_v)
 583
 584 zonkPat (LazyPat pat)
 585   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 586     returnNF_Tc (LazyPat new_pat, ids)
 587
 588 zonkPat (AsPat n pat)
 589   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 590     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 591     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 592
 593 zonkPat (ListPat ty pats)
 594   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 595     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 596     returnNF_Tc (ListPat new_ty new_pats, ids)
 597
 598 zonkPat (TuplePat pats boxed)
 599   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 600     returnNF_Tc (TuplePat new_pats boxed, ids)
 601
 602 zonkPat (ConPat n ty tvs dicts pats)
 603   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 604     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 605     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 606     tcExtendGlobalValEnv new_dicts      $
 607     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 608     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 609                  listToBag new_dicts `unionBags` ids)
 610
 611 zonkPat (RecPat n ty tvs dicts rpats)
 612   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 613     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 614     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 615     tcExtendGlobalValEnv new_dicts      $
 616     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 617     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 618                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 619   where
 620     zonk_rpat (f, pat, pun)
 621       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 622         returnNF_Tc ((f, new_pat, pun), ids)
 623
 624 zonkPat (LitPat lit ty)
 625   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 626     returnNF_Tc (LitPat lit new_ty, emptyBag)
 627
 628 zonkPat (NPat lit ty expr)
 629   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 630     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 631     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 632
 633 zonkPat (NPlusKPat n k ty e1 e2)
 634   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 635     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 636     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 637     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 638     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 639
 640 zonkPat (DictPat ds ms)
 641   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 642     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 643     returnNF_Tc (DictPat new_ds new_ms,
 644                  listToBag new_ds `unionBags` listToBag new_ms)
 645
 646
 647 zonkPats []
 648   = returnNF_Tc ([], emptyBag)
 649
 650 zonkPats (pat:pats)
 651   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 652     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 653     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 654 \end{code}
 655
 656 %************************************************************************
 657 %*                                                                      *
 658 \subsection[BackSubst-Foreign]{Foreign exports}
 659 %*                                                                      *
 660 %************************************************************************
 661
 662
 663 \begin{code}
 664 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
 665 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 666
 667 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
 668 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 669    zonkIdOcc i  `thenNF_Tc` \ i' ->
 670    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 671 \end{code}
 672
 673 \begin{code}
 674 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
 675 zonkRules rs = mapNF_Tc zonkRule rs
 676
 677 zonkRule (RuleDecl name tyvars vars lhs rhs loc)
 678   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 679     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 680     tcExtendGlobalValEnv new_bndrs                      $
 681     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 682     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 683     returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 684         -- I hate this map RuleBndr stuff
 685
 686 zonkRule (IfaceRuleDecl fun rule loc)
 687   = returnNF_Tc (IfaceRuleDecl fun rule loc)
 688 \end{code}