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, mkPArrTy, 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 (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         = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
 356                 -- This isn't the binding occurrence of these tyvars
 357                 -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
 358           zonkIdBndr global             `thenNF_Tc` \ new_global ->
 359           zonkIdOcc local               `thenNF_Tc` \ new_local ->
 360           returnNF_Tc (new_tyvars, new_global, new_local)
 361 \end{code}
 362
 363 %************************************************************************
 364 %*                                                                      *
 365 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 \begin{code}
 370 zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch
 371
 372 zonkMatch (Match pats _ grhss)
 373   = zonkPats pats                               `thenNF_Tc` \ (new_pats, new_ids) ->
 374     tcExtendGlobalValEnv (bagToList new_ids)    $
 375     zonkGRHSs grhss                             `thenNF_Tc` \ new_grhss ->
 376     returnNF_Tc (Match new_pats Nothing new_grhss)
 377
 378 -------------------------------------------------------------------------
 379 zonkGRHSs :: TcGRHSs
 380           -> NF_TcM TypecheckedGRHSs
 381
 382 zonkGRHSs (GRHSs grhss binds ty)
 383   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 384     tcSetEnv new_env $
 385     let
 386         zonk_grhs (GRHS guarded locn)
 387           = zonkStmts guarded  `thenNF_Tc` \ new_guarded ->
 388             returnNF_Tc (GRHS new_guarded locn)
 389     in
 390     mapNF_Tc zonk_grhs grhss    `thenNF_Tc` \ new_grhss ->
 391     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 392     returnNF_Tc (GRHSs new_grhss new_binds new_ty)
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
 403
 404 zonkExpr (HsVar id)
 405   = zonkIdOcc id        `thenNF_Tc` \ id' ->
 406     returnNF_Tc (HsVar id')
 407
 408 zonkExpr (HsIPVar id)
 409   = mapIPNameTc zonkIdOcc id    `thenNF_Tc` \ id' ->
 410     returnNF_Tc (HsIPVar id')
 411
 412 zonkExpr (HsLit (HsRat f ty))
 413   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 414     returnNF_Tc (HsLit (HsRat f new_ty))
 415
 416 zonkExpr (HsLit (HsLitLit lit ty))
 417   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 418     returnNF_Tc (HsLit (HsLitLit lit new_ty))
 419
 420 zonkExpr (HsLit lit)
 421   = returnNF_Tc (HsLit lit)
 422
 423 -- HsOverLit doesn't appear in typechecker output
 424
 425 zonkExpr (HsLam match)
 426   = zonkMatch match     `thenNF_Tc` \ new_match ->
 427     returnNF_Tc (HsLam new_match)
 428
 429 zonkExpr (HsApp e1 e2)
 430   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 431     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 432     returnNF_Tc (HsApp new_e1 new_e2)
 433
 434 zonkExpr (OpApp e1 op fixity e2)
 435   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 436     zonkExpr op `thenNF_Tc` \ new_op ->
 437     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 438     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 439
 440 zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
 441 zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
 442
 443 zonkExpr (SectionL expr op)
 444   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 445     zonkExpr op         `thenNF_Tc` \ new_op ->
 446     returnNF_Tc (SectionL new_expr new_op)
 447
 448 zonkExpr (SectionR op expr)
 449   = zonkExpr op         `thenNF_Tc` \ new_op ->
 450     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 451     returnNF_Tc (SectionR new_op new_expr)
 452
 453 zonkExpr (HsCase expr ms src_loc)
 454   = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 455     mapNF_Tc zonkMatch ms   `thenNF_Tc` \ new_ms ->
 456     returnNF_Tc (HsCase new_expr new_ms src_loc)
 457
 458 zonkExpr (HsIf e1 e2 e3 src_loc)
 459   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 460     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 461     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 462     returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
 463
 464 zonkExpr (HsLet binds expr)
 465   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 466     tcSetEnv new_env            $
 467     zonkExpr expr       `thenNF_Tc` \ new_expr ->
 468     returnNF_Tc (HsLet new_binds new_expr)
 469
 470 zonkExpr (HsWith expr binds)
 471   = zonkIPBinds binds                           `thenNF_Tc` \ new_binds ->
 472     tcExtendGlobalValEnv (map (ipNameName . fst) new_binds)     $
 473     zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 474     returnNF_Tc (HsWith new_expr new_binds)
 475     where
 476         zonkIPBinds = mapNF_Tc zonkIPBind
 477         zonkIPBind (n, e)
 478             = mapIPNameTc zonkIdBndr n  `thenNF_Tc` \ n' ->
 479               zonkExpr e                `thenNF_Tc` \ e' ->
 480               returnNF_Tc (n', e')
 481
 482 zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
 483
 484 zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
 485   = zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 486     zonkTcTypeToType ty `thenNF_Tc` \ new_ty   ->
 487     zonkIdOcc return_id         `thenNF_Tc` \ new_return_id ->
 488     zonkIdOcc then_id           `thenNF_Tc` \ new_then_id ->
 489     zonkIdOcc zero_id           `thenNF_Tc` \ new_zero_id ->
 490     returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
 491                          new_ty src_loc)
 492
 493 zonkExpr (ExplicitList ty exprs)
 494   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 495     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 496     returnNF_Tc (ExplicitList new_ty new_exprs)
 497
 498 zonkExpr (ExplicitPArr ty exprs)
 499   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 500     mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 501     returnNF_Tc (ExplicitPArr new_ty new_exprs)
 502
 503 zonkExpr (ExplicitTuple exprs boxed)
 504   = mapNF_Tc zonkExpr exprs     `thenNF_Tc` \ new_exprs ->
 505     returnNF_Tc (ExplicitTuple new_exprs boxed)
 506
 507 zonkExpr (RecordConOut data_con con_expr rbinds)
 508   = zonkExpr con_expr   `thenNF_Tc` \ new_con_expr ->
 509     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 510     returnNF_Tc (RecordConOut data_con new_con_expr new_rbinds)
 511
 512 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 513
 514 zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
 515   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 516     zonkTcTypeToType in_ty      `thenNF_Tc` \ new_in_ty ->
 517     zonkTcTypeToType out_ty     `thenNF_Tc` \ new_out_ty ->
 518     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 519     zonkRbinds rbinds   `thenNF_Tc` \ new_rbinds ->
 520     returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
 521
 522 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 523 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
 524 zonkExpr (PArrSeqIn _)       = panic "zonkExpr:PArrSeqIn"
 525
 526 zonkExpr (ArithSeqOut expr info)
 527   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 528     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 529     returnNF_Tc (ArithSeqOut new_expr new_info)
 530
 531 zonkExpr (PArrSeqOut expr info)
 532   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 533     zonkArithSeq info   `thenNF_Tc` \ new_info ->
 534     returnNF_Tc (PArrSeqOut new_expr new_info)
 535
 536 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
 537   = mapNF_Tc zonkExpr args      `thenNF_Tc` \ new_args ->
 538     zonkTcTypeToType result_ty  `thenNF_Tc` \ new_result_ty ->
 539     returnNF_Tc (HsCCall fun new_args may_gc is_casm new_result_ty)
 540
 541 zonkExpr (HsSCC lbl expr)
 542   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 543     returnNF_Tc (HsSCC lbl new_expr)
 544
 545 zonkExpr (TyLam tyvars expr)
 546   = mapNF_Tc zonkTcTyVarToTyVar tyvars  `thenNF_Tc` \ new_tyvars ->
 547         -- No need to extend tyvar env; see AbsBinds
 548
 549     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 550     returnNF_Tc (TyLam new_tyvars new_expr)
 551
 552 zonkExpr (TyApp expr tys)
 553   = zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 554     mapNF_Tc zonkTcTypeToType tys       `thenNF_Tc` \ new_tys ->
 555     returnNF_Tc (TyApp new_expr new_tys)
 556
 557 zonkExpr (DictLam dicts expr)
 558   = mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 559     tcExtendGlobalValEnv new_dicts      $
 560     zonkExpr expr                       `thenNF_Tc` \ new_expr ->
 561     returnNF_Tc (DictLam new_dicts new_expr)
 562
 563 zonkExpr (DictApp expr dicts)
 564   = zonkExpr expr               `thenNF_Tc` \ new_expr ->
 565     mapNF_Tc zonkIdOcc dicts    `thenNF_Tc` \ new_dicts ->
 566     returnNF_Tc (DictApp new_expr new_dicts)
 567
 568
 569
 570 -------------------------------------------------------------------------
 571 zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
 572
 573 zonkArithSeq (From e)
 574   = zonkExpr e          `thenNF_Tc` \ new_e ->
 575     returnNF_Tc (From new_e)
 576
 577 zonkArithSeq (FromThen e1 e2)
 578   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 579     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 580     returnNF_Tc (FromThen new_e1 new_e2)
 581
 582 zonkArithSeq (FromTo e1 e2)
 583   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 584     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 585     returnNF_Tc (FromTo new_e1 new_e2)
 586
 587 zonkArithSeq (FromThenTo e1 e2 e3)
 588   = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
 589     zonkExpr e2 `thenNF_Tc` \ new_e2 ->
 590     zonkExpr e3 `thenNF_Tc` \ new_e3 ->
 591     returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
 592
 593 -------------------------------------------------------------------------
 594 zonkStmts :: [TcStmt]
 595           -> NF_TcM [TypecheckedStmt]
 596
 597 zonkStmts [] = returnNF_Tc []
 598
 599 zonkStmts (ParStmtOut bndrstmtss : stmts)
 600   = mapNF_Tc (mapNF_Tc zonkId) bndrss   `thenNF_Tc` \ new_bndrss ->
 601     let new_binders = concat new_bndrss in
 602     mapNF_Tc zonkStmts stmtss           `thenNF_Tc` \ new_stmtss ->
 603     tcExtendGlobalValEnv new_binders    $
 604     zonkStmts stmts                     `thenNF_Tc` \ new_stmts ->
 605     returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 606   where (bndrss, stmtss) = unzip bndrstmtss
 607
 608 zonkStmts (ResultStmt expr locn : stmts)
 609   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 610     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 611     returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 612
 613 zonkStmts (ExprStmt expr ty locn : stmts)
 614   = zonkExpr expr       `thenNF_Tc` \ new_expr ->
 615     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 616     zonkStmts stmts     `thenNF_Tc` \ new_stmts ->
 617     returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts)
 618
 619 zonkStmts (LetStmt binds : stmts)
 620   = zonkBinds binds             `thenNF_Tc` \ (new_binds, new_env) ->
 621     tcSetEnv new_env            $
 622     zonkStmts stmts             `thenNF_Tc` \ new_stmts ->
 623     returnNF_Tc (LetStmt new_binds : new_stmts)
 624
 625 zonkStmts (BindStmt pat expr locn : stmts)
 626   = zonkExpr expr                               `thenNF_Tc` \ new_expr ->
 627     zonkPat pat                                 `thenNF_Tc` \ (new_pat, new_ids) ->
 628     tcExtendGlobalValEnv (bagToList new_ids)    $
 629     zonkStmts stmts                             `thenNF_Tc` \ new_stmts ->
 630     returnNF_Tc (BindStmt new_pat new_expr locn : new_stmts)
 631
 632
 633
 634 -------------------------------------------------------------------------
 635 zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
 636
 637 zonkRbinds rbinds
 638   = mapNF_Tc zonk_rbind rbinds
 639   where
 640     zonk_rbind (field, expr, pun)
 641       = zonkExpr expr           `thenNF_Tc` \ new_expr ->
 642         zonkIdOcc field         `thenNF_Tc` \ new_field ->
 643         returnNF_Tc (new_field, new_expr, pun)
 644
 645 -------------------------------------------------------------------------
 646 mapIPNameTc :: (a -> NF_TcM b) -> IPName a -> NF_TcM (IPName b)
 647 mapIPNameTc f (Dupable n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Dupable r)
 648 mapIPNameTc f (Linear  n) = f n  `thenNF_Tc` \ r -> returnNF_Tc (Linear r)
 649 \end{code}
 650
 651
 652 %************************************************************************
 653 %*                                                                      *
 654 \subsection[BackSubst-Pats]{Patterns}
 655 %*                                                                      *
 656 %************************************************************************
 657
 658 \begin{code}
 659 zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id)
 660
 661 zonkPat (WildPat ty)
 662   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty ->
 663     returnNF_Tc (WildPat new_ty, emptyBag)
 664
 665 zonkPat (VarPat v)
 666   = zonkIdBndr v            `thenNF_Tc` \ new_v ->
 667     returnNF_Tc (VarPat new_v, unitBag new_v)
 668
 669 zonkPat (LazyPat pat)
 670   = zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 671     returnNF_Tc (LazyPat new_pat, ids)
 672
 673 zonkPat (AsPat n pat)
 674   = zonkIdBndr n            `thenNF_Tc` \ new_n ->
 675     zonkPat pat     `thenNF_Tc` \ (new_pat, ids) ->
 676     returnNF_Tc (AsPat new_n new_pat, new_n `consBag` ids)
 677
 678 zonkPat (ListPat ty pats)
 679   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 680     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 681     returnNF_Tc (ListPat new_ty new_pats, ids)
 682
 683 zonkPat (PArrPat ty pats)
 684   = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 685     zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 686     returnNF_Tc (PArrPat new_ty new_pats, ids)
 687
 688 zonkPat (TuplePat pats boxed)
 689   = zonkPats pats               `thenNF_Tc` \ (new_pats, ids) ->
 690     returnNF_Tc (TuplePat new_pats boxed, ids)
 691
 692 zonkPat (ConPat n ty tvs dicts pats)
 693   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty ->
 694     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 695     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 696     tcExtendGlobalValEnv new_dicts      $
 697     zonkPats pats                       `thenNF_Tc` \ (new_pats, ids) ->
 698     returnNF_Tc (ConPat n new_ty new_tvs new_dicts new_pats,
 699                  listToBag new_dicts `unionBags` ids)
 700
 701 zonkPat (RecPat n ty tvs dicts rpats)
 702   = zonkTcTypeToType ty                 `thenNF_Tc` \ new_ty ->
 703     mapNF_Tc zonkTcTyVarToTyVar tvs     `thenNF_Tc` \ new_tvs ->
 704     mapNF_Tc zonkIdBndr dicts           `thenNF_Tc` \ new_dicts ->
 705     tcExtendGlobalValEnv new_dicts      $
 706     mapAndUnzipNF_Tc zonk_rpat rpats    `thenNF_Tc` \ (new_rpats, ids_s) ->
 707     returnNF_Tc (RecPat n new_ty new_tvs new_dicts new_rpats,
 708                  listToBag new_dicts `unionBags` unionManyBags ids_s)
 709   where
 710     zonk_rpat (f, pat, pun)
 711       = zonkPat pat             `thenNF_Tc` \ (new_pat, ids) ->
 712         returnNF_Tc ((f, new_pat, pun), ids)
 713
 714 zonkPat (LitPat lit ty)
 715   = zonkTcTypeToType ty     `thenNF_Tc` \ new_ty  ->
 716     returnNF_Tc (LitPat lit new_ty, emptyBag)
 717
 718 zonkPat (SigPat pat ty expr)
 719   = zonkPat pat                 `thenNF_Tc` \ (new_pat, ids) ->
 720     zonkTcTypeToType ty         `thenNF_Tc` \ new_ty  ->
 721     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 722     returnNF_Tc (SigPat new_pat new_ty new_expr, ids)
 723
 724 zonkPat (NPat lit ty expr)
 725   = zonkTcTypeToType ty         `thenNF_Tc` \ new_ty   ->
 726     zonkExpr expr               `thenNF_Tc` \ new_expr ->
 727     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 728
 729 zonkPat (NPlusKPat n k ty e1 e2)
 730   = zonkIdBndr n                `thenNF_Tc` \ new_n ->
 731     zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
 732     zonkExpr e1         `thenNF_Tc` \ new_e1 ->
 733     zonkExpr e2         `thenNF_Tc` \ new_e2 ->
 734     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 735
 736 zonkPat (DictPat ds ms)
 737   = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
 738     mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
 739     returnNF_Tc (DictPat new_ds new_ms,
 740                  listToBag new_ds `unionBags` listToBag new_ms)
 741
 742
 743 zonkPats []
 744   = returnNF_Tc ([], emptyBag)
 745
 746 zonkPats (pat:pats)
 747   = zonkPat pat         `thenNF_Tc` \ (pat',  ids1) ->
 748     zonkPats pats       `thenNF_Tc` \ (pats', ids2) ->
 749     returnNF_Tc (pat':pats', ids1 `unionBags` ids2)
 750 \end{code}
 751
 752 %************************************************************************
 753 %*                                                                      *
 754 \subsection[BackSubst-Foreign]{Foreign exports}
 755 %*                                                                      *
 756 %************************************************************************
 757
 758
 759 \begin{code}
 760 zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 761 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 762
 763 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
 764 zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
 765    zonkIdOcc i  `thenNF_Tc` \ i' ->
 766    returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
 767 \end{code}
 768
 769 \begin{code}
 770 zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl]
 771 zonkRules rs = mapNF_Tc zonkRule rs
 772
 773 zonkRule (HsRule name act vars lhs rhs loc)
 774   = mapNF_Tc zonk_bndr vars                             `thenNF_Tc` \ new_bndrs ->
 775     tcExtendGlobalValEnv (filter isId new_bndrs)        $
 776         -- Type variables don't need an envt
 777         -- They are bound through the mutable mechanism
 778     zonkExpr lhs                                        `thenNF_Tc` \ new_lhs ->
 779     zonkExpr rhs                                        `thenNF_Tc` \ new_rhs ->
 780     returnNF_Tc (HsRule name act (map RuleBndr new_bndrs) new_lhs new_rhs loc)
 781         -- I hate this map RuleBndr stuff
 782   where
 783    zonk_bndr (RuleBndr v)
 784         | isId v    = zonkIdBndr v
 785         | otherwise = zonkTcTyVarToTyVar v
 786
 787 zonkRule (IfaceRuleOut fun rule)
 788   = zonkIdOcc fun       `thenNF_Tc` \ fun' ->
 789     returnNF_Tc (IfaceRuleOut fun' rule)
 790 \end{code}