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