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