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