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 do_or_lc stmts ids ty src_loc)
 486   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 487     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 488     mapNF_Tc zonkIdOcc ids      `thenNF_Tc` \ new_ids ->
 489     returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
 490
 491 zonkExpr (ExplicitList ty exprs)
 492   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 493     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 494     returnNF_Tc (ExplicitList new_ty new_exprs)
 495
 496 zonkExpr (ExplicitPArr ty exprs)
 497   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 498     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 499     returnNF_Tc (ExplicitPArr new_ty new_exprs)
 500
 501 zonkExpr (ExplicitTuple exprs boxed)
 502   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 503     returnNF_Tc (ExplicitTuple new_exprs boxed)
 504
 505 zonkExpr (RecordConOut data_con con_expr rbinds)
 506   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 507     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 508     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 509
 510 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 511
 512 zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
 513   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 514     zonkTcTypeToType in_ty      `thenNF_Tc` \ new_in_ty ->
 515     zonkTcTypeToType out_ty     `thenNF_Tc` \ new_out_ty ->
 516     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 517     returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 518
 519 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 520 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 521 zonkExpr (PArrSeqIn _)       = panic "zonkExpr:PArrSeqIn"
 522
 523 zonkExpr (ArithSeqOut expr info)
 524   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 525     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 526     returnNF_Tc (ArithSeqOut new_expr new_info)
 527
 528 zonkExpr (PArrSeqOut expr info)
 529   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 530     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 531     returnNF_Tc (PArrSeqOut new_expr new_info)
 532
 533 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 534   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 535     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 536     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 537
 538 zonkExpr (HsSCC lbl expr)
 539   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 540     returnNF_Tc (HsSCC lbl new_expr)
 541
 542 zonkExpr (TyLam tyvars expr)
 543   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 544         -- No need to extend tyvar env; see AbsBinds
 545
 546     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 547     returnNF_Tc (TyLam new_tyvars new_expr)
 548
 549 zonkExpr (TyApp expr tys)
 550   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 551     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 552     returnNF_Tc (TyApp new_expr new_tys)
 553
 554 zonkExpr (DictLam dicts expr)
 555   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 556     tcExtendGlobalValEnv new_dicts      $
 557     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 558     returnNF_Tc (DictLam new_dicts new_expr)
 559
 560 zonkExpr (DictApp expr dicts)
 561   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 562     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 563     returnNF_Tc (DictApp new_expr new_dicts)
 564
 565
 566
 567 -------------------------------------------------------------------------
 568 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 569
 570 zonkArithSeq (From e)
 571   = zonkExpr e          `thenNF_Tc` \ new_e ->
 572     returnNF_Tc (From new_e)
 573
 574 zonkArithSeq (FromThen e1 e2)
 575   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 576     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 577     returnNF_Tc (FromThen new_e1 new_e2)
 578
 579 zonkArithSeq (FromTo e1 e2)
 580   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 581     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 582     returnNF_Tc (FromTo new_e1 new_e2)
 583
 584 zonkArithSeq (FromThenTo e1 e2 e3)
 585   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 586     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 587     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 588     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 589
 590 -------------------------------------------------------------------------
 591 zonkStmts :: [TcStmt]
 592           -> NF_TcM [TypecheckedStmt]
 593
 594 zonkStmts [] = returnNF_Tc []
 595
 596 zonkStmts (ParStmtOut bndrstmtss : stmts)
 597   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 598     let new_binders = concat new_bndrss in
 599     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 600     tcExtendGlobalValEnv new_binders    $
 601     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 602     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 603   where (bndrss, stmtss) = unzip bndrstmtss
 604
 605 zonkStmts (ResultStmt expr locn : stmts)
 606   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 607     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 608     returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 609
 610 zonkStmts (ExprStmt expr ty locn : stmts)
 611   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 612     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 613     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 614     returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
 615
 616 zonkStmts (LetStmt binds : stmts)
 617   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 618     tcSetEnv new_env            $
 619     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 620     returnNF_Tc (LetStmt new_binds : new_stmts)
 621
 622 zonkStmts (BindStmt pat expr locn : stmts)
 623   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 624     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 625     tcExtendGlobalValEnv (bagToList new_ids)    $
 626     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 627     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 628
 629
 630
 631 -------------------------------------------------------------------------
 632 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 633
 634 zonkRbinds rbinds
 635   = mapNF_Tc zonk_rbind rbinds
 636   where
 637     zonk_rbind (field, expr, pun)
 638       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 639         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 640         returnNF_Tc (new_field, new_expr, pun)
 641
 642 -------------------------------------------------------------------------
 643 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
 644 mapIPNameTc f (Dupable n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
 645 mapIPNameTc f (Linear  n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
 646 \end{code}
 647
 648
 649 %************************************************************************
 650 %*                                                                      *
 651 \subsection[BackSubst-Pats]{Patterns}
 652 %*                                                                      *
 653 %************************************************************************
 654
 655 \begin{code}
 656 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 657
 658 zonkPat (WildPat ty)
 659   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 660     returnNF_Tc (WildPat new_ty, emptyBag)
 661
 662 zonkPat (VarPat v)
 663   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 664     returnNF_Tc (VarPat new_v, unitBag new_v)
 665
 666 zonkPat (LazyPat pat)
 667   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 668     returnNF_Tc (LazyPat new_pat, ids)
 669
 670 zonkPat (AsPat n pat)
 671   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 672     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 673     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 674
 675 zonkPat (ListPat ty pats)
 676   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 677     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 678     returnNF_Tc (ListPat new_ty new_pats, ids)
 679
 680 zonkPat (PArrPat ty pats)
 681   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 682     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 683     returnNF_Tc (PArrPat new_ty new_pats, ids)
 684
 685 zonkPat (TuplePat pats boxed)
 686   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 687     returnNF_Tc (TuplePat new_pats boxed, ids)
 688
 689 zonkPat (ConPat n ty tvs dicts pats)
 690   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 691     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 692     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 693     tcExtendGlobalValEnv new_dicts      $
 694     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 695     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 696                  listToBag new_dicts `unionBags` ids)
 697
 698 zonkPat (RecPat n ty tvs dicts rpats)
 699   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 700     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 701     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 702     tcExtendGlobalValEnv new_dicts      $
 703     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 704     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 705                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 706   where
 707     zonk_rpat (f, pat, pun)
 708       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 709         returnNF_Tc ((f, new_pat, pun), ids)
 710
 711 zonkPat (LitPat lit ty)
 712   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty  ->
 713     returnNF_Tc (LitPat lit new_ty, emptyBag)
 714
 715 zonkPat (SigPat pat ty expr)
 716   = zonkPat pat                 `thenNF_Tc` \ (new_pat, ids) ->
 717     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty  ->
 718     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 719     returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
 720
 721 zonkPat (NPat lit ty expr)
 722   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 723     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 724     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 725
 726 zonkPat (NPlusKPat n k ty e1 e2)
 727   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 728     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 729     zonkExpr e1                 `thenNF_Tc` \ new_e1 ->
 730     zonkExpr e2                 `thenNF_Tc` \ new_e2 ->
 731     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 732
 733 zonkPat (DictPat ds ms)
 734   = mapNF_Tc zonkIdBndr ds      `thenNF_Tc` \ new_ds ->
 735     mapNF_Tc zonkIdBndr ms      `thenNF_Tc` \ new_ms ->
 736     returnNF_Tc (DictPat new_ds new_ms,
 737                  listToBag new_ds `unionBags` listToBag new_ms)
 738
 739
 740 zonkPats []
 741   = returnNF_Tc ([], emptyBag)
 742
 743 zonkPats (pat:pats)
 744   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 745     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 746     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 747 \end{code}
 748
 749 %************************************************************************
 750 %*                                                                      *
 751 \subsection[BackSubst-Foreign]{Foreign exports}
 752 %*                                                                      *
 753 %************************************************************************
 754
 755
 756 \begin{code}
 757 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 758 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 759
 760 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 761 zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
 762    zonkIdOcc i  `thenNF_Tc` \ i' ->
 763    returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
 764 \end{code}
 765
 766 \begin{code}
 767 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 768 zonkRules rs = mapNF_Tc zonkRule rs
 769
 770 zonkRule (HsRule name act vars lhs rhs loc)
 771   = mapNF_Tc zonk_bndr vars                             `thenNF_Tc` \ new_bndrs ->
 772     tcExtendGlobalValEnv (filter isId new_bndrs)        $
 773         -- Type variables don't need an envt
 774         -- They are bound through the mutable mechanism
 775     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 776     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 777     returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 778         -- I hate this map RuleBndr stuff
 779   where
 780    zonk_bndr (RuleBndr v)
 781         | isId v    = zonkIdBndr v
 782         | otherwise = zonkTcTyVarToTyVar v
 783
 784 zonkRule (IfaceRuleOut fun rule)
 785   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 786     returnNF_Tc (IfaceRuleOut fun' rule)
 787 \end{code}
 788