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