ghc/compiler/typecheck/TcHsSyn.lhs

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