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