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