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         TcForeignDecl,
  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         hsLitType, hsPatType,
  29
  30         -- re-exported from TcMonad
  31         TcId, TcIdSet,
  32
  33         zonkTopBinds, zonkTopDecls, zonkTopExpr,
  34         zonkId, zonkIdBndr
  35   ) where
  36
  37 #include "HsVersions.h"
  38
  39 -- friends:
  40 import HsSyn    -- oodles of it
  41
  42 -- others:
  43 import Id       ( idType, setIdType, Id )
  44 import DataCon  ( dataConWrapId )
  45
  46 import TcRnMonad
  47 import Type       ( Type )
  48 import TcType     ( TcType, tcGetTyVar )
  49 import TcMType    ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
  50 import TysPrim    ( charPrimTy, intPrimTy, floatPrimTy,
  51                     doublePrimTy, addrPrimTy
  52                   )
  53 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
  54                     mkListTy, mkPArrTy, mkTupleTy, unitTy )
  55 import CoreSyn    ( CoreExpr )
  56 import Var        ( isId, isLocalVar )
  57 import VarEnv
  58 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
  59 import Maybes     ( orElse )
  60 import Bag
  61 import Outputable
  62 \end{code}
  63
  64
  65 Type definitions
  66 ~~~~~~~~~~~~~~~~
  67
  68 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  69 All the types in @Tc...@ things have mutable type-variables in them for
  70 unification.
  71
  72 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  73 which have immutable type variables in them.
  74
  75 \begin{code}
  76 type TcHsBinds          = HsBinds       TcId
  77 type TcMonoBinds        = MonoBinds     TcId
  78 type TcDictBinds        = TcMonoBinds
  79 type TcPat              = OutPat        TcId
  80 type TcExpr             = HsExpr        TcId
  81 type TcGRHSs            = GRHSs         TcId
  82 type TcGRHS             = GRHS          TcId
  83 type TcMatch            = Match         TcId
  84 type TcStmt             = Stmt          TcId
  85 type TcArithSeqInfo     = ArithSeqInfo  TcId
  86 type TcRecordBinds      = HsRecordBinds TcId
  87 type TcHsModule         = HsModule      TcId
  88 type TcForeignDecl      = ForeignDecl  TcId
  89 type TcRuleDecl         = RuleDecl     TcId
  90
  91 type TypecheckedPat             = OutPat        Id
  92 type TypecheckedMonoBinds       = MonoBinds     Id
  93 type TypecheckedDictBinds       = TypecheckedMonoBinds
  94 type TypecheckedHsBinds         = HsBinds       Id
  95 type TypecheckedHsExpr          = HsExpr        Id
  96 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id
  97 type TypecheckedStmt            = Stmt          Id
  98 type TypecheckedMatch           = Match         Id
  99 type TypecheckedMatchContext    = HsMatchContext Id
 100 type TypecheckedGRHSs           = GRHSs         Id
 101 type TypecheckedGRHS            = GRHS          Id
 102 type TypecheckedRecordBinds     = HsRecordBinds Id
 103 type TypecheckedHsModule        = HsModule      Id
 104 type TypecheckedForeignDecl     = ForeignDecl   Id
 105 type TypecheckedRuleDecl        = RuleDecl      Id
 106 type TypecheckedCoreBind        = (Id, CoreExpr)
 107 \end{code}
 108
 109 \begin{code}
 110 mkHsTyApp expr []  = expr
 111 mkHsTyApp expr tys = TyApp expr tys
 112
 113 mkHsDictApp expr []      = expr
 114 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 115
 116 mkHsTyLam []     expr = expr
 117 mkHsTyLam tyvars expr = TyLam tyvars expr
 118
 119 mkHsDictLam []    expr = expr
 120 mkHsDictLam dicts expr = DictLam dicts expr
 121
 122 mkHsLet EmptyMonoBinds expr = expr
 123 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 124
 125 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 126 \end{code}
 127
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
 136 then something is wrong.
 137 \begin{code}
 138 hsPatType :: TypecheckedPat -> Type
 139
 140 hsPatType (ParPat pat)            = hsPatType pat
 141 hsPatType (WildPat ty)            = ty
 142 hsPatType (VarPat var)            = idType var
 143 hsPatType (LazyPat pat)           = hsPatType pat
 144 hsPatType (LitPat lit)            = hsLitType lit
 145 hsPatType (AsPat var pat)         = idType var
 146 hsPatType (ListPat _ ty)          = mkListTy ty
 147 hsPatType (PArrPat _ ty)          = mkPArrTy ty
 148 hsPatType (TuplePat pats box)     = mkTupleTy box (length pats) (map hsPatType pats)
 149 hsPatType (ConPatOut _ _ ty _ _)  = ty
 150 hsPatType (SigPatOut _ ty _)      = ty
 151 hsPatType (NPatOut lit ty _)      = ty
 152 hsPatType (NPlusKPatOut id _ _ _) = idType id
 153 hsPatType (DictPat ds ms)         = case (ds ++ ms) of
 154                                        []  -> unitTy
 155                                        [d] -> idType d
 156                                        ds  -> mkTupleTy Boxed (length ds) (map idType ds)
 157
 158
 159 hsLitType :: HsLit -> TcType
 160 hsLitType (HsChar c)       = charTy
 161 hsLitType (HsCharPrim c)   = charPrimTy
 162 hsLitType (HsString str)   = stringTy
 163 hsLitType (HsStringPrim s) = addrPrimTy
 164 hsLitType (HsInt i)        = intTy
 165 hsLitType (HsIntPrim i)    = intPrimTy
 166 hsLitType (HsInteger i)    = integerTy
 167 hsLitType (HsRat _ ty)     = ty
 168 hsLitType (HsFloatPrim f)  = floatPrimTy
 169 hsLitType (HsDoublePrim d) = doublePrimTy
 170 hsLitType (HsLitLit _ ty)  = ty
 171 \end{code}
 172
 173 \begin{code}
 174 -- zonkId is used *during* typechecking just to zonk the Id's type
 175 zonkId :: TcId -> TcM TcId
 176 zonkId id
 177   = zonkTcType (idType id) `thenM` \ ty' ->
 178     returnM (setIdType id ty')
 179 \end{code}
 180
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 This zonking pass runs over the bindings
 189
 190  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 191  b) convert unbound TcTyVar to Void
 192  c) convert each TcId to an Id by zonking its type
 193
 194 The type variables are converted by binding mutable tyvars to immutable ones
 195 and then zonking as normal.
 196
 197 The Ids are converted by binding them in the normal Tc envt; that
 198 way we maintain sharing; eg an Id is zonked at its binding site and they
 199 all occurrences of that Id point to the common zonked copy
 200
 201 It's all pretty boring stuff, because HsSyn is such a large type, and
 202 the environment manipulation is tiresome.
 203
 204 \begin{code}
 205 type ZonkEnv = IdEnv Id
 206         -- Maps an Id to its zonked version; both have the same Name
 207         -- Is only consulted lazily; hence knot-tying
 208
 209 emptyZonkEnv = emptyVarEnv
 210
 211 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
 212 extendZonkEnv env ids = extendVarEnvList env [(id,id) | id <- ids]
 213
 214 mkZonkEnv :: [Id] -> ZonkEnv
 215 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
 216
 217 zonkIdOcc :: ZonkEnv -> TcId -> Id
 218 -- Ids defined in this module should be in the envt;
 219 -- ignore others.  (Actually, data constructors are also
 220 -- not LocalVars, even when locally defined, but that is fine.)
 221 --
 222 -- Actually, Template Haskell works in 'chunks' of declarations, and
 223 -- an earlier chunk won't be in the 'env' that the zonking phase
 224 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
 225 -- zonked.  There's no point in looking it up there (except for error
 226 -- checking), and it's not conveniently to hand; hence the simple
 227 -- 'orElse' case in the LocalVar branch.
 228 --
 229 -- Even without template splices, in module Main, the checking of
 230 -- 'main' is done as a separte chunk.
 231 zonkIdOcc env id
 232   | isLocalVar id = lookupVarEnv env id `orElse` id
 233   | otherwise     = id
 234
 235 zonkIdOccs env ids = map (zonkIdOcc env) ids
 236
 237 -- zonkIdBndr is used *after* typechecking to get the Id's type
 238 -- to its final form.  The TyVarEnv give
 239 zonkIdBndr :: TcId -> TcM Id
 240 zonkIdBndr id
 241   = zonkTcTypeToType (idType id)        `thenM` \ ty' ->
 242     returnM (setIdType id ty')
 243 \end{code}
 244
 245
 246 \begin{code}
 247 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
 248 zonkTopExpr e = zonkExpr emptyZonkEnv e
 249
 250 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
 251              -> TcM ([Id],
 252                         TypecheckedMonoBinds,
 253                         [TypecheckedForeignDecl],
 254                         [TypecheckedRuleDecl])
 255 zonkTopDecls binds rules fords  -- Top level is implicitly recursive
 256   = fixM (\ ~(new_ids, _, _, _) ->
 257         let
 258            zonk_env = mkZonkEnv new_ids
 259         in
 260         zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
 261         zonkRules zonk_env rules                `thenM` \ rules' ->
 262         zonkForeignExports zonk_env fords       `thenM` \ fords' ->
 263
 264         returnM (bagToList new_ids, binds', fords', rules')
 265     )
 266
 267 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
 268 zonkTopBinds binds
 269   = fixM (\ ~(new_ids, _) ->
 270         let
 271            zonk_env = mkZonkEnv new_ids
 272         in
 273         zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
 274         returnM (bagToList new_ids, binds')
 275     )
 276
 277 ---------------------------------------------
 278 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
 279 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
 280
 281 zonkBinds env (ThenBinds b1 b2)
 282   = zonkBinds env b1    `thenM` \ (env1, b1') ->
 283     zonkBinds env1 b2   `thenM` \ (env2, b2') ->
 284     returnM (env2, b1' `ThenBinds` b2')
 285
 286 zonkBinds env (MonoBind bind sigs is_rec)
 287   = ASSERT( null sigs )
 288     fixM (\ ~(env1, _) ->
 289         zonkMonoBinds env1 bind         `thenM` \ (new_bind, new_ids) ->
 290         let
 291            env2 = extendZonkEnv env (bagToList new_ids)
 292         in
 293         returnM (env2, mkMonoBind new_bind [] is_rec)
 294     )
 295
 296 ---------------------------------------------
 297 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
 298               -> TcM (TypecheckedMonoBinds, Bag Id)
 299
 300 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
 301
 302 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
 303   = zonkMonoBinds env mbinds1           `thenM` \ (b1', ids1) ->
 304     zonkMonoBinds env mbinds2           `thenM` \ (b2', ids2) ->
 305     returnM (b1' `AndMonoBinds` b2',
 306                  ids1 `unionBags` ids2)
 307
 308 zonkMonoBinds env (PatMonoBind pat grhss locn)
 309   = zonkPat env pat     `thenM` \ (new_pat, ids) ->
 310     zonkGRHSs env grhss `thenM` \ new_grhss ->
 311     returnM (PatMonoBind new_pat new_grhss locn, ids)
 312
 313 zonkMonoBinds env (VarMonoBind var expr)
 314   = zonkIdBndr var      `thenM` \ new_var ->
 315     zonkExpr env expr   `thenM` \ new_expr ->
 316     returnM (VarMonoBind new_var new_expr, unitBag new_var)
 317
 318 zonkMonoBinds env (CoreMonoBind var core_expr)
 319   = zonkIdBndr var      `thenM` \ new_var ->
 320     returnM (CoreMonoBind new_var core_expr, unitBag new_var)
 321
 322 zonkMonoBinds env (FunMonoBind var inf ms locn)
 323   = zonkIdBndr var                      `thenM` \ new_var ->
 324     mappM (zonkMatch env) ms            `thenM` \ new_ms ->
 325     returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 326
 327
 328 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
 329   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 330         -- No need to extend tyvar env: the effects are
 331         -- propagated through binding the tyvars themselves
 332
 333     mappM zonkIdBndr  dicts             `thenM` \ new_dicts ->
 334     fixM (\ ~(_, _, val_bind_ids) ->
 335         let
 336           env1 = extendZonkEnv (extendZonkEnv env new_dicts)
 337                                (bagToList val_bind_ids)
 338         in
 339         zonkMonoBinds env1 val_bind             `thenM` \ (new_val_bind, val_bind_ids) ->
 340         mappM (zonkExport env1) exports `thenM` \ new_exports ->
 341         returnM (new_val_bind, new_exports, val_bind_ids)
 342     )                                           `thenM ` \ (new_val_bind, new_exports, _) ->
 343     let
 344         new_globals = listToBag [global | (_, global, local) <- new_exports]
 345     in
 346     returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 347                  new_globals)
 348   where
 349     zonkExport env (tyvars, global, local)
 350         = zonkTcTyVars tyvars           `thenM` \ tys ->
 351           let
 352                 new_tyvars = map (tcGetTyVar "zonkExport") tys
 353                 -- This isn't the binding occurrence of these tyvars
 354                 -- but they should *be* tyvars.  Hence tcGetTyVar.
 355           in
 356           zonkIdBndr global             `thenM` \ new_global ->
 357           returnM (new_tyvars, new_global, zonkIdOcc env local)
 358 \end{code}
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 \begin{code}
 367 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
 368
 369 zonkMatch env (Match pats _ grhss)
 370   = zonkPats env pats                                           `thenM` \ (new_pats, new_ids) ->
 371     zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss     `thenM` \ new_grhss ->
 372     returnM (Match new_pats Nothing new_grhss)
 373
 374 -------------------------------------------------------------------------
 375 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
 376
 377 zonkGRHSs env (GRHSs grhss binds ty)
 378   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 379     let
 380         zonk_grhs (GRHS guarded locn)
 381           = zonkStmts new_env guarded  `thenM` \ new_guarded ->
 382             returnM (GRHS new_guarded locn)
 383     in
 384     mappM zonk_grhs grhss       `thenM` \ new_grhss ->
 385     zonkTcTypeToType ty         `thenM` \ new_ty ->
 386     returnM (GRHSs new_grhss new_binds new_ty)
 387 \end{code}
 388
 389 %************************************************************************
 390 %*                                                                      *
 391 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 \begin{code}
 396 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
 397
 398 zonkExpr env (HsVar id)
 399   = returnM (HsVar (zonkIdOcc env id))
 400
 401 zonkExpr env (HsIPVar id)
 402   = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
 403
 404 zonkExpr env (HsLit (HsRat f ty))
 405   = zonkTcTypeToType ty     `thenM` \ new_ty  ->
 406     returnM (HsLit (HsRat f new_ty))
 407
 408 zonkExpr env (HsLit (HsLitLit lit ty))
 409   = zonkTcTypeToType ty     `thenM` \ new_ty  ->
 410     returnM (HsLit (HsLitLit lit new_ty))
 411
 412 zonkExpr env (HsLit lit)
 413   = returnM (HsLit lit)
 414
 415 -- HsOverLit doesn't appear in typechecker output
 416
 417 zonkExpr env (HsLam match)
 418   = zonkMatch env match `thenM` \ new_match ->
 419     returnM (HsLam new_match)
 420
 421 zonkExpr env (HsApp e1 e2)
 422   = zonkExpr env e1     `thenM` \ new_e1 ->
 423     zonkExpr env e2     `thenM` \ new_e2 ->
 424     returnM (HsApp new_e1 new_e2)
 425
 426 zonkExpr env (HsBracketOut body bs)
 427   = mappM zonk_b bs     `thenM` \ bs' ->
 428     returnM (HsBracketOut body bs')
 429   where
 430     zonk_b (n,e) = zonkExpr env e       `thenM` \ e' ->
 431                    returnM (n,e')
 432
 433 zonkExpr env (HsSplice n e) = WARN( True, ppr e )       -- Should not happen
 434                               returnM (HsSplice n e)
 435
 436 zonkExpr env (OpApp e1 op fixity e2)
 437   = zonkExpr env e1     `thenM` \ new_e1 ->
 438     zonkExpr env op     `thenM` \ new_op ->
 439     zonkExpr env e2     `thenM` \ new_e2 ->
 440     returnM (OpApp new_e1 new_op fixity new_e2)
 441
 442 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
 443
 444 zonkExpr env (HsPar e)
 445   = zonkExpr env e      `thenM` \new_e ->
 446     returnM (HsPar new_e)
 447
 448 zonkExpr env (SectionL expr op)
 449   = zonkExpr env expr   `thenM` \ new_expr ->
 450     zonkExpr env op             `thenM` \ new_op ->
 451     returnM (SectionL new_expr new_op)
 452
 453 zonkExpr env (SectionR op expr)
 454   = zonkExpr env op             `thenM` \ new_op ->
 455     zonkExpr env expr           `thenM` \ new_expr ->
 456     returnM (SectionR new_op new_expr)
 457
 458 zonkExpr env (HsCase expr ms src_loc)
 459   = zonkExpr env expr           `thenM` \ new_expr ->
 460     mappM (zonkMatch env) ms    `thenM` \ new_ms ->
 461     returnM (HsCase new_expr new_ms src_loc)
 462
 463 zonkExpr env (HsIf e1 e2 e3 src_loc)
 464   = zonkExpr env e1     `thenM` \ new_e1 ->
 465     zonkExpr env e2     `thenM` \ new_e2 ->
 466     zonkExpr env e3     `thenM` \ new_e3 ->
 467     returnM (HsIf new_e1 new_e2 new_e3 src_loc)
 468
 469 zonkExpr env (HsLet binds expr)
 470   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 471     zonkExpr new_env expr       `thenM` \ new_expr ->
 472     returnM (HsLet new_binds new_expr)
 473
 474 zonkExpr env (HsWith expr binds is_with)
 475   = mappM zonk_ip_bind binds    `thenM` \ new_binds ->
 476     let
 477         env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
 478     in
 479     zonkExpr env1 expr          `thenM` \ new_expr ->
 480     returnM (HsWith new_expr new_binds is_with)
 481     where
 482         zonk_ip_bind (n, e)
 483             = mapIPNameTc zonkIdBndr n  `thenM` \ n' ->
 484               zonkExpr env e            `thenM` \ e' ->
 485               returnM (n', e')
 486
 487 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
 488   = zonkStmts env stmts         `thenM` \ new_stmts ->
 489     zonkTcTypeToType ty         `thenM` \ new_ty   ->
 490     returnM (HsDo do_or_lc new_stmts
 491                       (zonkIdOccs env ids)
 492                       new_ty src_loc)
 493
 494 zonkExpr env (ExplicitList ty exprs)
 495   = zonkTcTypeToType ty                 `thenM` \ new_ty ->
 496     mappM (zonkExpr env) exprs  `thenM` \ new_exprs ->
 497     returnM (ExplicitList new_ty new_exprs)
 498
 499 zonkExpr env (ExplicitPArr ty exprs)
 500   = zonkTcTypeToType ty                 `thenM` \ new_ty ->
 501     mappM (zonkExpr env) exprs  `thenM` \ new_exprs ->
 502     returnM (ExplicitPArr new_ty new_exprs)
 503
 504 zonkExpr env (ExplicitTuple exprs boxed)
 505   = mappM (zonkExpr env) exprs          `thenM` \ new_exprs ->
 506     returnM (ExplicitTuple new_exprs boxed)
 507
 508 zonkExpr env (RecordConOut data_con con_expr rbinds)
 509   = zonkExpr env con_expr       `thenM` \ new_con_expr ->
 510     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 511     returnM (RecordConOut data_con new_con_expr new_rbinds)
 512
 513 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
 514
 515 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
 516   = zonkExpr env expr           `thenM` \ new_expr ->
 517     zonkTcTypeToType in_ty      `thenM` \ new_in_ty ->
 518     zonkTcTypeToType out_ty     `thenM` \ new_out_ty ->
 519     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 520     returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 521
 522 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 523 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 524 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
 525
 526 zonkExpr env (ArithSeqOut expr info)
 527   = zonkExpr env expr           `thenM` \ new_expr ->
 528     zonkArithSeq env info       `thenM` \ new_info ->
 529     returnM (ArithSeqOut new_expr new_info)
 530
 531 zonkExpr env (PArrSeqOut expr info)
 532   = zonkExpr env expr           `thenM` \ new_expr ->
 533     zonkArithSeq env info       `thenM` \ new_info ->
 534     returnM (PArrSeqOut new_expr new_info)
 535
 536 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
 537   = mappM (zonkExpr env) args   `thenM` \ new_args ->
 538     zonkTcTypeToType result_ty          `thenM` \ new_result_ty ->
 539     returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
 540
 541 zonkExpr env (HsSCC lbl expr)
 542   = zonkExpr env expr   `thenM` \ new_expr ->
 543     returnM (HsSCC lbl new_expr)
 544
 545 zonkExpr env (TyLam tyvars expr)
 546   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 547         -- No need to extend tyvar env; see AbsBinds
 548
 549     zonkExpr env expr                   `thenM` \ new_expr ->
 550     returnM (TyLam new_tyvars new_expr)
 551
 552 zonkExpr env (TyApp expr tys)
 553   = zonkExpr env expr                           `thenM` \ new_expr ->
 554     mappM zonkTcTypeToType tys  `thenM` \ new_tys ->
 555     returnM (TyApp new_expr new_tys)
 556
 557 zonkExpr env (DictLam dicts expr)
 558   = mappM zonkIdBndr dicts              `thenM` \ new_dicts ->
 559     let
 560         env1 = extendZonkEnv env new_dicts
 561     in
 562     zonkExpr env1 expr                          `thenM` \ new_expr ->
 563     returnM (DictLam new_dicts new_expr)
 564
 565 zonkExpr env (DictApp expr dicts)
 566   = zonkExpr env expr                   `thenM` \ new_expr ->
 567     returnM (DictApp new_expr (zonkIdOccs env dicts))
 568
 569
 570
 571 -------------------------------------------------------------------------
 572 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
 573
 574 zonkArithSeq env (From e)
 575   = zonkExpr env e              `thenM` \ new_e ->
 576     returnM (From new_e)
 577
 578 zonkArithSeq env (FromThen e1 e2)
 579   = zonkExpr env e1     `thenM` \ new_e1 ->
 580     zonkExpr env e2     `thenM` \ new_e2 ->
 581     returnM (FromThen new_e1 new_e2)
 582
 583 zonkArithSeq env (FromTo e1 e2)
 584   = zonkExpr env e1     `thenM` \ new_e1 ->
 585     zonkExpr env e2     `thenM` \ new_e2 ->
 586     returnM (FromTo new_e1 new_e2)
 587
 588 zonkArithSeq env (FromThenTo e1 e2 e3)
 589   = zonkExpr env e1     `thenM` \ new_e1 ->
 590     zonkExpr env e2     `thenM` \ new_e2 ->
 591     zonkExpr env e3     `thenM` \ new_e3 ->
 592     returnM (FromThenTo new_e1 new_e2 new_e3)
 593
 594 -------------------------------------------------------------------------
 595 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
 596
 597 zonkStmts env [] = returnM []
 598
 599 zonkStmts env (ParStmtOut bndrstmtss : stmts)
 600   = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
 601     mappM (zonkStmts env) stmtss        `thenM` \ new_stmtss ->
 602     let
 603         new_binders = concat new_bndrss
 604         env1 = extendZonkEnv env new_binders
 605     in
 606     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 607     returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 608   where
 609     (bndrss, stmtss) = unzip bndrstmtss
 610
 611 zonkStmts env (ResultStmt expr locn : stmts)
 612   = zonkExpr env expr   `thenM` \ new_expr ->
 613     zonkStmts env stmts `thenM` \ new_stmts ->
 614     returnM (ResultStmt new_expr locn : new_stmts)
 615
 616 zonkStmts env (ExprStmt expr ty locn : stmts)
 617   = zonkExpr env expr   `thenM` \ new_expr ->
 618     zonkTcTypeToType ty `thenM` \ new_ty ->
 619     zonkStmts env stmts `thenM` \ new_stmts ->
 620     returnM (ExprStmt new_expr new_ty locn : new_stmts)
 621
 622 zonkStmts env (LetStmt binds : stmts)
 623   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 624     zonkStmts new_env stmts     `thenM` \ new_stmts ->
 625     returnM (LetStmt new_binds : new_stmts)
 626
 627 zonkStmts env (BindStmt pat expr locn : stmts)
 628   = zonkExpr env expr                   `thenM` \ new_expr ->
 629     zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 630     let
 631         env1 = extendZonkEnv env (bagToList new_ids)
 632     in
 633     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 634     returnM (BindStmt new_pat new_expr locn : new_stmts)
 635
 636
 637
 638 -------------------------------------------------------------------------
 639 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
 640
 641 zonkRbinds env rbinds
 642   = mappM zonk_rbind rbinds
 643   where
 644     zonk_rbind (field, expr)
 645       = zonkExpr env expr       `thenM` \ new_expr ->
 646         returnM (zonkIdOcc env field, new_expr)
 647
 648 -------------------------------------------------------------------------
 649 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 650 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 651 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 652 \end{code}
 653
 654
 655 %************************************************************************
 656 %*                                                                      *
 657 \subsection[BackSubst-Pats]{Patterns}
 658 %*                                                                      *
 659 %************************************************************************
 660
 661 \begin{code}
 662 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
 663
 664 zonkPat env (ParPat p)
 665   = zonkPat env p       `thenM` \ (new_p, ids) ->
 666     returnM (ParPat new_p, ids)
 667
 668 zonkPat env (WildPat ty)
 669   = zonkTcTypeToType ty     `thenM` \ new_ty ->
 670     returnM (WildPat new_ty, emptyBag)
 671
 672 zonkPat env (VarPat v)
 673   = zonkIdBndr v            `thenM` \ new_v ->
 674     returnM (VarPat new_v, unitBag new_v)
 675
 676 zonkPat env (LazyPat pat)
 677   = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 678     returnM (LazyPat new_pat, ids)
 679
 680 zonkPat env (AsPat n pat)
 681   = zonkIdBndr n            `thenM` \ new_n ->
 682     zonkPat env pat         `thenM` \ (new_pat, ids) ->
 683     returnM (AsPat new_n new_pat, new_n `consBag` ids)
 684
 685 zonkPat env (ListPat pats ty)
 686   = zonkTcTypeToType ty `thenM` \ new_ty ->
 687     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 688     returnM (ListPat new_pats new_ty, ids)
 689
 690 zonkPat env (PArrPat pats ty)
 691   = zonkTcTypeToType ty `thenM` \ new_ty ->
 692     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 693     returnM (PArrPat new_pats new_ty, ids)
 694
 695 zonkPat env (TuplePat pats boxed)
 696   = zonkPats env pats                   `thenM` \ (new_pats, ids) ->
 697     returnM (TuplePat new_pats boxed, ids)
 698
 699 zonkPat env (ConPatOut n stuff ty tvs dicts)
 700   = zonkTcTypeToType ty                 `thenM` \ new_ty ->
 701     mappM zonkTcTyVarToTyVar tvs        `thenM` \ new_tvs ->
 702     mappM zonkIdBndr dicts              `thenM` \ new_dicts ->
 703     let
 704         env1 = extendZonkEnv env new_dicts
 705     in
 706     zonkConStuff env stuff              `thenM` \ (new_stuff, ids) ->
 707     returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
 708                  listToBag new_dicts `unionBags` ids)
 709
 710 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
 711
 712 zonkPat env (SigPatOut pat ty expr)
 713   = zonkPat env pat                     `thenM` \ (new_pat, ids) ->
 714     zonkTcTypeToType ty         `thenM` \ new_ty  ->
 715     zonkExpr env expr           `thenM` \ new_expr ->
 716     returnM (SigPatOut new_pat new_ty new_expr, ids)
 717
 718 zonkPat env (NPatOut lit ty expr)
 719   = zonkTcTypeToType ty         `thenM` \ new_ty   ->
 720     zonkExpr env expr           `thenM` \ new_expr ->
 721     returnM (NPatOut lit new_ty new_expr, emptyBag)
 722
 723 zonkPat env (NPlusKPatOut n k e1 e2)
 724   = zonkIdBndr n                `thenM` \ new_n ->
 725     zonkExpr env e1                     `thenM` \ new_e1 ->
 726     zonkExpr env e2                     `thenM` \ new_e2 ->
 727     returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
 728
 729 zonkPat env (DictPat ds ms)
 730   = mappM zonkIdBndr ds      `thenM` \ new_ds ->
 731     mappM zonkIdBndr ms      `thenM` \ new_ms ->
 732     returnM (DictPat new_ds new_ms,
 733                  listToBag new_ds `unionBags` listToBag new_ms)
 734
 735 ---------------------------
 736 zonkConStuff env (PrefixCon pats)
 737   = zonkPats env pats           `thenM` \ (new_pats, ids) ->
 738     returnM (PrefixCon new_pats, ids)
 739
 740 zonkConStuff env (InfixCon p1 p2)
 741   = zonkPat env p1              `thenM` \ (new_p1, ids1) ->
 742     zonkPat env p2              `thenM` \ (new_p2, ids2) ->
 743     returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
 744
 745 zonkConStuff env (RecCon rpats)
 746   = mapAndUnzipM zonk_rpat rpats        `thenM` \ (new_rpats, ids_s) ->
 747     returnM (RecCon new_rpats, unionManyBags ids_s)
 748   where
 749     zonk_rpat (f, pat)
 750       = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 751         returnM ((f, new_pat), ids)
 752
 753 ---------------------------
 754 zonkPats env []
 755   = returnM ([], emptyBag)
 756
 757 zonkPats env (pat:pats)
 758   = zonkPat env pat     `thenM` \ (pat',  ids1) ->
 759     zonkPats env pats   `thenM` \ (pats', ids2) ->
 760     returnM (pat':pats', ids1 `unionBags` ids2)
 761 \end{code}
 762
 763 %************************************************************************
 764 %*                                                                      *
 765 \subsection[BackSubst-Foreign]{Foreign exports}
 766 %*                                                                      *
 767 %************************************************************************
 768
 769
 770 \begin{code}
 771 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
 772 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 773
 774 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 775 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
 776    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
 777 \end{code}
 778
 779 \begin{code}
 780 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
 781 zonkRules env rs = mappM (zonkRule env) rs
 782
 783 zonkRule env (HsRule name act vars lhs rhs loc)
 784   = mappM zonk_bndr vars                                `thenM` \ new_bndrs ->
 785     let
 786         env1 = extendZonkEnv env (filter isId new_bndrs)
 787         -- Type variables don't need an envt
 788         -- They are bound through the mutable mechanism
 789     in
 790     zonkExpr env1 lhs                                   `thenM` \ new_lhs ->
 791     zonkExpr env1 rhs                                   `thenM` \ new_rhs ->
 792     returnM (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 793         -- I hate this map RuleBndr stuff
 794   where
 795    zonk_bndr (RuleBndr v)
 796         | isId v    = zonkIdBndr v
 797         | otherwise = zonkTcTyVarToTyVar v
 798
 799 zonkRule env (IfaceRuleOut fun rule)
 800   = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
 801 \end{code}
 802