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         TypecheckedMatchContext,
  25
  26         mkHsTyApp, mkHsDictApp, mkHsConApp,
  27         mkHsTyLam, mkHsDictLam, mkHsLet,
  28         simpleHsLitTy,
  29
  30         collectTypedPatBinders, outPatType,
  31
  32         -- re-exported from TcEnv
  33         TcId,
  34
  35         zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
  36         zonkForeignExports, zonkRules
  37   ) where
  38
  39 #include "HsVersions.h"
  40
  41 -- friends:
  42 import HsSyn    -- oodles of it
  43
  44 -- others:
  45 import Id       ( idName, idType, setIdType, Id )
  46 import DataCon  ( dataConWrapId )
  47 import TcEnv    ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
  48
  49 import TcMonad
  50 import TypeRep    ( IPName(..) )        -- For zonking
  51 import Type       ( Type, ipNameName )
  52 import TcType     ( TcType )
  53 import TcMType    ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
  54 import TysPrim    ( charPrimTy, intPrimTy, floatPrimTy,
  55                     doublePrimTy, addrPrimTy
  56                   )
  57 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
  58                     mkListTy, mkTupleTy, unitTy )
  59 import CoreSyn    ( Expr )
  60 import Var        ( isId )
  61 import BasicTypes ( RecFlag(..), Boxity(..) )
  62 import Bag
  63 import Outputable
  64 import HscTypes ( TyThing(..) )
  65 \end{code}
  66
  67
  68 Type definitions
  69 ~~~~~~~~~~~~~~~~
  70
  71 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  72 All the types in @Tc...@ things have mutable type-variables in them for
  73 unification.
  74
  75 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  76 which have immutable type variables in them.
  77
  78 \begin{code}
  79 type TcHsBinds          = HsBinds TcId TcPat
  80 type TcMonoBinds        = MonoBinds TcId TcPat
  81 type TcDictBinds        = TcMonoBinds
  82 type TcPat              = OutPat TcId
  83 type TcExpr             = HsExpr TcId TcPat
  84 type TcGRHSs            = GRHSs TcId TcPat
  85 type TcGRHS             = GRHS TcId TcPat
  86 type TcMatch            = Match TcId TcPat
  87 type TcStmt             = Stmt TcId TcPat
  88 type TcArithSeqInfo     = ArithSeqInfo TcId TcPat
  89 type TcRecordBinds      = HsRecordBinds TcId TcPat
  90 type TcHsModule = HsModule TcId TcPat
  91
  92 type TcCoreExpr = Expr TcId
  93 type TcForeignExportDecl = ForeignDecl TcId
  94 type TcRuleDecl          = RuleDecl    TcId TcPat
  95
  96 type TypecheckedPat             = OutPat        Id
  97 type TypecheckedMonoBinds       = MonoBinds     Id TypecheckedPat
  98 type TypecheckedDictBinds       = TypecheckedMonoBinds
  99 type TypecheckedHsBinds         = HsBinds       Id TypecheckedPat
 100 type TypecheckedHsExpr          = HsExpr        Id TypecheckedPat
 101 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id TypecheckedPat
 102 type TypecheckedStmt            = Stmt          Id TypecheckedPat
 103 type TypecheckedMatch           = Match         Id TypecheckedPat
 104 type TypecheckedMatchContext    = HsMatchContext Id
 105 type TypecheckedGRHSs           = GRHSs         Id TypecheckedPat
 106 type TypecheckedGRHS            = GRHS          Id TypecheckedPat
 107 type TypecheckedRecordBinds     = HsRecordBinds Id TypecheckedPat
 108 type TypecheckedHsModule        = HsModule      Id TypecheckedPat
 109 type TypecheckedForeignDecl     = ForeignDecl Id
 110 type TypecheckedRuleDecl        = RuleDecl      Id TypecheckedPat
 111 \end{code}
 112
 113 \begin{code}
 114 mkHsTyApp expr []  = expr
 115 mkHsTyApp expr tys = TyApp expr tys
 116
 117 mkHsDictApp expr []      = expr
 118 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 119
 120 mkHsTyLam []     expr = expr
 121 mkHsTyLam tyvars expr = TyLam tyvars expr
 122
 123 mkHsDictLam []    expr = expr
 124 mkHsDictLam dicts expr = DictLam dicts expr
 125
 126 mkHsLet EmptyMonoBinds expr = expr
 127 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 128
 129 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 130 \end{code}
 131
 132
 133 ------------------------------------------------------
 134 \begin{code}
 135 simpleHsLitTy :: HsLit -> TcType
 136 simpleHsLitTy (HsCharPrim c)   = charPrimTy
 137 simpleHsLitTy (HsStringPrim s) = addrPrimTy
 138 simpleHsLitTy (HsInt i)        = intTy
 139 simpleHsLitTy (HsInteger i)    = integerTy
 140 simpleHsLitTy (HsIntPrim i)    = intPrimTy
 141 simpleHsLitTy (HsFloatPrim f)  = floatPrimTy
 142 simpleHsLitTy (HsDoublePrim d) = doublePrimTy
 143 simpleHsLitTy (HsChar c)       = charTy
 144 simpleHsLitTy (HsString str)   = stringTy
 145 \end{code}
 146
 147
 148 %************************************************************************
 149 %*                                                                      *
 150 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 151 %*                                                                      *
 152 %************************************************************************
 153
 154 Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@,
 155 then something is wrong.
 156 \begin{code}
 157 outPatType :: TypecheckedPat -> Type
 158
 159 outPatType (WildPat ty)         = ty
 160 outPatType (VarPat var)         = idType var
 161 outPatType (LazyPat pat)        = outPatType pat
 162 outPatType (AsPat var pat)      = idType var
 163 outPatType (ConPat _ ty _ _ _)  = ty
 164 outPatType (ListPat ty _)       = mkListTy ty
 165 outPatType (TuplePat pats box)  = mkTupleTy box (length pats) (map outPatType pats)
 166 outPatType (RecPat _ ty _ _ _)  = ty
 167 outPatType (SigPat _ ty _)      = ty
 168 outPatType (LitPat lit ty)      = ty
 169 outPatType (NPat lit ty _)      = ty
 170 outPatType (NPlusKPat _ _ ty _ _) = ty
 171 outPatType (DictPat ds ms)      = case (length ds_ms) of
 172                                     0 -> unitTy
 173                                     1 -> idType (head ds_ms)
 174                                     n -> mkTupleTy Boxed n (map idType ds_ms)
 175                                    where
 176                                     ds_ms = ds ++ ms
 177 \end{code}
 178
 179
 180 Nota bene: @DsBinds@ relies on the fact that at least for simple
 181 tuple patterns @collectTypedPatBinders@ returns the binders in
 182 the same order as they appear in the tuple.
 183
 184 @collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees.
 185
 186 \begin{code}
 187 collectTypedPatBinders :: TypecheckedPat -> [Id]
 188 collectTypedPatBinders (VarPat var)            = [var]
 189 collectTypedPatBinders (LazyPat pat)           = collectTypedPatBinders pat
 190 collectTypedPatBinders (AsPat a pat)           = a : collectTypedPatBinders pat
 191 collectTypedPatBinders (SigPat pat _ _)        = collectTypedPatBinders pat
 192 collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
 193 collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
 194 collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
 195 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
 196                                                           fields)
 197 collectTypedPatBinders (DictPat ds ms)         = ds ++ ms
 198 collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var]
 199 collectTypedPatBinders any_other_pat           = [ {-no binders-} ]
 200 \end{code}
 201
 202
 203 %************************************************************************
 204 %*                                                                      *
 205 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 206 %*                                                                      *
 207 %************************************************************************
 208
 209 This zonking pass runs over the bindings
 210
 211  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 212  b) convert unbound TcTyVar to Void
 213  c) convert each TcId to an Id by zonking its type
 214
 215 The type variables are converted by binding mutable tyvars to immutable ones
 216 and then zonking as normal.
 217
 218 The Ids are converted by binding them in the normal Tc envt; that
 219 way we maintain sharing; eg an Id is zonked at its binding site and they
 220 all occurrences of that Id point to the common zonked copy
 221
 222 It's all pretty boring stuff, because HsSyn is such a large type, and
 223 the environment manipulation is tiresome.
 224
 225 \begin{code}
 226 -- zonkId is used *during* typechecking just to zonk the Id's type
 227 zonkId :: TcId -> NF_TcM TcId
 228 zonkId id
 229   = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
 230     returnNF_Tc (setIdType id ty')
 231
 232 -- zonkIdBndr is used *after* typechecking to get the Id's type
 233 -- to its final form.  The TyVarEnv give
 234 zonkIdBndr :: TcId -> NF_TcM Id
 235 zonkIdBndr id
 236   = zonkTcTypeToType (idType id)        `thenNF_Tc` \ ty' ->
 237     returnNF_Tc (setIdType id ty')
 238
 239 zonkIdOcc :: TcId -> NF_TcM Id
 240 zonkIdOcc id
 241   = tcLookupGlobal_maybe (idName id)    `thenNF_Tc` \ maybe_id' ->
 242         -- We're even look up up superclass selectors and constructors;
 243         -- even though zonking them is a no-op anyway, and the
 244         -- superclass selectors aren't in the environment anyway.
 245         -- But we don't want to call isLocalId to find out whether
 246         -- it's a superclass selector (for example) because that looks
 247         -- at the IdInfo field, which in turn be in a knot because of
 248         -- the big knot in typecheckModule
 249     let
 250         new_id = case maybe_id' of
 251                     Just (AnId id') -> id'
 252                     other           -> id -- WARN( isLocalId id, ppr id ) id
 253                                         -- Oops: the warning can give a black hole
 254                                         -- because it looks at the idinfo
 255     in
 256     returnNF_Tc new_id
 257 \end{code}
 258
 259
 260 \begin{code}
 261 zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 262 zonkTopBinds binds      -- Top level is implicitly recursive
 263   = fixNF_Tc (\ ~(_, new_ids) ->
 264         tcExtendGlobalValEnv (bagToList new_ids)        $
 265         zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
 266         tcGetEnv                                `thenNF_Tc` \ env ->
 267         returnNF_Tc ((binds', env), new_ids)
 268     )                                   `thenNF_Tc` \ (stuff, _) ->
 269     returnNF_Tc stuff
 270
 271 zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv)
 272
 273 zonkBinds binds
 274   = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env ->
 275                           returnNF_Tc (binds', env))
 276   where
 277     -- go :: TcHsBinds
 278     --    -> (TypecheckedHsBinds
 279     --        -> NF_TcM (TypecheckedHsBinds, TcEnv)
 280     --       )
 281     --    -> NF_TcM (TypecheckedHsBinds, TcEnv)
 282
 283     go (ThenBinds b1 b2) thing_inside = go b1   $ \ b1' ->
 284                                         go b2   $ \ b2' ->
 285                                         thing_inside (b1' `ThenBinds` b2')
 286
 287     go EmptyBinds thing_inside = thing_inside EmptyBinds
 288
 289     go (MonoBind bind sigs is_rec) thing_inside
 290           = ASSERT( null sigs )
 291             fixNF_Tc (\ ~(_, new_ids) ->
 292                 tcExtendGlobalValEnv (bagToList new_ids)        $
 293                 zonkMonoBinds bind                              `thenNF_Tc` \ (new_bind, new_ids) ->
 294                 thing_inside (mkMonoBind new_bind [] is_rec)    `thenNF_Tc` \ stuff ->
 295                 returnNF_Tc (stuff, new_ids)
 296             )                                                   `thenNF_Tc` \ (stuff, _) ->
 297            returnNF_Tc stuff
 298 \end{code}
 299
 300 \begin{code}
 301 -------------------------------------------------------------------------
 302 zonkMonoBinds :: TcMonoBinds
 303               -> NF_TcM (TypecheckedMonoBinds, Bag Id)
 304
 305 zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
 306
 307 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
 308   = zonkMonoBinds mbinds1               `thenNF_Tc` \ (b1', ids1) ->
 309     zonkMonoBinds mbinds2               `thenNF_Tc` \ (b2', ids2) ->
 310     returnNF_Tc (b1' `AndMonoBinds` b2',
 311                  ids1 `unionBags` ids2)
 312
 313 zonkMonoBinds (PatMonoBind pat grhss locn)
 314   = zonkPat pat         `thenNF_Tc` \ (new_pat, ids) ->
 315     zonkGRHSs grhss     `thenNF_Tc` \ new_grhss ->
 316     returnNF_Tc (PatMonoBind new_pat new_grhss locn, ids)
 317
 318 zonkMonoBinds (VarMonoBind var expr)
 319   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 320     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 321     returnNF_Tc (VarMonoBind new_var new_expr, unitBag new_var)
 322
 323 zonkMonoBinds (CoreMonoBind var core_expr)
 324   = zonkIdBndr var      `thenNF_Tc` \ new_var ->
 325     returnNF_Tc (CoreMonoBind new_var core_expr, unitBag new_var)
 326
 327 zonkMonoBinds (FunMonoBind var inf ms locn)
 328   = zonkIdBndr var                      `thenNF_Tc` \ new_var ->
 329     mapNF_Tc zonkMatch ms               `thenNF_Tc` \ new_ms ->
 330     returnNF_Tc (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 331
 332
 333 zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
 334   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 335         -- No need to extend tyvar env: the effects are
 336         -- propagated through binding the tyvars themselves
 337
 338     mapNF_Tc zonkIdBndr  dicts          `thenNF_Tc` \ new_dicts ->
 339     tcExtendGlobalValEnv new_dicts                      $
 340
 341     fixNF_Tc (\ ~(_, _, val_bind_ids) ->
 342         tcExtendGlobalValEnv (bagToList val_bind_ids)   $
 343         zonkMonoBinds val_bind                          `thenNF_Tc` \ (new_val_bind, val_bind_ids) ->
 344         mapNF_Tc zonkExport exports                     `thenNF_Tc` \ new_exports ->
 345         returnNF_Tc (new_val_bind, new_exports,  val_bind_ids)
 346     )                                           `thenNF_Tc ` \ (new_val_bind, new_exports, _) ->
 347     let
 348             new_globals = listToBag [global | (_, global, local) <- new_exports]
 349     in
 350     returnNF_Tc (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 351                  new_globals)
 352   where
 353     zonkExport (tyvars, global, local)
 354         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 355                 -- This isn't the binding occurrence of these tyvars
 356                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 357           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 358           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 359           returnNF_Tc (new_tyvars, new_global, new_local)
 360 \end{code}
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 \begin{code}
 369 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 370
 371 zonkMatch (Match pats _ grhss)
 372   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 373     tcExtendGlobalValEnv (bagToList new_ids)    $
 374     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 375     returnNF_Tc (Match new_pats Nothing new_grhss)
 376
 377 -------------------------------------------------------------------------
 378 zonkGRHSs :: TcGRHSs
 379           -> NF_TcM TypecheckedGRHSs
 380
 381 zonkGRHSs (GRHSs grhss binds ty)
 382   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 383     tcSetEnv new_env $
 384     let
 385         zonk_grhs (GRHS guarded locn)
 386           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 387             returnNF_Tc (GRHS new_guarded locn)
 388     in
 389     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 390     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 391     returnNF_Tc (GRHSs new_grhss new_binds new_ty)
 392 \end{code}
 393
 394 %************************************************************************
 395 %*                                                                      *
 396 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 397 %*                                                                      *
 398 %************************************************************************
 399
 400 \begin{code}
 401 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 402
 403 zonkExpr (HsVar id)
 404   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 405     returnNF_Tc (HsVar id')
 406
 407 zonkExpr (HsIPVar id)
 408   = mapIPNameTc zonkIdOcc id    `thenNF_Tc` \ id' ->
 409     returnNF_Tc (HsIPVar id')
 410
 411 zonkExpr (HsLit (HsRat f ty))
 412   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 413     returnNF_Tc (HsLit (HsRat f new_ty))
 414
 415 zonkExpr (HsLit (HsLitLit lit ty))
 416   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 417     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 418
 419 zonkExpr (HsLit lit)
 420   = returnNF_Tc (HsLit lit)
 421
 422 -- HsOverLit doesn't appear in typechecker output
 423
 424 zonkExpr (HsLam match)
 425   = zonkMatch match     `thenNF_Tc` \ new_match ->
 426     returnNF_Tc (HsLam new_match)
 427
 428 zonkExpr (HsApp e1 e2)
 429   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 430     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 431     returnNF_Tc (HsApp new_e1 new_e2)
 432
 433 zonkExpr (OpApp e1 op fixity e2)
 434   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 435     zonkExpr op `thenNF_Tc` \ new_op ->
 436     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 437     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 438
 439 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 440 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 441
 442 zonkExpr (SectionL expr op)
 443   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 444     zonkExpr op         `thenNF_Tc` \ new_op ->
 445     returnNF_Tc (SectionL new_expr new_op)
 446
 447 zonkExpr (SectionR op expr)
 448   = zonkExpr op         `thenNF_Tc` \ new_op ->
 449     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 450     returnNF_Tc (SectionR new_op new_expr)
 451
 452 zonkExpr (HsCase expr ms src_loc)
 453   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 454     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 455     returnNF_Tc (HsCase new_expr new_ms src_loc)
 456
 457 zonkExpr (HsIf e1 e2 e3 src_loc)
 458   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 459     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 460     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 461     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 462
 463 zonkExpr (HsLet binds expr)
 464   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 465     tcSetEnv new_env            $
 466     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 467     returnNF_Tc (HsLet new_binds new_expr)
 468
 469 zonkExpr (HsWith expr binds)
 470   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 471     tcExtendGlobalValEnv (map (ipNameName . fst) new_binds)     $
 472     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 473     returnNF_Tc (HsWith new_expr new_binds)
 474     where
 475         zonkIPBinds = mapNF_Tc zonkIPBind
 476         zonkIPBind (n, e)
 477             = mapIPNameTc zonkIdBndr n  `thenNF_Tc` \ n' ->
 478               zonkExpr e                `thenNF_Tc` \ e' ->
 479               returnNF_Tc (n', e')
 480
 481 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 482
 483 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 484   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 485     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 486     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 487     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 488     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 489     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 490                          new_ty src_loc)
 491
 492 zonkExpr (ExplicitList ty exprs)
 493   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 494     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 495     returnNF_Tc (ExplicitList new_ty new_exprs)
 496
 497 zonkExpr (ExplicitTuple exprs boxed)
 498   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 499     returnNF_Tc (ExplicitTuple new_exprs boxed)
 500
 501 zonkExpr (RecordConOut data_con con_expr rbinds)
 502   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 503     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 504     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 505
 506 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 507
 508 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
 509   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 510     zonkTcTypeToType in_ty      `thenNF_Tc` \ new_in_ty ->
 511     zonkTcTypeToType out_ty     `thenNF_Tc` \ new_out_ty ->
 512     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 513     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 514     returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
 515
 516 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 517 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 518
 519 zonkExpr (ArithSeqOut expr info)
 520   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 521     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 522     returnNF_Tc (ArithSeqOut new_expr new_info)
 523
 524 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 525   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 526     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 527     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 528
 529 zonkExpr (HsSCC lbl expr)
 530   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 531     returnNF_Tc (HsSCC lbl new_expr)
 532
 533 zonkExpr (TyLam tyvars expr)
 534   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 535         -- No need to extend tyvar env; see AbsBinds
 536
 537     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 538     returnNF_Tc (TyLam new_tyvars new_expr)
 539
 540 zonkExpr (TyApp expr tys)
 541   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 542     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 543     returnNF_Tc (TyApp new_expr new_tys)
 544
 545 zonkExpr (DictLam dicts expr)
 546   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 547     tcExtendGlobalValEnv new_dicts      $
 548     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 549     returnNF_Tc (DictLam new_dicts new_expr)
 550
 551 zonkExpr (DictApp expr dicts)
 552   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 553     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 554     returnNF_Tc (DictApp new_expr new_dicts)
 555
 556
 557
 558 -------------------------------------------------------------------------
 559 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 560
 561 zonkArithSeq (From e)
 562   = zonkExpr e          `thenNF_Tc` \ new_e ->
 563     returnNF_Tc (From new_e)
 564
 565 zonkArithSeq (FromThen e1 e2)
 566   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 567     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 568     returnNF_Tc (FromThen new_e1 new_e2)
 569
 570 zonkArithSeq (FromTo e1 e2)
 571   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 572     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 573     returnNF_Tc (FromTo new_e1 new_e2)
 574
 575 zonkArithSeq (FromThenTo e1 e2 e3)
 576   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 577     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 578     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 579     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 580
 581 -------------------------------------------------------------------------
 582 zonkStmts :: [TcStmt]
 583           -> NF_TcM [TypecheckedStmt]
 584
 585 zonkStmts [] = returnNF_Tc []
 586
 587 zonkStmts (ParStmtOut bndrstmtss : stmts)
 588   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 589     let new_binders = concat new_bndrss in
 590     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 591     tcExtendGlobalValEnv new_binders    $
 592     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 593     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 594   where (bndrss, stmtss) = unzip bndrstmtss
 595
 596 zonkStmts (ResultStmt expr locn : stmts)
 597   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 598     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 599     returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 600
 601 zonkStmts (ExprStmt expr ty locn : stmts)
 602   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 603     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 604     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 605     returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
 606
 607 zonkStmts (LetStmt binds : stmts)
 608   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 609     tcSetEnv new_env            $
 610     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 611     returnNF_Tc (LetStmt new_binds : new_stmts)
 612
 613 zonkStmts (BindStmt pat expr locn : stmts)
 614   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 615     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 616     tcExtendGlobalValEnv (bagToList new_ids)    $
 617     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 618     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 619
 620
 621
 622 -------------------------------------------------------------------------
 623 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 624
 625 zonkRbinds rbinds
 626   = mapNF_Tc zonk_rbind rbinds
 627   where
 628     zonk_rbind (field, expr, pun)
 629       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 630         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 631         returnNF_Tc (new_field, new_expr, pun)
 632
 633 -------------------------------------------------------------------------
 634 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
 635 mapIPNameTc f (Dupable   n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
 636 mapIPNameTc f (MustSplit n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (MustSplit r)
 637 \end{code}
 638
 639
 640 %************************************************************************
 641 %*                                                                      *
 642 \subsection[BackSubst-Pats]{Patterns}
 643 %*                                                                      *
 644 %************************************************************************
 645
 646 \begin{code}
 647 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 648
 649 zonkPat (WildPat ty)
 650   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 651     returnNF_Tc (WildPat new_ty, emptyBag)
 652
 653 zonkPat (VarPat v)
 654   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 655     returnNF_Tc (VarPat new_v, unitBag new_v)
 656
 657 zonkPat (LazyPat pat)
 658   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 659     returnNF_Tc (LazyPat new_pat, ids)
 660
 661 zonkPat (AsPat n pat)
 662   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 663     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 664     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 665
 666 zonkPat (ListPat ty pats)
 667   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 668     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 669     returnNF_Tc (ListPat new_ty new_pats, ids)
 670
 671 zonkPat (TuplePat pats boxed)
 672   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 673     returnNF_Tc (TuplePat new_pats boxed, ids)
 674
 675 zonkPat (ConPat n ty tvs dicts pats)
 676   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 677     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 678     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 679     tcExtendGlobalValEnv new_dicts      $
 680     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 681     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 682                  listToBag new_dicts `unionBags` ids)
 683
 684 zonkPat (RecPat n ty tvs dicts rpats)
 685   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 686     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 687     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 688     tcExtendGlobalValEnv new_dicts      $
 689     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 690     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 691                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 692   where
 693     zonk_rpat (f, pat, pun)
 694       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 695         returnNF_Tc ((f, new_pat, pun), ids)
 696
 697 zonkPat (LitPat lit ty)
 698   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 699     returnNF_Tc (LitPat lit new_ty, emptyBag)
 700
 701 zonkPat (SigPat pat ty expr)
 702   = zonkPat pat                 `thenNF_Tc` \ (new_pat, ids) ->
 703     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty  ->
 704     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 705     returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
 706
 707 zonkPat (NPat lit ty expr)
 708   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 709     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 710     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 711
 712 zonkPat (NPlusKPat n k ty e1 e2)
 713   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 714     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 715     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 716     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 717     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 718
 719 zonkPat (DictPat ds ms)
 720   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 721     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 722     returnNF_Tc (DictPat new_ds new_ms,
 723                  listToBag new_ds `unionBags` listToBag new_ms)
 724
 725
 726 zonkPats []
 727   = returnNF_Tc ([], emptyBag)
 728
 729 zonkPats (pat:pats)
 730   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 731     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 732     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 733 \end{code}
 734
 735 %************************************************************************
 736 %*                                                                      *
 737 \subsection[BackSubst-Foreign]{Foreign exports}
 738 %*                                                                      *
 739 %************************************************************************
 740
 741
 742 \begin{code}
 743 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 744 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 745
 746 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 747 zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
 748    zonkIdOcc i  `thenNF_Tc` \ i' ->
 749    returnNF_Tc (ForeignExport i' undefined spec src_loc)
 750 \end{code}
 751
 752 \begin{code}
 753 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 754 zonkRules rs = mapNF_Tc zonkRule rs
 755
 756 zonkRule (HsRule name act vars lhs rhs loc)
 757   = mapNF_Tc zonk_bndr vars                             `thenNF_Tc` \ new_bndrs ->
 758     tcExtendGlobalValEnv (filter isId new_bndrs)        $
 759         -- Type variables don't need an envt
 760         -- They are bound through the mutable mechanism
 761     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 762     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 763     returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 764         -- I hate this map RuleBndr stuff
 765   where
 766    zonk_bndr (RuleBndr v)
 767         | isId v    = zonkIdBndr v
 768         | otherwise = zonkTcTyVarToTyVar v
 769
 770 zonkRule (IfaceRuleOut fun rule)
 771   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 772     returnNF_Tc (IfaceRuleOut fun' rule)
 773 \end{code}