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