ghc/compiler/typecheck/TcHsSyn.lhs

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