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