ghc/compiler/typecheck/TcHsSyn.lhs

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