ghc/compiler/typecheck/TcHsSyn.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   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         TcMonoBinds, TcHsBinds, TcPat,
  12         TcExpr, TcGRHSs, TcGRHS, TcMatch,
  13         TcStmt, TcArithSeqInfo, TcRecordBinds,
  14         TcHsModule, TcCoreExpr, TcDictBinds,
  15         TcForeignExportDecl,
  16
  17         TypecheckedHsBinds, TypecheckedRuleDecl,
  18         TypecheckedMonoBinds, TypecheckedPat,
  19         TypecheckedHsExpr, TypecheckedArithSeqInfo,
  20         TypecheckedStmt, TypecheckedForeignDecl,
  21         TypecheckedMatch, TypecheckedHsModule,
  22         TypecheckedGRHSs, TypecheckedGRHS,
  23         TypecheckedRecordBinds, TypecheckedDictBinds,
  24
  25         mkHsTyApp, mkHsDictApp,
  26         mkHsTyLam, mkHsDictLam, mkHsLet,
  27
  28         -- re-exported from TcEnv
  29         TcId, tcInstId,
  30
  31         maybeBoxedPrimType,
  32
  33         zonkTopBinds, zonkId, zonkIdOcc,
  34         zonkForeignExports, zonkRules
  35   ) where
  36
  37 #include "HsVersions.h"
  38
  39 -- friends:
  40 import HsSyn    -- oodles of it
  41
  42 -- others:
  43 import Id       ( idName, idType, setIdType, omitIfaceSigForId, Id )
  44 import DataCon  ( DataCon, dataConArgTys )
  45 import TcEnv    ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
  46                   ValueEnv, TcId, tcInstId
  47                 )
  48
  49 import TcMonad
  50 import TcType   ( TcType, TcTyVar,
  51                   zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
  52                 )
  53 import TyCon    ( isDataTyCon )
  54 import Type     ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
  55 import Name     ( isLocallyDefined )
  56 import Var      ( TyVar )
  57 import VarEnv   ( TyVarEnv, emptyVarEnv, extendVarEnvList )
  58 import VarSet   ( isEmptyVarSet )
  59 import CoreSyn  ( Expr )
  60 import BasicTypes ( RecFlag(..) )
  61 import Bag
  62 import UniqFM
  63 import Outputable
  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 TcHsBinds          = HsBinds TcId TcPat
  79 type TcMonoBinds        = MonoBinds TcId TcPat
  80 type TcDictBinds        = TcMonoBinds
  81 type TcPat              = OutPat TcId
  82 type TcExpr             = HsExpr TcId TcPat
  83 type TcGRHSs            = GRHSs TcId TcPat
  84 type TcGRHS             = GRHS TcId TcPat
  85 type TcMatch            = Match TcId TcPat
  86 type TcStmt             = Stmt TcId TcPat
  87 type TcArithSeqInfo     = ArithSeqInfo TcId TcPat
  88 type TcRecordBinds      = HsRecordBinds TcId TcPat
  89 type TcHsModule = HsModule TcId TcPat
  90
  91 type TcCoreExpr = Expr TcId
  92 type TcForeignExportDecl = ForeignDecl TcId
  93 type TcRuleDecl          = RuleDecl    TcId TcPat
  94
  95 type TypecheckedPat             = OutPat        Id
  96 type TypecheckedMonoBinds       = MonoBinds     Id TypecheckedPat
  97 type TypecheckedDictBinds       = TypecheckedMonoBinds
  98 type TypecheckedHsBinds         = HsBinds       Id TypecheckedPat
  99 type TypecheckedHsExpr          = HsExpr        Id TypecheckedPat
 100 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id TypecheckedPat
 101 type TypecheckedStmt            = Stmt          Id TypecheckedPat
 102 type TypecheckedMatch           = Match         Id TypecheckedPat
 103 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
 104 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
 105 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
 106 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
 107 type TypecheckedForeignDecl     = ForeignDecl Id
 108 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 109 \end{code}
 110
 111 \begin{code}
 112 mkHsTyApp expr []  = expr
 113 mkHsTyApp expr tys = TyApp expr tys
 114
 115 mkHsDictApp expr []      = expr
 116 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 117
 118 mkHsTyLam []     expr = expr
 119 mkHsTyLam tyvars expr = TyLam tyvars expr
 120
 121 mkHsDictLam []    expr = expr
 122 mkHsDictLam dicts expr = DictLam dicts expr
 123
 124 mkHsLet EmptyMonoBinds expr = expr
 125 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 Some gruesome hackery for desugaring ccalls. It's here because if we put it
 135 in Type.lhs we get irritating loops, and it's only used by TcInstDcls.lhs and
 136 DsCCall.lhs.
 137
 138 \begin{code}
 139 maybeBoxedPrimType :: Type -> Maybe (DataCon, Type)
 140 maybeBoxedPrimType ty
 141   = case splitAlgTyConApp_maybe ty of                                   -- Data type,
 142       Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon         -- with exactly one constructor
 143         -> case (dataConArgTys data_con tys_applied) of
 144              [data_con_arg_ty]                          -- Applied to exactly one type,
 145                 | isUnLiftedType data_con_arg_ty        -- which is primitive
 146                 -> Just (data_con, data_con_arg_ty)
 147              other_cases -> Nothing
 148       other_cases -> Nothing
 149 \end{code}
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 This zonking pass runs over the bindings
 158
 159  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 160  b) convert unbound TcTyVar to Void
 161  c) convert each TcId to an Id by zonking its type
 162
 163 The type variables are converted by binding mutable tyvars to immutable ones
 164 and then zonking as normal.
 165
 166 The Ids are converted by binding them in the normal Tc envt; that
 167 way we maintain sharing; eg an Id is zonked at its binding site and they
 168 all occurrences of that Id point to the common zonked copy
 169
 170 It's all pretty boring stuff, because HsSyn is such a large type, and
 171 the environment manipulation is tiresome.
 172
 173 \begin{code}
 174 -- zonkId is used *during* typechecking just to zonk the Id's type
 175 zonkId :: TcId -> NF_TcM s TcId
 176 zonkId id
 177   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 178     returnNF_Tc (setIdType id ty')
 179
 180 -- zonkIdBndr is used *after* typechecking to get the Id's type
 181 -- to its final form.  The TyVarEnv give
 182 zonkIdBndr :: TcId -> NF_TcM s Id
 183 zonkIdBndr id
 184   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 185     returnNF_Tc (setIdType id ty')
 186
 187 zonkIdOcc :: TcId -> NF_TcM s Id
 188 zonkIdOcc id
 189   | not (isLocallyDefined id) || omitIfaceSigForId id
 190         -- The omitIfaceSigForId thing may look wierd but it's quite
 191         -- sensible really.  We're avoiding looking up superclass selectors
 192         -- and constructors; zonking them is a no-op anyway, and the
 193         -- superclass selectors aren't in the environment anyway.
 194   = returnNF_Tc id
 195   | otherwise
 196   = tcLookupValueMaybe (idName id)      `thenNF_Tc` \ maybe_id' ->
 197     let
 198         new_id = case maybe_id' of
 199                     Just id' -> id'
 200                     Nothing  -> pprTrace "zonkIdOcc: " (ppr id) id
 201     in
 202     returnNF_Tc new_id
 203 \end{code}
 204
 205
 206 \begin{code}
 207 zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv)
 208 zonkTopBinds binds      -- Top level is implicitly recursive
 209   = fixNF_Tc (\ ~(_, new_ids) ->
 210         tcExtendGlobalValEnv (bagToList new_ids)        $
 211         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 212         tcGetValueEnv                           `thenNF_Tc` \ env ->
 213         returnNF_Tc ((binds', env), new_ids)
 214     )                                   `thenNF_Tc` \ (stuff, _) ->
 215     returnNF_Tc stuff
 216
 217 zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 218
 219 zonkBinds binds
 220   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 221                           returnNF_Tc (binds', env))
 222   where
 223     -- go :: TcHsBinds
 224     --    -> (TypecheckedHsBinds
 225     --        -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 226     --       )
 227     --    -> NF_TcM s (TypecheckedHsBinds, TcEnv)
 228
 229     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 230                                         go b2   $ \ b2' ->
 231                                         thing_inside (b1' `ThenBinds` b2')
 232
 233     go EmptyBinds thing_inside = thing_inside EmptyBinds
 234
 235     go (MonoBind bind sigs is_rec) thing_inside
 236           = ASSERT( null sigs )
 237             fixNF_Tc (\ ~(_, new_ids) ->
 238                 tcExtendGlobalValEnv (bagToList new_ids)        $
 239                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 240                 thing_inside (MonoBind new_bind [] is_rec)      `thenNF_Tc` \ stuff ->
 241                 returnNF_Tc (stuff, new_ids)
 242             )                                                   `thenNF_Tc` \ (stuff, _) ->
 243            returnNF_Tc stuff
 244 \end{code}
 245
 246 \begin{code}
 247 -------------------------------------------------------------------------
 248 zonkMonoBinds :: TcMonoBinds
 249               -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
 250
 251 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 252
 253 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 254   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 255     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 256     returnNF_Tc (b1' `AndMonoBinds` b2',
 257                  ids1 `unionBags` ids2)
 258
 259 zonkMonoBinds (PatMonoBind pat grhss locn)
 260   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 261     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 262     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 263
 264 zonkMonoBinds (VarMonoBind var expr)
 265   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 266     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 267     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 268
 269 zonkMonoBinds (CoreMonoBind var core_expr)
 270   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 271     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 272
 273 zonkMonoBinds (FunMonoBind var inf ms locn)
 274   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 275     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 276     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 277
 278
 279 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 280   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 281         -- No need to extend tyvar env: the effects are
 282         -- propagated through binding the tyvars themselves
 283
 284     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 285     tcExtendGlobalValEnv new_dicts                      $
 286
 287     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 288         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 289         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 290         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 291         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 292     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 293     let
 294             new_globals = listToBag [global | (_, global, local) <- new_exports]
 295     in
 296     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 297                  new_globals)
 298   where
 299     zonkExport (tyvars, global, local)
 300         = mapNF_Tc zonkTcTyVarBndr tyvars       `thenNF_Tc` \ new_tyvars ->
 301           zonkIdBndr global                     `thenNF_Tc` \ new_global ->
 302           zonkIdOcc local                       `thenNF_Tc` \ new_local ->
 303           returnNF_Tc (new_tyvars, new_global, new_local)
 304 \end{code}
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 \begin{code}
 313 zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch
 314
 315 zonkMatch (Match _ pats _ grhss)
 316   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 317     tcExtendGlobalValEnv (bagToList new_ids)    $
 318     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 319     returnNF_Tc (Match [] new_pats Nothing new_grhss)
 320
 321 -------------------------------------------------------------------------
 322 zonkGRHSs :: TcGRHSs
 323           -> NF_TcM s TypecheckedGRHSs
 324
 325 zonkGRHSs (GRHSs grhss binds (Just ty))
 326   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 327     tcSetEnv new_env $
 328     let
 329         zonk_grhs (GRHS guarded locn)
 330           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 331             returnNF_Tc (GRHS new_guarded locn)
 332     in
 333     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 334     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 335     returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty))
 336 \end{code}
 337
 338 %************************************************************************
 339 %*                                                                      *
 340 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 341 %*                                                                      *
 342 %************************************************************************
 343
 344 \begin{code}
 345 zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
 346
 347 zonkExpr (HsVar id)
 348   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 349     returnNF_Tc (HsVar id')
 350
 351 zonkExpr (HsLit _) = panic "zonkExpr:HsLit"
 352
 353 zonkExpr (HsLitOut lit ty)
 354   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 355     returnNF_Tc (HsLitOut lit new_ty)
 356
 357 zonkExpr (HsLam match)
 358   = zonkMatch match     `thenNF_Tc` \ new_match ->
 359     returnNF_Tc (HsLam new_match)
 360
 361 zonkExpr (HsApp e1 e2)
 362   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 363     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 364     returnNF_Tc (HsApp new_e1 new_e2)
 365
 366 zonkExpr (OpApp e1 op fixity e2)
 367   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 368     zonkExpr op `thenNF_Tc` \ new_op ->
 369     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 370     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 371
 372 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 373 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 374
 375 zonkExpr (SectionL expr op)
 376   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 377     zonkExpr op         `thenNF_Tc` \ new_op ->
 378     returnNF_Tc (SectionL new_expr new_op)
 379
 380 zonkExpr (SectionR op expr)
 381   = zonkExpr op         `thenNF_Tc` \ new_op ->
 382     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 383     returnNF_Tc (SectionR new_op new_expr)
 384
 385 zonkExpr (HsCase expr ms src_loc)
 386   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 387     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 388     returnNF_Tc (HsCase new_expr new_ms src_loc)
 389
 390 zonkExpr (HsIf e1 e2 e3 src_loc)
 391   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 392     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 393     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 394     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 395
 396 zonkExpr (HsLet binds expr)
 397   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 398     tcSetEnv new_env            $
 399     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 400     returnNF_Tc (HsLet new_binds new_expr)
 401
 402 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 403
 404 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 405   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 406     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 407     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 408     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 409     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 410     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 411                          new_ty src_loc)
 412
 413 zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList"
 414
 415 zonkExpr (ExplicitListOut ty exprs)
 416   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 417     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 418     returnNF_Tc (ExplicitListOut new_ty new_exprs)
 419
 420 zonkExpr (ExplicitTuple exprs boxed)
 421   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 422     returnNF_Tc (ExplicitTuple new_exprs boxed)
 423
 424 zonkExpr (HsCon data_con tys exprs)
 425   = mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 426     mapNF_Tc zonkExpr exprs             `thenNF_Tc` \ new_exprs ->
 427     returnNF_Tc (HsCon data_con new_tys new_exprs)
 428
 429 zonkExpr (RecordConOut data_con con_expr rbinds)
 430   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 431     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 432     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 433
 434 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 435
 436 zonkExpr (RecordUpdOut expr ty dicts rbinds)
 437   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 438     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 439     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 440     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 441     returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds)
 442
 443 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 444 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 445
 446 zonkExpr (ArithSeqOut expr info)
 447   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 448     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 449     returnNF_Tc (ArithSeqOut new_expr new_info)
 450
 451 zonkExpr (CCall fun args may_gc is_casm result_ty)
 452   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 453     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 454     returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
 455
 456 zonkExpr (HsSCC label expr)
 457   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 458     returnNF_Tc (HsSCC label new_expr)
 459
 460 zonkExpr (TyLam tyvars expr)
 461   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 462         -- No need to extend tyvar env; see AbsBinds
 463
 464     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 465     returnNF_Tc (TyLam new_tyvars new_expr)
 466
 467 zonkExpr (TyApp expr tys)
 468   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 469     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 470     returnNF_Tc (TyApp new_expr new_tys)
 471
 472 zonkExpr (DictLam dicts expr)
 473   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 474     tcExtendGlobalValEnv new_dicts      $
 475     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 476     returnNF_Tc (DictLam new_dicts new_expr)
 477
 478 zonkExpr (DictApp expr dicts)
 479   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 480     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 481     returnNF_Tc (DictApp new_expr new_dicts)
 482
 483
 484
 485 -------------------------------------------------------------------------
 486 zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
 487
 488 zonkArithSeq (From e)
 489   = zonkExpr e          `thenNF_Tc` \ new_e ->
 490     returnNF_Tc (From new_e)
 491
 492 zonkArithSeq (FromThen e1 e2)
 493   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 494     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 495     returnNF_Tc (FromThen new_e1 new_e2)
 496
 497 zonkArithSeq (FromTo e1 e2)
 498   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 499     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 500     returnNF_Tc (FromTo new_e1 new_e2)
 501
 502 zonkArithSeq (FromThenTo e1 e2 e3)
 503   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 504     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 505     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 506     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 507
 508 -------------------------------------------------------------------------
 509 zonkStmts :: [TcStmt]
 510           -> NF_TcM s [TypecheckedStmt]
 511
 512 zonkStmts [] = returnNF_Tc []
 513
 514 zonkStmts [ReturnStmt expr]
 515   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 516     returnNF_Tc [ReturnStmt new_expr]
 517
 518 zonkStmts (ExprStmt expr locn : stmts)
 519   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 520     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 521     returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 522
 523 zonkStmts (GuardStmt expr locn : stmts)
 524   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 525     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 526     returnNF_Tc (GuardStmt new_expr locn : new_stmts)
 527
 528 zonkStmts (LetStmt binds : stmts)
 529   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 530     tcSetEnv new_env            $
 531     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 532     returnNF_Tc (LetStmt new_binds : new_stmts)
 533
 534 zonkStmts (BindStmt pat expr locn : stmts)
 535   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 536     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 537     tcExtendGlobalValEnv (bagToList new_ids)    $
 538     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 539     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 540
 541
 542
 543 -------------------------------------------------------------------------
 544 zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
 545
 546 zonkRbinds rbinds
 547   = mapNF_Tc zonk_rbind rbinds
 548   where
 549     zonk_rbind (field, expr, pun)
 550       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 551         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 552         returnNF_Tc (new_field, new_expr, pun)
 553 \end{code}
 554
 555 %************************************************************************
 556 %*                                                                      *
 557 \subsection[BackSubst-Pats]{Patterns}
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 \begin{code}
 562 zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id)
 563
 564 zonkPat (WildPat ty)
 565   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 566     returnNF_Tc (WildPat new_ty, emptyBag)
 567
 568 zonkPat (VarPat v)
 569   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 570     returnNF_Tc (VarPat new_v, unitBag new_v)
 571
 572 zonkPat (LazyPat pat)
 573   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 574     returnNF_Tc (LazyPat new_pat, ids)
 575
 576 zonkPat (AsPat n pat)
 577   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 578     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 579     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 580
 581 zonkPat (ListPat ty pats)
 582   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 583     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 584     returnNF_Tc (ListPat new_ty new_pats, ids)
 585
 586 zonkPat (TuplePat pats boxed)
 587   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 588     returnNF_Tc (TuplePat new_pats boxed, ids)
 589
 590 zonkPat (ConPat n ty tvs dicts pats)
 591   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 592     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 593     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 594     tcExtendGlobalValEnv new_dicts      $
 595     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 596     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 597                  listToBag new_dicts `unionBags` ids)
 598
 599 zonkPat (RecPat n ty tvs dicts rpats)
 600   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 601     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 602     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 603     tcExtendGlobalValEnv new_dicts      $
 604     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 605     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 606                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 607   where
 608     zonk_rpat (f, pat, pun)
 609       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 610         returnNF_Tc ((f, new_pat, pun), ids)
 611
 612 zonkPat (LitPat lit ty)
 613   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 614     returnNF_Tc (LitPat lit new_ty, emptyBag)
 615
 616 zonkPat (NPat lit ty expr)
 617   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 618     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 619     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 620
 621 zonkPat (NPlusKPat n k ty e1 e2)
 622   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 623     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 624     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 625     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 626     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 627
 628 zonkPat (DictPat ds ms)
 629   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 630     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 631     returnNF_Tc (DictPat new_ds new_ms,
 632                  listToBag new_ds `unionBags` listToBag new_ms)
 633
 634
 635 zonkPats []
 636   = returnNF_Tc ([], emptyBag)
 637
 638 zonkPats (pat:pats)
 639   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 640     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 641     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 642 \end{code}
 643
 644 %************************************************************************
 645 %*                                                                      *
 646 \subsection[BackSubst-Foreign]{Foreign exports}
 647 %*                                                                      *
 648 %************************************************************************
 649
 650
 651 \begin{code}
 652 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl]
 653 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 654
 655 zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl)
 656 zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) =
 657    zonkIdOcc i  `thenNF_Tc` \ i' ->
 658    returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc)
 659 \end{code}
 660
 661 \begin{code}
 662 zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl]
 663 zonkRules rs = mapNF_Tc zonkRule rs
 664
 665 zonkRule (RuleDecl name tyvars vars lhs rhs loc)
 666   = mapNF_Tc zonkTcTyVarToTyVar tyvars                  `thenNF_Tc` \ new_tyvars ->
 667     mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars]        `thenNF_Tc` \ new_bndrs ->
 668     tcExtendGlobalValEnv new_bndrs                      $
 669     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 670     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 671     returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 672         -- I hate this map RuleBndr stuff
 673
 674 zonkRule (IfaceRuleDecl fun rule loc)
 675   = returnNF_Tc (IfaceRuleDecl fun rule loc)
 676 \end{code}