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