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