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       ( GenId(..), IdDetails, -- Can meddle modestly with Ids
  40                   dataConArgTys, Id
  41                 )
  42
  43 -- others:
  44 import Name     ( NamedThing(..) )
  45 import BasicTypes ( IfaceFlavour, Unused )
  46 import TcEnv    ( tcLookupGlobalValueMaybe, tcExtendGlobalValEnv,
  47                   TcIdOcc(..), TcIdBndr, 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 u n ty details prags info))
 155   = zonkTcType ty    `thenNF_Tc` \ ty' ->
 156     returnNF_Tc (TcId (Id u n ty' details prags info))
 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 u n ty details prags info))
 184   = zonkTcTypeToType te ty      `thenNF_Tc` \ ty' ->
 185     returnNF_Tc (Id u n ty' details prags info)
 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                                     Id u n voidTy details prags info
 197                                 where
 198                                     Id u n _ details prags info = id
 199     in
 200     returnNF_Tc new_id
 201 \end{code}
 202
 203
 204 \begin{code}
 205 zonkTopBinds :: TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, TcEnv s)
 206 zonkTopBinds binds      -- Top level is implicitly recursive
 207   = fixNF_Tc (\ ~(_, new_ids) ->
 208         tcExtendGlobalValEnv (bagToList new_ids)        $
 209         zonkMonoBinds emptyTyVarEnv binds               `thenNF_Tc` \ (binds', new_ids) ->
 210         tcGetEnv                                        `thenNF_Tc` \ env ->
 211         returnNF_Tc ((binds', env), new_ids)
 212     )                                   `thenNF_Tc` \ (stuff, _) ->
 213     returnNF_Tc stuff
 214
 215
 216 zonkBinds :: TyVarEnv Type
 217           -> TcHsBinds s
 218           -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 219
 220 zonkBinds te binds
 221   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> returnNF_Tc (binds', env))
 222   where
 223     -- go :: TcHsBinds s -> (TypecheckedHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv s))
 224     --                   -> NF_TcM s (TypecheckedHsBinds, TcEnv s)
 225     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 226                                         go b2   $ \ b2' ->
 227                                         thing_inside (b1' `ThenBinds` b2')
 228
 229     go EmptyBinds thing_inside = thing_inside EmptyBinds
 230
 231     go (MonoBind bind sigs is_rec) thing_inside
 232           = ASSERT( null sigs )
 233             fixNF_Tc (\ ~(_, new_ids) ->
 234                 tcExtendGlobalValEnv (bagToList new_ids)        $
 235                 zonkMonoBinds te bind                           `thenNF_Tc` \ (new_bind, new_ids) ->
 236                 thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
 237                 returnNF_Tc (stuff, new_ids)
 238             )                                           `thenNF_Tc` \ (stuff, _) ->
 239            returnNF_Tc stuff
 240 \end{code}
 241
 242 \begin{code}
 243 -------------------------------------------------------------------------
 244 zonkMonoBinds :: TyVarEnv Type
 245               -> TcMonoBinds s
 246               -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
 247
 248 zonkMonoBinds te EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 249
 250 zonkMonoBinds te (AndMonoBinds mbinds1 mbinds2)
 251   = zonkMonoBinds te mbinds1            `thenNF_Tc` \ (b1', ids1) ->
 252     zonkMonoBinds te mbinds2            `thenNF_Tc` \ (b2', ids2) ->
 253     returnNF_Tc (b1' `AndMonoBinds` b2', ids1 `unionBags` ids2)
 254
 255 zonkMonoBinds te (PatMonoBind pat grhss_w_binds locn)
 256   = zonkPat te pat                              `thenNF_Tc` \ (new_pat, ids) ->
 257     zonkGRHSsAndBinds te grhss_w_binds          `thenNF_Tc` \ new_grhss_w_binds ->
 258     returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids)
 259
 260 zonkMonoBinds te (VarMonoBind var expr)
 261   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 262     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 263     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 264
 265 zonkMonoBinds te (CoreMonoBind var core_expr)
 266   = zonkIdBndr te var           `thenNF_Tc` \ new_var ->
 267     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 268
 269 zonkMonoBinds te (FunMonoBind var inf ms locn)
 270   = zonkIdBndr te var                   `thenNF_Tc` \ new_var ->
 271     mapNF_Tc (zonkMatch te) ms          `thenNF_Tc` \ new_ms ->
 272     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 273
 274
 275 zonkMonoBinds te (AbsBinds tyvars dicts exports val_bind)
 276   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 277     let
 278         new_te = extend_te te new_tyvars
 279     in
 280     mapNF_Tc (zonkIdBndr new_te) dicts          `thenNF_Tc` \ new_dicts ->
 281
 282     tcExtendGlobalValEnv new_dicts                      $
 283     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 284         tcExtendGlobalValEnv (bagToList val_bind_ids)           $
 285         zonkMonoBinds new_te val_bind           `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 286         mapNF_Tc (zonkExport new_te) exports    `thenNF_Tc` \ new_exports ->
 287         returnNF_Tc (new_val_bind, new_exports, val_bind_ids)
 288     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 289     let
 290             new_globals = listToBag [global | (_, global, local) <- new_exports]
 291     in
 292     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports new_val_bind,
 293                  new_globals)
 294   where
 295     zonkExport te (tyvars, global, local)
 296         = mapNF_Tc zonkTcTyVarToTyVar tyvars    `thenNF_Tc` \ new_tyvars ->
 297           zonkIdBndr te global                  `thenNF_Tc` \ new_global ->
 298           zonkIdOcc local                       `thenNF_Tc` \ new_local ->
 299           returnNF_Tc (new_tyvars, new_global, new_local)
 300 \end{code}
 301
 302 %************************************************************************
 303 %*                                                                      *
 304 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
 305 %*                                                                      *
 306 %************************************************************************
 307
 308 \begin{code}
 309 zonkMatch :: TyVarEnv Type
 310           -> TcMatch s -> NF_TcM s TypecheckedMatch
 311
 312 zonkMatch te (PatMatch pat match)
 313   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 314     tcExtendGlobalValEnv (bagToList ids)        $
 315     zonkMatch te match          `thenNF_Tc` \ new_match ->
 316     returnNF_Tc (PatMatch new_pat new_match)
 317
 318 zonkMatch te (GRHSMatch grhss_w_binds)
 319   = zonkGRHSsAndBinds te grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
 320     returnNF_Tc (GRHSMatch new_grhss_w_binds)
 321
 322 zonkMatch te (SimpleMatch expr)
 323   = zonkExpr te expr   `thenNF_Tc` \ new_expr ->
 324     returnNF_Tc (SimpleMatch new_expr)
 325
 326 -------------------------------------------------------------------------
 327 zonkGRHSsAndBinds :: TyVarEnv Type
 328                   -> TcGRHSsAndBinds s
 329                   -> NF_TcM s TypecheckedGRHSsAndBinds
 330
 331 zonkGRHSsAndBinds te (GRHSsAndBindsOut grhss binds ty)
 332   = zonkBinds te binds                  `thenNF_Tc` \ (new_binds, new_env) ->
 333     tcSetEnv new_env $
 334     let
 335         zonk_grhs (GRHS guard expr locn)
 336           = zonkStmts te guard  `thenNF_Tc` \ (new_guard, new_env) ->
 337             tcSetEnv new_env $
 338             zonkExpr te expr    `thenNF_Tc` \ new_expr  ->
 339             returnNF_Tc (GRHS new_guard new_expr locn)
 340     in
 341     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 342     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 343     returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
 344 \end{code}
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 zonkExpr :: TyVarEnv Type
 354          -> TcExpr s -> NF_TcM s TypecheckedHsExpr
 355
 356 zonkExpr te (HsVar id)
 357   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 358     returnNF_Tc (HsVar id')
 359
 360 zonkExpr te (HsLit _) = panic "zonkExpr te:HsLit"
 361
 362 zonkExpr te (HsLitOut lit ty)
 363   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 364     returnNF_Tc (HsLitOut lit new_ty)
 365
 366 zonkExpr te (HsLam match)
 367   = zonkMatch te match  `thenNF_Tc` \ new_match ->
 368     returnNF_Tc (HsLam new_match)
 369
 370 zonkExpr te (HsApp e1 e2)
 371   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 372     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 373     returnNF_Tc (HsApp new_e1 new_e2)
 374
 375 zonkExpr te (OpApp e1 op fixity e2)
 376   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 377     zonkExpr te op      `thenNF_Tc` \ new_op ->
 378     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 379     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 380
 381 zonkExpr te (NegApp _ _) = panic "zonkExpr te:NegApp"
 382 zonkExpr te (HsPar _)    = panic "zonkExpr te:HsPar"
 383
 384 zonkExpr te (SectionL expr op)
 385   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 386     zonkExpr te op              `thenNF_Tc` \ new_op ->
 387     returnNF_Tc (SectionL new_expr new_op)
 388
 389 zonkExpr te (SectionR op expr)
 390   = zonkExpr te op              `thenNF_Tc` \ new_op ->
 391     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 392     returnNF_Tc (SectionR new_op new_expr)
 393
 394 zonkExpr te (HsCase expr ms src_loc)
 395   = zonkExpr te expr                `thenNF_Tc` \ new_expr ->
 396     mapNF_Tc (zonkMatch te) ms   `thenNF_Tc` \ new_ms ->
 397     returnNF_Tc (HsCase new_expr new_ms src_loc)
 398
 399 zonkExpr te (HsIf e1 e2 e3 src_loc)
 400   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 401     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 402     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 403     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 404
 405 zonkExpr te (HsLet binds expr)
 406   = zonkBinds te binds          `thenNF_Tc` \ (new_binds, new_env) ->
 407     tcSetEnv new_env            $
 408     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 409     returnNF_Tc (HsLet new_binds new_expr)
 410
 411 zonkExpr te (HsDo _ _ _) = panic "zonkExpr te:HsDo"
 412
 413 zonkExpr te (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 414   = zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, _) ->
 415     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 416     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 417     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 418     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 419     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 420                          new_ty src_loc)
 421
 422 zonkExpr te (ExplicitList _) = panic "zonkExpr te:ExplicitList"
 423
 424 zonkExpr te (ExplicitListOut ty exprs)
 425   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 426     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 427     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 428
 429 zonkExpr te (ExplicitTuple exprs)
 430   = mapNF_Tc (zonkExpr te) exprs  `thenNF_Tc` \ new_exprs ->
 431     returnNF_Tc (ExplicitTuple new_exprs)
 432
 433 zonkExpr te (HsCon con_id tys exprs)
 434   = mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 435     mapNF_Tc (zonkExpr te) exprs        `thenNF_Tc` \ new_exprs ->
 436     returnNF_Tc (HsCon con_id new_tys new_exprs)
 437
 438 zonkExpr te (RecordCon con_id con_expr rbinds)
 439   = zonkIdOcc con_id            `thenNF_Tc` \ new_con_id ->
 440     zonkExpr te con_expr        `thenNF_Tc` \ new_con_expr ->
 441     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 442     returnNF_Tc (RecordCon new_con_id new_con_expr new_rbinds)
 443
 444 zonkExpr te (RecordUpd _ _) = panic "zonkExpr te:RecordUpd"
 445
 446 zonkExpr te (RecordUpdOut expr ty dicts rbinds)
 447   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 448     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 449     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 450     zonkRbinds te rbinds        `thenNF_Tc` \ new_rbinds ->
 451     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 452
 453 zonkExpr te (ExprWithTySig _ _) = panic "zonkExpr te:ExprWithTySig"
 454 zonkExpr te (ArithSeqIn _) = panic "zonkExpr te:ArithSeqIn"
 455
 456 zonkExpr te (ArithSeqOut expr info)
 457   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 458     zonkArithSeq te info        `thenNF_Tc` \ new_info ->
 459     returnNF_Tc (ArithSeqOut new_expr new_info)
 460
 461 zonkExpr te (CCall fun args may_gc is_casm result_ty)
 462   = mapNF_Tc (zonkExpr te) args         `thenNF_Tc` \ new_args ->
 463     zonkTcTypeToType te result_ty       `thenNF_Tc` \ new_result_ty ->
 464     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 465
 466 zonkExpr te (HsSCC label expr)
 467   = zonkExpr te expr    `thenNF_Tc` \ new_expr ->
 468     returnNF_Tc (HsSCC label new_expr)
 469
 470 zonkExpr te (TyLam tyvars expr)
 471   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 472     let
 473         new_te = extend_te te new_tyvars
 474     in
 475     zonkExpr new_te expr                `thenNF_Tc` \ new_expr ->
 476     returnNF_Tc (TyLam new_tyvars new_expr)
 477
 478 zonkExpr te (TyApp expr tys)
 479   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 480     mapNF_Tc (zonkTcTypeToType te) tys  `thenNF_Tc` \ new_tys ->
 481     returnNF_Tc (TyApp new_expr new_tys)
 482
 483 zonkExpr te (DictLam dicts expr)
 484   = mapNF_Tc (zonkIdBndr te) dicts      `thenNF_Tc` \ new_dicts ->
 485     tcExtendGlobalValEnv new_dicts      $
 486     zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 487     returnNF_Tc (DictLam new_dicts new_expr)
 488
 489 zonkExpr te (DictApp expr dicts)
 490   = zonkExpr te expr                    `thenNF_Tc` \ new_expr ->
 491     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 492     returnNF_Tc (DictApp new_expr new_dicts)
 493
 494
 495
 496 -------------------------------------------------------------------------
 497 zonkArithSeq :: TyVarEnv Type
 498              -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
 499
 500 zonkArithSeq te (From e)
 501   = zonkExpr te e               `thenNF_Tc` \ new_e ->
 502     returnNF_Tc (From new_e)
 503
 504 zonkArithSeq te (FromThen e1 e2)
 505   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 506     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 507     returnNF_Tc (FromThen new_e1 new_e2)
 508
 509 zonkArithSeq te (FromTo e1 e2)
 510   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 511     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 512     returnNF_Tc (FromTo new_e1 new_e2)
 513
 514 zonkArithSeq te (FromThenTo e1 e2 e3)
 515   = zonkExpr te e1      `thenNF_Tc` \ new_e1 ->
 516     zonkExpr te e2      `thenNF_Tc` \ new_e2 ->
 517     zonkExpr te e3      `thenNF_Tc` \ new_e3 ->
 518     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 519
 520 -------------------------------------------------------------------------
 521 zonkStmts :: TyVarEnv Type
 522           -> [TcStmt s] -> NF_TcM s ([TypecheckedStmt], TcEnv s)
 523
 524 zonkStmts te [] = tcGetEnv      `thenNF_Tc` \ env ->
 525                   returnNF_Tc ([], env)
 526
 527 zonkStmts te [ReturnStmt expr]
 528   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 529     tcGetEnv                    `thenNF_Tc` \ env ->
 530     returnNF_Tc ([ReturnStmt new_expr], env)
 531
 532 zonkStmts te (ExprStmt expr locn : stmts)
 533   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 534     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 535     returnNF_Tc (ExprStmt new_expr locn : new_stmts, new_env)
 536
 537 zonkStmts te (GuardStmt expr locn : stmts)
 538   = zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 539     zonkStmts te        stmts   `thenNF_Tc` \ (new_stmts, new_env) ->
 540     returnNF_Tc (GuardStmt new_expr locn : new_stmts, new_env)
 541
 542 zonkStmts te (LetStmt binds : stmts)
 543   = zonkBinds te     binds      `thenNF_Tc` \ (new_binds, new_env) ->
 544     tcSetEnv new_env            $
 545     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env2) ->
 546     returnNF_Tc (LetStmt new_binds : new_stmts, new_env2)
 547
 548 zonkStmts te (BindStmt pat expr locn : stmts)
 549   = zonkPat te pat              `thenNF_Tc` \ (new_pat, ids) ->
 550     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 551     tcExtendGlobalValEnv (bagToList ids)        $
 552     zonkStmts te stmts          `thenNF_Tc` \ (new_stmts, new_env) ->
 553     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts, new_env)
 554
 555
 556
 557 -------------------------------------------------------------------------
 558 zonkRbinds :: TyVarEnv Type
 559            -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds
 560
 561 zonkRbinds te rbinds
 562   = mapNF_Tc zonk_rbind rbinds
 563   where
 564     zonk_rbind (field, expr, pun)
 565       = zonkExpr te expr        `thenNF_Tc` \ new_expr ->
 566         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 567         returnNF_Tc (new_field, new_expr, pun)
 568 \end{code}
 569
 570 %************************************************************************
 571 %*                                                                      *
 572 \subsection[BackSubst-Pats]{Patterns}
 573 %*                                                                      *
 574 %************************************************************************
 575
 576 \begin{code}
 577 zonkPat :: TyVarEnv Type
 578         -> TcPat s -> NF_TcM s (TypecheckedPat, Bag Id)
 579
 580 zonkPat te (WildPat ty)
 581   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty ->
 582     returnNF_Tc (WildPat new_ty, emptyBag)
 583
 584 zonkPat te (VarPat v)
 585   = zonkIdBndr te v         `thenNF_Tc` \ new_v ->
 586     returnNF_Tc (VarPat new_v, unitBag new_v)
 587
 588 zonkPat te (LazyPat pat)
 589   = zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 590     returnNF_Tc (LazyPat new_pat, ids)
 591
 592 zonkPat te (AsPat n pat)
 593   = zonkIdBndr te n         `thenNF_Tc` \ new_n ->
 594     zonkPat te pat          `thenNF_Tc` \ (new_pat, ids) ->
 595     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 596
 597 zonkPat te (ConPat n ty pats)
 598   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 599     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 600     returnNF_Tc (ConPat n new_ty new_pats, ids)
 601
 602 zonkPat te (ConOpPat pat1 op pat2 ty)
 603   = zonkPat te pat1         `thenNF_Tc` \ (new_pat1, ids1) ->
 604     zonkPat te pat2         `thenNF_Tc` \ (new_pat2, ids2) ->
 605     zonkTcTypeToType te ty  `thenNF_Tc` \ new_ty ->
 606     returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 `unionBags` ids2)
 607
 608 zonkPat te (ListPat ty pats)
 609   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 610     zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 611     returnNF_Tc (ListPat new_ty new_pats, ids)
 612
 613 zonkPat te (TuplePat pats)
 614   = zonkPats te pats            `thenNF_Tc` \ (new_pats, ids) ->
 615     returnNF_Tc (TuplePat new_pats, ids)
 616
 617 zonkPat te (RecPat n ty rpats)
 618   = zonkTcTypeToType te ty              `thenNF_Tc` \ new_ty ->
 619     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 620     returnNF_Tc (RecPat n new_ty new_rpats, unionManyBags ids_s)
 621   where
 622     zonk_rpat (f, pat, pun)
 623       = zonkPat te pat       `thenNF_Tc` \ (new_pat, ids) ->
 624         returnNF_Tc ((f, new_pat, pun), ids)
 625
 626 zonkPat te (LitPat lit ty)
 627   = zonkTcTypeToType te ty          `thenNF_Tc` \ new_ty  ->
 628     returnNF_Tc (LitPat lit new_ty, emptyBag)
 629
 630 zonkPat te (NPat lit ty expr)
 631   = zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty   ->
 632     zonkExpr te expr            `thenNF_Tc` \ new_expr ->
 633     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 634
 635 zonkPat te (NPlusKPat n k ty e1 e2)
 636   = zonkIdBndr te n             `thenNF_Tc` \ new_n ->
 637     zonkTcTypeToType te ty      `thenNF_Tc` \ new_ty ->
 638     zonkExpr te e1              `thenNF_Tc` \ new_e1 ->
 639     zonkExpr te e2              `thenNF_Tc` \ new_e2 ->
 640     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 641
 642 zonkPat te (DictPat ds ms)
 643   = mapNF_Tc (zonkIdBndr te) ds    `thenNF_Tc` \ new_ds ->
 644     mapNF_Tc (zonkIdBndr te) ms    `thenNF_Tc` \ new_ms ->
 645     returnNF_Tc (DictPat new_ds new_ms,
 646                  listToBag new_ds `unionBags` listToBag new_ms)
 647
 648
 649 zonkPats te []
 650   = returnNF_Tc ([], emptyBag)
 651 zonkPats te (pat:pats)
 652   = zonkPat te pat      `thenNF_Tc` \ (pat', ids1) ->
 653     zonkPats te pats    `thenNF_Tc` \ (pats', ids2) ->
 654     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 655 \end{code}
 656
 657