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