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