ghc/compiler/typecheck/TcHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   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, zonkBinds, zonkMonoBinds, zonkTcId,
  34         zonkForeignExports
  35   ) where
  36
  37 #include "HsVersions.h"
  38
  39 -- friends:
  40 import HsSyn    -- oodles of it
  41 import Id       ( idType, dataConArgTys, mkIdWithNewType, Id
  42                 )
  43
  44 -- others:
  45 import Name     ( NamedThing(..) )
  46 import BasicTypes ( IfaceFlavour, Unused )
  47 import TcEnv    ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv, tcGetGlobalValEnv,
  48                   TcIdOcc(..), TcIdBndr, GlobalValueEnv,
  49                   tcIdType, tcIdTyVars, tcInstId
  50                 )
  51
  52 import TcMonad
  53 import TcType   ( TcType, TcMaybe, TcTyVar, TcBox,
  54                   zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType
  55                 )
  56 import TyCon    ( isDataTyCon )
  57 import Type     ( mkTyVarTy, splitAlgTyConApp_maybe, isUnpointedType, Type )
  58 import TyVar    ( TyVar, TyVarEnv, emptyTyVarEnv, growTyVarEnvList )
  59 import TysPrim  ( voidTy )
  60 import CoreSyn  ( GenCoreExpr )
  61 import Unique   ( Unique )              -- instances
  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          = GenCoreExpr (TcIdOcc s) (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 (Id, 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                 | isUnpointedType 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   = zonkTcType (idType id)    `thenNF_Tc` \ ty' ->
 160     returnNF_Tc (TcId (mkIdWithNewType id ty'))
 161 \end{code}
 162
 163 This zonking pass runs over the bindings
 164
 165  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 166  b) convert unbound TcTyVar to Void
 167  c) convert each TcIdBndr to an Id by zonking its type
 168
 169 We pass an environment around so that
 170
 171  a) we know which TyVars are unbound
 172  b) we maintain sharing; eg an Id is zonked at its binding site and they
 173     all occurrences of that Id point to the common zonked copy
 174
 175 Actually, since this is all in the Tc monad, it's convenient to keep the
 176 mapping from TcIds to Ids in the GVE of the Tc monad.   (Those TcIds
 177 were previously in the LVE of the Tc monad.)
 178
 179 It's all pretty boring stuff, because HsSyn is such a large type, and
 180 the environment manipulation is tiresome.
 181
 182 \begin{code}
 183 extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars]
 184
 185 zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
 186 zonkIdBndr te (RealId id) = returnNF_Tc id
 187 zonkIdBndr te (TcId id)
 188   = zonkTcTypeToType te (idType id)     `thenNF_Tc` \ ty' ->
 189     returnNF_Tc (mkIdWithNewType id ty')
 190
 191
 192 zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
 193 zonkIdOcc (RealId id) = returnNF_Tc id
 194 zonkIdOcc (TcId id)
 195   = tcLookupGlobalValueMaybe (getName id)       `thenNF_Tc` \ maybe_id' ->
 196     let
 197         new_id = case maybe_id' of
 198                     Just id' -> id'
 199                     Nothing  -> pprTrace "zonkIdOcc: " (ppr id) $
 200                                     mkIdWithNewType id voidTy
 201     in
 202     returnNF_Tc new_id
 203 \end{code}
 204
 205
 206 \begin{code}
 207 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, GlobalValueEnv)
 208 zonkTopBinds binds      -- Top level is implicitly recursive
 209   = fixNF_Tc (\ ~(_, new_ids) ->
 210         tcExtendGlobalValEnv (bagToList new_ids)        $
 211         zonkMonoBinds emptyTyVarEnv binds               `thenNF_Tc` \ (binds', new_ids) ->
 212         tcGetGlobalValEnv                               `thenNF_Tc` \ env ->
 213         returnNF_Tc ((binds', env), new_ids)
 214     )                                   `thenNF_Tc` \ (stuff, _) ->
 215     returnNF_Tc stuff
 216
 217
 218 zonkBinds :: TyVarEnv Type
 219           -> TcHsBinds s
 220           -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 221
 222 zonkBinds te binds
 223   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
 224   where
 225     -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
 226     --                   -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 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 te 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 :: TyVarEnv Type
 247               -> TcMonoBinds s
 248               -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
 249
 250 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 251
 252 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
 253   = zonkMonoBinds te mbinds1            `thenNF_Tc` \ (b1', ids1) ->
 254     zonkMonoBinds te mbinds2            `thenNF_Tc` \ (b2', ids2) ->
 255     returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
 256
 257 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
 258   = zonkPat te pat                              `thenNF_Tc` \ (new_pat, ids) ->
 259     zonkGRHSsAndBinds te grhss_w_binds          `thenNF_Tc` \ new_grhss_w_binds ->
 260     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
 261
 262 zonkMonoBinds te (VarMonoBind var expr)
 263   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 264     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 265     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 266
 267 zonkMonoBinds te (CoreMonoBind var core_expr)
 268   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 269     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 270
 271 zonkMonoBinds te (FunMonoBind var inf ms locn)
 272   = zonkIdBndr te var                   `thenNF_Tc` \ new_var ->
 273     mapNF_Tc (zonkMatch te) ms          `thenNF_Tc` \ new_ms ->
 274     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 275
 276
 277 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
 278   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 279     let
 280         new_te = extend_te te new_tyvars
 281     in
 282     mapNF_Tc (zonkIdBndr new_te) dicts          `thenNF_Tc` \ new_dicts ->
 283
 284     tcExtendGlobalValEnv new_dicts                      $
 285     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 286         tcExtendGlobalValEnv (bagToList val_bind_ids)           $
 287         zonkMonoBinds new_te val_bind           `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 288         mapNF_Tc (zonkExport new_te) 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 new_val_bind,
 295                  new_globals)
 296   where
 297     zonkExport te (tyvars, global, local)
 298         = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
 299           zonkIdBndr te 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 GRHSsAndBinds}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 \begin{code}
 311 zonkMatch :: TyVarEnv Type
 312           -> TcMatch s -> NF_TcM s TypecheckedMatch
 313
 314 zonkMatch te (PatMatch pat match)
 315   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 316     tcExtendGlobalValEnv (bagToList ids)        $
 317     zonkMatch te match          `thenNF_Tc` \ new_match ->
 318     returnNF_Tc (PatMatch new_pat new_match)
 319
 320 zonkMatch te (GRHSMatch grhss_w_binds)
 321   = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
 322     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 323
 324 zonkMatch te (SimpleMatch expr)
 325   = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
 326     returnNF_Tc (SimpleMatch new_expr)
 327
 328 -------------------------------------------------------------------------
 329 zonkGRHSsAndBinds :: TyVarEnv Type
 330                   -> TcGRHSsAndBinds s
 331                   -> NF_TcM s TypecheckedGRHSsAndBinds
 332
 333 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
 334   = zonkBinds te binds                  `thenNF_Tc` \ (new_binds, new_env) ->
 335     tcSetEnv new_env $
 336     let
 337         zonk_grhs (GRHS guard expr locn)
 338           = zonkStmts te guard  `thenNF_Tc` \ (new_guard, new_env) ->
 339             tcSetEnv new_env $
 340             zonkExpr te expr    `thenNF_Tc` \ new_expr  ->
 341             returnNF_Tc (GRHS new_guard new_expr locn)
 342     in
 343     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 344     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 345     returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
 346 \end{code}
 347
 348 %************************************************************************
 349 %*                                                                      *
 350 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 351 %*                                                                      *
 352 %************************************************************************
 353
 354 \begin{code}
 355 zonkExpr :: TyVarEnv Type
 356          -> TcExpr s -> NF_TcM s TypecheckedHsExpr
 357
 358 zonkExpr te (HsVar id)
 359   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 360     returnNF_Tc (HsVar id')
 361
 362 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
 363
 364 zonkExpr te (HsLitOut lit ty)
 365   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 366     returnNF_Tc (HsLitOut lit new_ty)
 367
 368 zonkExpr te (HsLam match)
 369   = zonkMatch te match  `thenNF_Tc` \ new_match ->
 370     returnNF_Tc (HsLam new_match)
 371
 372 zonkExpr te (HsApp e1 e2)
 373   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 374     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 375     returnNF_Tc (HsApp new_e1 new_e2)
 376
 377 zonkExpr te (OpApp e1 op fixity e2)
 378   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 379     zonkExpr te op      `thenNF_Tc` \ new_op ->
 380     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 381     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 382
 383 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
 384 zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"
 385
 386 zonkExpr te (SectionL expr op)
 387   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 388     zonkExpr te op              `thenNF_Tc` \ new_op ->
 389     returnNF_Tc (SectionL new_expr new_op)
 390
 391 zonkExpr te (SectionR op expr)
 392   = zonkExpr te op              `thenNF_Tc` \ new_op ->
 393     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 394     returnNF_Tc (SectionR new_op new_expr)
 395
 396 zonkExpr te (HsCase expr ms src_loc)
 397   = zonkExpr te expr                `thenNF_Tc` \ new_expr ->
 398     mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->
 399     returnNF_Tc (HsCase new_expr new_ms src_loc)
 400
 401 zonkExpr te (HsIf e1 e2 e3 src_loc)
 402   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 403     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 404     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 405     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 406
 407 zonkExpr te (HsLet binds expr)
 408   = zonkBinds te binds          `thenNF_Tc` \ (new_binds, new_env) ->
 409     tcSetEnv new_env            $
 410     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 411     returnNF_Tc (HsLet new_binds new_expr)
 412
 413 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
 414
 415 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 416   = zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, _) ->
 417     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 418     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 419     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 420     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 421     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 422                          new_ty src_loc)
 423
 424 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
 425
 426 zonkExpr te (ExplicitListOut ty exprs)
 427   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 428     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 429     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 430
 431 zonkExpr te (ExplicitTuple exprs)
 432   = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->
 433     returnNF_Tc (ExplicitTuple new_exprs)
 434
 435 zonkExpr te (HsCon con_id tys exprs)
 436   = mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 437     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 438     returnNF_Tc (HsCon con_id new_tys new_exprs)
 439
 440 zonkExpr te (RecordCon con_id con_expr rbinds)
 441   = zonkIdOcc con_id            `thenNF_Tc` \ new_con_id ->
 442     zonkExpr te con_expr        `thenNF_Tc` \ new_con_expr ->
 443     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 444     returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds)
 445
 446 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
 447
 448 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
 449   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 450     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 451     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 452     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 453     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 454
 455 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
 456 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
 457
 458 zonkExpr te (ArithSeqOut expr info)
 459   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 460     zonkArithSeq te info        `thenNF_Tc` \ new_info ->
 461     returnNF_Tc (ArithSeqOut new_expr new_info)
 462
 463 zonkExpr te (CCall fun args may_gc is_casm result_ty)
 464   = mapNF_Tc (zonkExpr te) args         `thenNF_Tc` \ new_args ->
 465     zonkTcTypeToType te result_ty       `thenNF_Tc` \ new_result_ty ->
 466     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 467
 468 zonkExpr te (HsSCC label expr)
 469   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 470     returnNF_Tc (HsSCC label new_expr)
 471
 472 zonkExpr te (TyLam tyvars expr)
 473   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 474     let
 475         new_te = extend_te te new_tyvars
 476     in
 477     zonkExpr new_te expr                `thenNF_Tc` \ new_expr ->
 478     returnNF_Tc (TyLam new_tyvars new_expr)
 479
 480 zonkExpr te (TyApp expr tys)
 481   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 482     mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 483     returnNF_Tc (TyApp new_expr new_tys)
 484
 485 zonkExpr te (DictLam dicts expr)
 486   = mapNF_Tc (zonkIdBndr te) dicts      `thenNF_Tc` \ new_dicts ->
 487     tcExtendGlobalValEnv new_dicts      $
 488     zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 489     returnNF_Tc (DictLam new_dicts new_expr)
 490
 491 zonkExpr te (DictApp expr dicts)
 492   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 493     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 494     returnNF_Tc (DictApp new_expr new_dicts)
 495
 496
 497
 498 -------------------------------------------------------------------------
 499 zonkArithSeq :: TyVarEnv Type
 500              -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 501
 502 zonkArithSeq te (From e)
 503   = zonkExpr te e               `thenNF_Tc` \ new_e ->
 504     returnNF_Tc (From new_e)
 505
 506 zonkArithSeq te (FromThen e1 e2)
 507   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 508     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 509     returnNF_Tc (FromThen new_e1 new_e2)
 510
 511 zonkArithSeq te (FromTo e1 e2)
 512   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 513     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 514     returnNF_Tc (FromTo new_e1 new_e2)
 515
 516 zonkArithSeq te (FromThenTo e1 e2 e3)
 517   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 518     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 519     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 520     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 521
 522 -------------------------------------------------------------------------
 523 zonkStmts :: TyVarEnv Type
 524           -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
 525
 526 zonkStmts te [] = tcGetEnv      `thenNF_Tc` \ env ->
 527                   returnNF_Tc ([], env)
 528
 529 zonkStmts te [ReturnStmt expr]
 530   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 531     tcGetEnv                    `thenNF_Tc` \ env ->
 532     returnNF_Tc ([ReturnStmt new_expr], env)
 533
 534 zonkStmts te (ExprStmt expr locn : stmts)
 535   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 536     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 537     returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
 538
 539 zonkStmts te (GuardStmt expr locn : stmts)
 540   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 541     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 542     returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
 543
 544 zonkStmts te (LetStmt binds : stmts)
 545   = zonkBinds te     binds      `thenNF_Tc` \ (new_binds, new_env) ->
 546     tcSetEnv new_env            $
 547     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env2) ->
 548     returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
 549
 550 zonkStmts te (BindStmt pat expr locn : stmts)
 551   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 552     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 553     tcExtendGlobalValEnv (bagToList ids)        $
 554     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env) ->
 555     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
 556
 557
 558
 559 -------------------------------------------------------------------------
 560 zonkRbinds :: TyVarEnv Type
 561            -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 562
 563 zonkRbinds te rbinds
 564   = mapNF_Tc zonk_rbind rbinds
 565   where
 566     zonk_rbind (field, expr, pun)
 567       = zonkExpr te expr        `thenNF_Tc` \ new_expr ->
 568         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 569         returnNF_Tc (new_field, new_expr, pun)
 570 \end{code}
 571
 572 %************************************************************************
 573 %*                                                                      *
 574 \subsection[BackSubst-Pats]{Patterns}
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 \begin{code}
 579 zonkPat :: TyVarEnv Type
 580         -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
 581
 582 zonkPat te (WildPat ty)
 583   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty ->
 584     returnNF_Tc (WildPat new_ty, emptyBag)
 585
 586 zonkPat te (VarPat v)
 587   = zonkIdBndr te v         `thenNF_Tc` \ new_v ->
 588     returnNF_Tc (VarPat new_v, unitBag new_v)
 589
 590 zonkPat te (LazyPat pat)
 591   = zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 592     returnNF_Tc (LazyPat new_pat, ids)
 593
 594 zonkPat te (AsPat n pat)
 595   = zonkIdBndr te n         `thenNF_Tc` \ new_n ->
 596     zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 597     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 598
 599 zonkPat te (ConPat n ty pats)
 600   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 601     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 602     returnNF_Tc (ConPat n new_ty new_pats, ids)
 603
 604 zonkPat te (ConOpPat pat1 op pat2 ty)
 605   = zonkPat te pat1         `thenNF_Tc` \ (new_pat1, ids1) ->
 606     zonkPat te pat2         `thenNF_Tc` \ (new_pat2, ids2) ->
 607     zonkTcTypeToType te ty  `thenNF_Tc` \ new_ty ->
 608     returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
 609
 610 zonkPat te (ListPat ty pats)
 611   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 612     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 613     returnNF_Tc (ListPat new_ty new_pats, ids)
 614
 615 zonkPat te (TuplePat pats)
 616   = zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 617     returnNF_Tc (TuplePat new_pats, ids)
 618
 619 zonkPat te (RecPat n ty rpats)
 620   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 621     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 622     returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
 623   where
 624     zonk_rpat (f, pat, pun)
 625       = zonkPat te pat       `thenNF_Tc` \ (new_pat, ids) ->
 626         returnNF_Tc ((f, new_pat, pun), ids)
 627
 628 zonkPat te (LitPat lit ty)
 629   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 630     returnNF_Tc (LitPat lit new_ty, emptyBag)
 631
 632 zonkPat te (NPat lit ty expr)
 633   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 634     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 635     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 636
 637 zonkPat te (NPlusKPat n k ty e1 e2)
 638   = zonkIdBndr te n             `thenNF_Tc` \ new_n ->
 639     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 640     zonkExpr te e1              `thenNF_Tc` \ new_e1 ->
 641     zonkExpr te e2              `thenNF_Tc` \ new_e2 ->
 642     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 643
 644 zonkPat te (DictPat ds ms)
 645   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
 646     mapNF_Tc (zonkIdBndr te) 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 te []
 652   = returnNF_Tc ([], emptyBag)
 653 zonkPats te (pat:pats)
 654   = zonkPat te pat      `thenNF_Tc` \ (pat', ids1) ->
 655     zonkPats te pats    `thenNF_Tc` \ (pats', ids2) ->
 656     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 657 \end{code}
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsection[BackSubst-Foreign]{Foreign exports}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665
 666 \begin{code}
 667 zonkForeignExports :: [TcForeignExportDecl s] -> NF_TcM s [TypecheckedForeignDecl]
 668 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 669
 670 zonkForeignExport :: TcForeignExportDecl s -> NF_TcM s (TypecheckedForeignDecl)
 671 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 672    zonkIdOcc i  `thenNF_Tc` \ i' ->
 673    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 674
 675 \end{code}