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, TcGRHSsAndBinds, TcGRHS, TcMatch,
  13         TcStmt, TcArithSeqInfo, TcRecordBinds,
  14         TcHsModule, TcCoreExpr, TcDictBinds,
  15         TcForeignExportDecl,
  16
  17         TypecheckedHsBinds,
  18         TypecheckedMonoBinds, TypecheckedPat,
  19         TypecheckedHsExpr, TypecheckedArithSeqInfo,
  20         TypecheckedStmt, TypecheckedForeignDecl,
  21         TypecheckedMatch, TypecheckedHsModule,
  22         TypecheckedGRHSsAndBinds, TypecheckedGRHS,
  23         TypecheckedRecordBinds, TypecheckedDictBinds,
  24
  25         mkHsTyApp, mkHsDictApp,
  26         mkHsTyLam, mkHsDictLam,
  27
  28         -- re-exported from TcEnv
  29         TcIdOcc(..), TcIdBndr, tcIdType, tcIdTyVars, tcInstId,
  30
  31         maybeBoxedPrimType,
  32
  33         zonkTopBinds, zonkTcId, zonkId,
  34         zonkForeignExports
  35   ) where
  36
  37 #include "HsVersions.h"
  38
  39 -- friends:
  40 import HsSyn    -- oodles of it
  41
  42 -- others:
  43 import Id       ( idType, setIdType, Id )
  44 import DataCon  ( DataCon, dataConArgTys )
  45 import Name     ( NamedThing(..) )
  46 import BasicTypes ( Unused )
  47 import TcEnv    ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv,
  48                   TcIdOcc(..), TcIdBndr, GlobalValueEnv,
  49                   tcIdType, tcIdTyVars, tcInstId
  50                 )
  51
  52 import TcMonad
  53 import TcType   ( TcType, TcTyVar, TcBox,
  54                   zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
  55                 )
  56 import TyCon    ( isDataTyCon )
  57 import Type     ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
  58 import Var      ( TyVar )
  59 import VarEnv   ( TyVarEnv, emptyVarEnv, extendVarEnvList )
  60 import TysWiredIn       ( voidTy )
  61 import CoreSyn  ( Expr )
  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 s        = HsBinds (TcBox s) (TcIdOcc s) (TcPat s)
  80 type TcMonoBinds s      = MonoBinds (TcBox s) (TcIdOcc s) (TcPat s)
  81 type TcDictBinds s      = TcMonoBinds s
  82 type TcPat s            = OutPat (TcBox s) (TcIdOcc s)
  83 type TcExpr s           = HsExpr (TcBox s) (TcIdOcc s) (TcPat s)
  84 type TcGRHSsAndBinds s  = GRHSsAndBinds (TcBox s) (TcIdOcc s) (TcPat s)
  85 type TcGRHS s           = GRHS (TcBox s) (TcIdOcc s) (TcPat s)
  86 type TcMatch s          = Match (TcBox s) (TcIdOcc s) (TcPat s)
  87 type TcStmt s           = Stmt (TcBox s) (TcIdOcc s) (TcPat s)
  88 type TcArithSeqInfo s   = ArithSeqInfo (TcBox s) (TcIdOcc s) (TcPat s)
  89 type TcRecordBinds s    = HsRecordBinds (TcBox s) (TcIdOcc s) (TcPat s)
  90 type TcHsModule s       = HsModule (TcBox s) (TcIdOcc s) (TcPat s)
  91
  92 type TcCoreExpr s       = Expr (TcIdOcc s) (TcBox s)
  93 type TcForeignExportDecl s = ForeignDecl (TcIdOcc s)
  94
  95 type TypecheckedPat             = OutPat        Unused Id
  96 type TypecheckedMonoBinds       = MonoBinds     Unused Id TypecheckedPat
  97 type TypecheckedDictBinds       = TypecheckedMonoBinds
  98 type TypecheckedHsBinds         = HsBinds       Unused Id TypecheckedPat
  99 type TypecheckedHsExpr          = HsExpr        Unused Id TypecheckedPat
 100 type TypecheckedArithSeqInfo    = ArithSeqInfo  Unused Id TypecheckedPat
 101 type TypecheckedStmt            = Stmt          Unused Id TypecheckedPat
 102 type TypecheckedMatch           = Match         Unused Id TypecheckedPat
 103 type TypecheckedGRHSsAndBinds   = GRHSsAndBinds Unused Id TypecheckedPat
 104 type TypecheckedGRHS            = GRHS          Unused Id TypecheckedPat
 105 type TypecheckedRecordBinds     = HsRecordBinds Unused Id TypecheckedPat
 106 type TypecheckedHsModule        = HsModule      Unused Id TypecheckedPat
 107 type TypecheckedForeignDecl     = ForeignDecl Id
 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 \end{code}
 123
 124 %************************************************************************
 125 %*                                                                      *
 126 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 127 %*                                                                      *
 128 %************************************************************************
 129
 130 Some gruesome hackery for desugaring ccalls. It's here because if we put it
 131 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
 132 DsCCall.lhs.
 133
 134 \begin{code}
 135 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
 136 maybeBoxedPrimType ty
 137   = case splitAlgTyConApp_maybe ty of                                   -- Data type,
 138       Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon         -- with exactly one constructor
 139         -> case (dataConArgTys data_con tys_applied) of
 140              [data_con_arg_ty]                          -- Applied to exactly one type,
 141                 | isUnLiftedType data_con_arg_ty        -- which is primitive
 142                 -> Just (data_con, data_con_arg_ty)
 143              other_cases -> Nothing
 144       other_cases -> Nothing
 145 \end{code}
 146
 147 %************************************************************************
 148 %*                                                                      *
 149 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 150 %*                                                                      *
 151 %************************************************************************
 152
 153 @zonkTcId@ just works on TcIdOccs.  It's used when zonking Method insts.
 154
 155 \begin{code}
 156 zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
 157 zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
 158 zonkTcId (TcId id)
 159   = zonkId id `thenNF_Tc` \id ->
 160     returnNF_Tc (TcId id)
 161
 162 zonkId :: TcIdBndr s -> NF_TcM s (TcIdBndr s)
 163 zonkId id
 164   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 165     returnNF_Tc (setIdType id ty')
 166 \end{code}
 167
 168
 169 This zonking pass runs over the bindings
 170
 171  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 172  b) convert unbound TcTyVar to Void
 173  c) convert each TcIdBndr to an Id by zonking its type
 174
 175 We pass an environment around so that
 176
 177  a) we know which TyVars are unbound
 178  b) we maintain sharing; eg an Id is zonked at its binding site and they
 179     all occurrences of that Id point to the common zonked copy
 180
 181 Actually, since this is all in the Tc monad, it's convenient to keep the
 182 mapping from TcIds to Ids in the GVE of the Tc monad.   (Those TcIds
 183 were previously in the LVE of the Tc monad.)   The type variables, though,
 184 we carry round in a separate environment.
 185
 186 It's all pretty boring stuff, because HsSyn is such a large type, and
 187 the environment manipulation is tiresome.
 188
 189 \begin{code}
 190 extend_te te tyvars = extendVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
 191
 192 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
 193 zonkIdBndr te (RealId id) = returnNF_Tc id
 194 zonkIdBndr te (TcId id)
 195   = zonkTcTypeToType te (idType id)     `thenNF_Tc` \ ty' ->
 196     returnNF_Tc (setIdType id ty')
 197
 198
 199 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
 200 zonkIdOcc (RealId id) = returnNF_Tc id
 201 zonkIdOcc (TcId id)
 202   = tcLookupGlobalValueMaybe (getName id)       `thenNF_Tc` \ maybe_id' ->
 203     let
 204         new_id = case maybe_id' of
 205                     Just id' -> id'
 206                     Nothing  -> pprTrace "zonkIdOcc: " (ppr id) $
 207                                     setIdType id voidTy
 208     in
 209     returnNF_Tc new_id
 210 \end{code}
 211
 212
 213 \begin{code}
 214 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv)
 215 zonkTopBinds binds      -- Top level is implicitly recursive
 216   = fixNF_Tc (\ ~(_, new_ids) ->
 217         tcExtendGlobalValEnv (bagToList new_ids)        $
 218         zonkMonoBinds emptyVarEnv binds                 `thenNF_Tc` \ (binds', _, new_ids) ->
 219                 -- No top-level existential type variables
 220         tcGetGlobalValEnv                               `thenNF_Tc` \ env ->
 221         returnNF_Tc ((binds', env), new_ids)
 222     )                                   `thenNF_Tc` \ (stuff, _) ->
 223     returnNF_Tc stuff
 224
 225
 226 zonkBinds :: TyVarEnv Type
 227           -> TcHsBinds s
 228           -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
 229
 230 zonkBinds te binds
 231   = go binds te (\ binds' te' -> tcGetEnv `thenNF_Tc` \ env ->
 232                                  returnNF_Tc (binds', te', env))
 233   where
 234     -- go :: TcHsBinds s
 235     --    -> (TypecheckedHsBinds
 236     --        -> TyVarEnv Type
 237     --        -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
 238     --       )
 239     --    -> NF_TcM s (TypecheckedHsBinds, TyVarEnv Type, TcEnv s)
 240     go (ThenBinds b1 b2) te thing_inside = go b1 te     $ \ b1' te1 ->
 241                                            go b2 te1    $ \ b2' te2 ->
 242                                            thing_inside (b1' `ThenBinds` b2') te2
 243
 244     go EmptyBinds te thing_inside = thing_inside EmptyBinds te
 245
 246     go (MonoBind bind sigs is_rec) te thing_inside
 247           = ASSERT( null sigs )
 248             fixNF_Tc (\ ~(_, new_tvs, new_ids) ->
 249                 let
 250                    new_te = extend_te te (bagToList new_tvs)
 251                 in
 252                 tcExtendGlobalValEnv (bagToList new_ids)                $
 253                 zonkMonoBinds new_te bind                               `thenNF_Tc` \ (new_bind, new_tvs, new_ids) ->
 254                 thing_inside (MonoBind new_bind [] is_rec) new_te       `thenNF_Tc` \ stuff ->
 255                 returnNF_Tc (stuff, new_tvs, new_ids)
 256             )                                                   `thenNF_Tc` \ (stuff, _, _) ->
 257            returnNF_Tc stuff
 258 \end{code}
 259
 260 \begin{code}
 261 -------------------------------------------------------------------------
 262 zonkMonoBinds :: TyVarEnv Type
 263               -> TcMonoBinds s
 264               -> NF_TcM s (TypecheckedMonoBinds, Bag TyVar, Bag Id)
 265
 266 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag, emptyBag)
 267
 268 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
 269   = zonkMonoBinds te mbinds1            `thenNF_Tc` \ (b1', tvs1, ids1) ->
 270     zonkMonoBinds te mbinds2            `thenNF_Tc` \ (b2', tvs2, ids2) ->
 271     returnNF_Tc (b1' `AndMonoBinds` b2',
 272                  tvs1 `unionBags` tvs2,
 273                  ids1 `unionBags` ids2)
 274
 275 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
 276   = zonkPat te pat                              `thenNF_Tc` \ (new_pat, tvs, ids) ->
 277     zonkGRHSsAndBinds te grhss_w_binds          `thenNF_Tc` \ new_grhss_w_binds ->
 278     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, tvs, ids)
 279
 280 zonkMonoBinds te (VarMonoBind var expr)
 281   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 282     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 283     returnNF_Tc (VarMonoBind new_var new_expr, emptyBag, unitBag new_var)
 284
 285 zonkMonoBinds te (CoreMonoBind var core_expr)
 286   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 287     returnNF_Tc (CoreMonoBind new_var core_expr, emptyBag, unitBag new_var)
 288
 289 zonkMonoBinds te (FunMonoBind var inf ms locn)
 290   = zonkIdBndr te var                   `thenNF_Tc` \ new_var ->
 291     mapNF_Tc (zonkMatch te) ms          `thenNF_Tc` \ new_ms ->
 292     returnNF_Tc (FunMonoBind new_var inf new_ms locn, emptyBag, unitBag new_var)
 293
 294
 295 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
 296   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 297     let
 298         new_te = extend_te te new_tyvars
 299     in
 300     mapNF_Tc (zonkIdBndr new_te) dicts          `thenNF_Tc` \ new_dicts ->
 301
 302     tcExtendGlobalValEnv new_dicts                      $
 303     fixNF_Tc (\ ~(_, _, val_bind_tvs, val_bind_ids) ->
 304         let
 305            new_te2 = extend_te new_te (bagToList val_bind_tvs)
 306         in
 307         tcExtendGlobalValEnv (bagToList val_bind_ids)           $
 308         zonkMonoBinds new_te2 val_bind          `thenNF_Tc` \ (new_val_bind, val_bind_tvs, val_bind_ids) ->
 309         mapNF_Tc (zonkExport new_te2) exports   `thenNF_Tc` \ new_exports ->
 310         returnNF_Tc (new_val_bind, new_exports, val_bind_tvs, val_bind_ids)
 311     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _, _) ->
 312     let
 313             new_globals = listToBag [global | (_, global, local) <- new_exports]
 314     in
 315     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
 316                  emptyBag,      -- For now.
 317                  new_globals)
 318   where
 319     zonkExport te (tyvars, global, local)
 320         = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
 321           zonkIdBndr te global                  `thenNF_Tc` \ new_global ->
 322           zonkIdOcc local                       `thenNF_Tc` \ new_local ->
 323           returnNF_Tc (new_tyvars, new_global, new_local)
 324 \end{code}
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 \begin{code}
 333 zonkMatch :: TyVarEnv Type
 334           -> TcMatch s -> NF_TcM s TypecheckedMatch
 335
 336 zonkMatch te (PatMatch pat match)
 337   = zonkPat te pat              `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
 338     let
 339         new_te = extend_te te (bagToList new_tvs)
 340     in
 341     tcExtendGlobalValEnv (bagToList new_ids)    $
 342     zonkMatch new_te match      `thenNF_Tc` \ new_match ->
 343     returnNF_Tc (PatMatch new_pat new_match)
 344
 345 zonkMatch te (GRHSMatch grhss_w_binds)
 346   = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
 347     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 348
 349 zonkMatch te (SimpleMatch expr)
 350   = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
 351     returnNF_Tc (SimpleMatch new_expr)
 352
 353 -------------------------------------------------------------------------
 354 zonkGRHSsAndBinds :: TyVarEnv Type
 355                   -> TcGRHSsAndBinds s
 356                   -> NF_TcM s TypecheckedGRHSsAndBinds
 357
 358 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
 359   = zonkBinds te binds                  `thenNF_Tc` \ (new_binds, new_te, new_env) ->
 360     tcSetEnv new_env $
 361     let
 362         zonk_grhs (GRHS guarded locn)
 363           = zonkStmts new_te guarded  `thenNF_Tc` \ new_guarded ->
 364             returnNF_Tc (GRHS new_guarded locn)
 365     in
 366     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 367     zonkTcTypeToType new_te ty  `thenNF_Tc` \ new_ty ->
 368     returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
 369 \end{code}
 370
 371 %************************************************************************
 372 %*                                                                      *
 373 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 \begin{code}
 378 zonkExpr :: TyVarEnv Type
 379          -> TcExpr s -> NF_TcM s TypecheckedHsExpr
 380
 381 zonkExpr te (HsVar id)
 382   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 383     returnNF_Tc (HsVar id')
 384
 385 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
 386
 387 zonkExpr te (HsLitOut lit ty)
 388   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 389     returnNF_Tc (HsLitOut lit new_ty)
 390
 391 zonkExpr te (HsLam match)
 392   = zonkMatch te match  `thenNF_Tc` \ new_match ->
 393     returnNF_Tc (HsLam new_match)
 394
 395 zonkExpr te (HsApp e1 e2)
 396   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 397     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 398     returnNF_Tc (HsApp new_e1 new_e2)
 399
 400 zonkExpr te (OpApp e1 op fixity e2)
 401   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 402     zonkExpr te op      `thenNF_Tc` \ new_op ->
 403     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 404     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 405
 406 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
 407 zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"
 408
 409 zonkExpr te (SectionL expr op)
 410   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 411     zonkExpr te op              `thenNF_Tc` \ new_op ->
 412     returnNF_Tc (SectionL new_expr new_op)
 413
 414 zonkExpr te (SectionR op expr)
 415   = zonkExpr te op              `thenNF_Tc` \ new_op ->
 416     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 417     returnNF_Tc (SectionR new_op new_expr)
 418
 419 zonkExpr te (HsCase expr ms src_loc)
 420   = zonkExpr te expr                `thenNF_Tc` \ new_expr ->
 421     mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->
 422     returnNF_Tc (HsCase new_expr new_ms src_loc)
 423
 424 zonkExpr te (HsIf e1 e2 e3 src_loc)
 425   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 426     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 427     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 428     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 429
 430 zonkExpr te (HsLet binds expr)
 431   = zonkBinds te binds          `thenNF_Tc` \ (new_binds, new_te, new_env) ->
 432     tcSetEnv new_env            $
 433     zonkExpr new_te expr        `thenNF_Tc` \ new_expr ->
 434     returnNF_Tc (HsLet new_binds new_expr)
 435
 436 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
 437
 438 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 439   = zonkStmts te stmts          `thenNF_Tc` \ new_stmts ->
 440     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 441     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 442     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 443     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 444     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 445                          new_ty src_loc)
 446
 447 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
 448
 449 zonkExpr te (ExplicitListOut ty exprs)
 450   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 451     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 452     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 453
 454 zonkExpr te (ExplicitTuple exprs boxed)
 455   = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->
 456     returnNF_Tc (ExplicitTuple new_exprs boxed)
 457
 458 zonkExpr te (HsCon data_con tys exprs)
 459   = mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 460     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 461     returnNF_Tc (HsCon data_con new_tys new_exprs)
 462
 463 zonkExpr te (RecordConOut data_con con_expr rbinds)
 464   = zonkExpr te con_expr        `thenNF_Tc` \ new_con_expr ->
 465     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 466     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 467
 468 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
 469
 470 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
 471   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 472     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 473     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 474     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 475     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 476
 477 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
 478 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
 479
 480 zonkExpr te (ArithSeqOut expr info)
 481   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 482     zonkArithSeq te info        `thenNF_Tc` \ new_info ->
 483     returnNF_Tc (ArithSeqOut new_expr new_info)
 484
 485 zonkExpr te (CCall fun args may_gc is_casm result_ty)
 486   = mapNF_Tc (zonkExpr te) args         `thenNF_Tc` \ new_args ->
 487     zonkTcTypeToType te result_ty       `thenNF_Tc` \ new_result_ty ->
 488     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 489
 490 zonkExpr te (HsSCC label expr)
 491   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 492     returnNF_Tc (HsSCC label new_expr)
 493
 494 zonkExpr te (TyLam tyvars expr)
 495   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 496     let
 497         new_te = extend_te te new_tyvars
 498     in
 499     zonkExpr new_te expr                `thenNF_Tc` \ new_expr ->
 500     returnNF_Tc (TyLam new_tyvars new_expr)
 501
 502 zonkExpr te (TyApp expr tys)
 503   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 504     mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 505     returnNF_Tc (TyApp new_expr new_tys)
 506
 507 zonkExpr te (DictLam dicts expr)
 508   = mapNF_Tc (zonkIdBndr te) dicts      `thenNF_Tc` \ new_dicts ->
 509     tcExtendGlobalValEnv new_dicts      $
 510     zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 511     returnNF_Tc (DictLam new_dicts new_expr)
 512
 513 zonkExpr te (DictApp expr dicts)
 514   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 515     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 516     returnNF_Tc (DictApp new_expr new_dicts)
 517
 518
 519
 520 -------------------------------------------------------------------------
 521 zonkArithSeq :: TyVarEnv Type
 522              -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 523
 524 zonkArithSeq te (From e)
 525   = zonkExpr te e               `thenNF_Tc` \ new_e ->
 526     returnNF_Tc (From new_e)
 527
 528 zonkArithSeq te (FromThen e1 e2)
 529   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 530     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 531     returnNF_Tc (FromThen new_e1 new_e2)
 532
 533 zonkArithSeq te (FromTo e1 e2)
 534   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 535     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 536     returnNF_Tc (FromTo new_e1 new_e2)
 537
 538 zonkArithSeq te (FromThenTo e1 e2 e3)
 539   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 540     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 541     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 542     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 543
 544 -------------------------------------------------------------------------
 545 zonkStmts :: TyVarEnv Type
 546           -> [TcStmt s]
 547           -> NF_TcM s [TypecheckedStmt]
 548
 549 zonkStmts te [] = returnNF_Tc []
 550
 551 zonkStmts te [ReturnStmt expr]
 552   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 553     returnNF_Tc [ReturnStmt new_expr]
 554
 555 zonkStmts te (ExprStmt expr locn : stmts)
 556   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 557     zonkStmts te        stmts   `thenNF_Tc` \ new_stmts ->
 558     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 559
 560 zonkStmts te (GuardStmt expr locn : stmts)
 561   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 562     zonkStmts te        stmts   `thenNF_Tc` \ new_stmts ->
 563     returnNF_Tc (GuardStmt new_expr locn : new_stmts)
 564
 565 zonkStmts te (LetStmt binds : stmts)
 566   = zonkBinds te binds          `thenNF_Tc` \ (new_binds, new_te, new_env) ->
 567     tcSetEnv new_env            $
 568     zonkStmts new_te stmts      `thenNF_Tc` \ new_stmts ->
 569     returnNF_Tc (LetStmt new_binds : new_stmts)
 570
 571 zonkStmts te (BindStmt pat expr locn : stmts)
 572   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 573     zonkPat te pat              `thenNF_Tc` \ (new_pat, new_tvs, new_ids) ->
 574     let
 575         new_te = extend_te te (bagToList new_tvs)
 576     in
 577     tcExtendGlobalValEnv (bagToList new_ids)    $
 578     zonkStmts new_te stmts      `thenNF_Tc` \ new_stmts ->
 579     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 580
 581
 582
 583 -------------------------------------------------------------------------
 584 zonkRbinds :: TyVarEnv Type
 585            -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 586
 587 zonkRbinds te rbinds
 588   = mapNF_Tc zonk_rbind rbinds
 589   where
 590     zonk_rbind (field, expr, pun)
 591       = zonkExpr te expr        `thenNF_Tc` \ new_expr ->
 592         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 593         returnNF_Tc (new_field, new_expr, pun)
 594 \end{code}
 595
 596 %************************************************************************
 597 %*                                                                      *
 598 \subsection[BackSubst-Pats]{Patterns}
 599 %*                                                                      *
 600 %************************************************************************
 601
 602 \begin{code}
 603 zonkPat :: TyVarEnv Type
 604         -> TcPat s -> NF_TcM s (TypecheckedPat, Bag TyVar, Bag Id)
 605
 606 zonkPat te (WildPat ty)
 607   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty ->
 608     returnNF_Tc (WildPat new_ty, emptyBag, emptyBag)
 609
 610 zonkPat te (VarPat v)
 611   = zonkIdBndr te v         `thenNF_Tc` \ new_v ->
 612     returnNF_Tc (VarPat new_v, emptyBag, unitBag new_v)
 613
 614 zonkPat te (LazyPat pat)
 615   = zonkPat te pat          `thenNF_Tc` \ (new_pat, tvs, ids) ->
 616     returnNF_Tc (LazyPat new_pat, tvs, ids)
 617
 618 zonkPat te (AsPat n pat)
 619   = zonkIdBndr te n         `thenNF_Tc` \ new_n ->
 620     zonkPat te pat          `thenNF_Tc` \ (new_pat, tvs, ids) ->
 621     returnNF_Tc (AsPat new_n new_pat, tvs, new_n `consBag` ids)
 622
 623 zonkPat te (ListPat ty pats)
 624   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 625     zonkPats te pats            `thenNF_Tc` \ (new_pats, tvs, ids) ->
 626     returnNF_Tc (ListPat new_ty new_pats, tvs, ids)
 627
 628 zonkPat te (TuplePat pats boxed)
 629   = zonkPats te pats            `thenNF_Tc` \ (new_pats, tvs, ids) ->
 630     returnNF_Tc (TuplePat new_pats boxed, tvs, ids)
 631
 632 zonkPat te (ConPat n ty tvs dicts pats)
 633   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 634     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 635     let
 636         new_te = extend_te te new_tvs
 637     in
 638     mapNF_Tc (zonkIdBndr new_te) dicts  `thenNF_Tc` \ new_dicts ->
 639     tcExtendGlobalValEnv new_dicts      $
 640
 641     zonkPats new_te pats                `thenNF_Tc` \ (new_pats, tvs, ids) ->
 642
 643     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 644                  listToBag new_tvs `unionBags` tvs,
 645                  listToBag new_dicts `unionBags` ids)
 646
 647 zonkPat te (RecPat n ty tvs dicts rpats)
 648   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 649     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 650     let
 651         new_te = extend_te te new_tvs
 652     in
 653     mapNF_Tc (zonkIdBndr new_te) dicts          `thenNF_Tc` \ new_dicts ->
 654     tcExtendGlobalValEnv new_dicts              $
 655     mapNF_Tc (zonk_rpat new_te) rpats           `thenNF_Tc` \ stuff ->
 656     let
 657         (new_rpats, tvs_s, ids_s) = unzip3 stuff
 658     in
 659     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 660                  listToBag new_tvs   `unionBags` unionManyBags tvs_s,
 661                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 662   where
 663     zonk_rpat te (f, pat, pun)
 664       = zonkPat te pat          `thenNF_Tc` \ (new_pat, tvs, ids) ->
 665         returnNF_Tc ((f, new_pat, pun), tvs, ids)
 666
 667 zonkPat te (LitPat lit ty)
 668   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 669     returnNF_Tc (LitPat lit new_ty, emptyBag, emptyBag)
 670
 671 zonkPat te (NPat lit ty expr)
 672   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 673     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 674     returnNF_Tc (NPat lit new_ty new_expr, emptyBag, emptyBag)
 675
 676 zonkPat te (NPlusKPat n k ty e1 e2)
 677   = zonkIdBndr te n             `thenNF_Tc` \ new_n ->
 678     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 679     zonkExpr te e1              `thenNF_Tc` \ new_e1 ->
 680     zonkExpr te e2              `thenNF_Tc` \ new_e2 ->
 681     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, emptyBag, unitBag new_n)
 682
 683 zonkPat te (DictPat ds ms)
 684   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
 685     mapNF_Tc (zonkIdBndr te) ms    `thenNF_Tc` \ new_ms ->
 686     returnNF_Tc (DictPat new_ds new_ms, emptyBag,
 687                  listToBag new_ds `unionBags` listToBag new_ms)
 688
 689
 690 zonkPats te []
 691   = returnNF_Tc ([], emptyBag, emptyBag)
 692
 693 zonkPats te (pat:pats)
 694   = zonkPat te pat      `thenNF_Tc` \ (pat',  tvs1, ids1) ->
 695     zonkPats te pats    `thenNF_Tc` \ (pats', tvs2, ids2) ->
 696     returnNF_Tc (pat':pats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2)
 697 \end{code}
 698
 699 %************************************************************************
 700 %*                                                                      *
 701 \subsection[BackSubst-Foreign]{Foreign exports}
 702 %*                                                                      *
 703 %************************************************************************
 704
 705
 706 \begin{code}
 707 zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
 708 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 709
 710 zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
 711 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 712    zonkIdOcc i  `thenNF_Tc` \ i' ->
 713    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 714
 715 \end{code}