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, zonkTopBndrs
  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, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
  49                     tcGetTyVar, isAnyTypeKind, mkTyConApp )
  50 import qualified  Type
  51 import TcMType    ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
  52                     putTcTyVar )
  53 import TysPrim    ( charPrimTy, intPrimTy, floatPrimTy,
  54                     doublePrimTy, addrPrimTy
  55                   )
  56 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
  57                     mkListTy, mkPArrTy, mkTupleTy, unitTy,
  58                     voidTy, listTyCon, tupleTyCon )
  59 import TyCon      ( mkPrimTyCon, tyConKind )
  60 import PrimRep    ( PrimRep(VoidRep) )
  61 import CoreSyn    ( CoreExpr )
  62 import Name       ( getOccName, mkInternalName, mkDerivedTyConOcc )
  63 import Var        ( isId, isLocalVar, tyVarKind )
  64 import VarSet
  65 import VarEnv
  66 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
  67 import Maybes     ( orElse )
  68 import Unique     ( Uniquable(..) )
  69 import SrcLoc     ( noSrcLoc )
  70 import Bag
  71 import Outputable
  72 \end{code}
  73
  74
  75 Type definitions
  76 ~~~~~~~~~~~~~~~~
  77
  78 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
  79 All the types in @Tc...@ things have mutable type-variables in them for
  80 unification.
  81
  82 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
  83 which have immutable type variables in them.
  84
  85 \begin{code}
  86 type TcHsBinds          = HsBinds       TcId
  87 type TcMonoBinds        = MonoBinds     TcId
  88 type TcDictBinds        = TcMonoBinds
  89 type TcPat              = OutPat        TcId
  90 type TcExpr             = HsExpr        TcId
  91 type TcGRHSs            = GRHSs         TcId
  92 type TcGRHS             = GRHS          TcId
  93 type TcMatch            = Match         TcId
  94 type TcStmt             = Stmt          TcId
  95 type TcArithSeqInfo     = ArithSeqInfo  TcId
  96 type TcRecordBinds      = HsRecordBinds TcId
  97 type TcHsModule         = HsModule      TcId
  98 type TcForeignDecl      = ForeignDecl  TcId
  99 type TcRuleDecl         = RuleDecl     TcId
 100
 101 type TypecheckedPat             = OutPat        Id
 102 type TypecheckedMonoBinds       = MonoBinds     Id
 103 type TypecheckedDictBinds       = TypecheckedMonoBinds
 104 type TypecheckedHsBinds         = HsBinds       Id
 105 type TypecheckedHsExpr          = HsExpr        Id
 106 type TypecheckedArithSeqInfo    = ArithSeqInfo  Id
 107 type TypecheckedStmt            = Stmt          Id
 108 type TypecheckedMatch           = Match         Id
 109 type TypecheckedMatchContext    = HsMatchContext Id
 110 type TypecheckedGRHSs           = GRHSs         Id
 111 type TypecheckedGRHS            = GRHS          Id
 112 type TypecheckedRecordBinds     = HsRecordBinds Id
 113 type TypecheckedHsModule        = HsModule      Id
 114 type TypecheckedForeignDecl     = ForeignDecl   Id
 115 type TypecheckedRuleDecl        = RuleDecl      Id
 116 type TypecheckedCoreBind        = (Id, CoreExpr)
 117 \end{code}
 118
 119 \begin{code}
 120 mkHsTyApp expr []  = expr
 121 mkHsTyApp expr tys = TyApp expr tys
 122
 123 mkHsDictApp expr []      = expr
 124 mkHsDictApp expr dict_vars = DictApp expr dict_vars
 125
 126 mkHsTyLam []     expr = expr
 127 mkHsTyLam tyvars expr = TyLam tyvars expr
 128
 129 mkHsDictLam []    expr = expr
 130 mkHsDictLam dicts expr = DictLam dicts expr
 131
 132 mkHsLet EmptyMonoBinds expr = expr
 133 mkHsLet mbinds         expr = HsLet (MonoBind mbinds [] Recursive) expr
 134
 135 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
 136 \end{code}
 137
 138
 139 %************************************************************************
 140 %*                                                                      *
 141 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 142 %*                                                                      *
 143 %************************************************************************
 144
 145 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
 146 then something is wrong.
 147 \begin{code}
 148 hsPatType :: TypecheckedPat -> Type
 149
 150 hsPatType (ParPat pat)            = hsPatType pat
 151 hsPatType (WildPat ty)            = ty
 152 hsPatType (VarPat var)            = idType var
 153 hsPatType (LazyPat pat)           = hsPatType pat
 154 hsPatType (LitPat lit)            = hsLitType lit
 155 hsPatType (AsPat var pat)         = idType var
 156 hsPatType (ListPat _ ty)          = mkListTy ty
 157 hsPatType (PArrPat _ ty)          = mkPArrTy ty
 158 hsPatType (TuplePat pats box)     = mkTupleTy box (length pats) (map hsPatType pats)
 159 hsPatType (ConPatOut _ _ ty _ _)  = ty
 160 hsPatType (SigPatOut _ ty _)      = ty
 161 hsPatType (NPatOut lit ty _)      = ty
 162 hsPatType (NPlusKPatOut id _ _ _) = idType id
 163 hsPatType (DictPat ds ms)         = case (ds ++ ms) of
 164                                        []  -> unitTy
 165                                        [d] -> idType d
 166                                        ds  -> mkTupleTy Boxed (length ds) (map idType ds)
 167
 168
 169 hsLitType :: HsLit -> TcType
 170 hsLitType (HsChar c)       = charTy
 171 hsLitType (HsCharPrim c)   = charPrimTy
 172 hsLitType (HsString str)   = stringTy
 173 hsLitType (HsStringPrim s) = addrPrimTy
 174 hsLitType (HsInt i)        = intTy
 175 hsLitType (HsIntPrim i)    = intPrimTy
 176 hsLitType (HsInteger i)    = integerTy
 177 hsLitType (HsRat _ ty)     = ty
 178 hsLitType (HsFloatPrim f)  = floatPrimTy
 179 hsLitType (HsDoublePrim d) = doublePrimTy
 180 hsLitType (HsLitLit _ ty)  = ty
 181 \end{code}
 182
 183 \begin{code}
 184 -- zonkId is used *during* typechecking just to zonk the Id's type
 185 zonkId :: TcId -> TcM TcId
 186 zonkId id
 187   = zonkTcType (idType id) `thenM` \ ty' ->
 188     returnM (setIdType id ty')
 189 \end{code}
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 This zonking pass runs over the bindings
 199
 200  a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
 201  b) convert unbound TcTyVar to Void
 202  c) convert each TcId to an Id by zonking its type
 203
 204 The type variables are converted by binding mutable tyvars to immutable ones
 205 and then zonking as normal.
 206
 207 The Ids are converted by binding them in the normal Tc envt; that
 208 way we maintain sharing; eg an Id is zonked at its binding site and they
 209 all occurrences of that Id point to the common zonked copy
 210
 211 It's all pretty boring stuff, because HsSyn is such a large type, and
 212 the environment manipulation is tiresome.
 213
 214 \begin{code}
 215 data ZonkEnv = ZonkEnv  (TcType -> TcM Type)    -- How to zonk a type
 216                         (IdEnv Id)              -- What variables are in scope
 217         -- Maps an Id to its zonked version; both have the same Name
 218         -- Is only consulted lazily; hence knot-tying
 219
 220 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
 221
 222 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
 223 extendZonkEnv (ZonkEnv zonk_ty env) ids
 224   = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
 225
 226 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
 227 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
 228
 229 mkZonkEnv :: [Id] -> ZonkEnv
 230 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
 231
 232 zonkIdOcc :: ZonkEnv -> TcId -> Id
 233 -- Ids defined in this module should be in the envt;
 234 -- ignore others.  (Actually, data constructors are also
 235 -- not LocalVars, even when locally defined, but that is fine.)
 236 --
 237 -- Actually, Template Haskell works in 'chunks' of declarations, and
 238 -- an earlier chunk won't be in the 'env' that the zonking phase
 239 -- carries around.  Instead it'll be in the tcg_gbl_env, already fully
 240 -- zonked.  There's no point in looking it up there (except for error
 241 -- checking), and it's not conveniently to hand; hence the simple
 242 -- 'orElse' case in the LocalVar branch.
 243 --
 244 -- Even without template splices, in module Main, the checking of
 245 -- 'main' is done as a separte chunk.
 246 zonkIdOcc (ZonkEnv zonk_ty env) id
 247   | isLocalVar id = lookupVarEnv env id `orElse` id
 248   | otherwise     = id
 249
 250 zonkIdOccs env ids = map (zonkIdOcc env) ids
 251
 252 -- zonkIdBndr is used *after* typechecking to get the Id's type
 253 -- to its final form.  The TyVarEnv give
 254 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
 255 zonkIdBndr env id
 256   = zonkTcTypeToType env (idType id)    `thenM` \ ty' ->
 257     returnM (setIdType id ty')
 258
 259 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 260 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
 261
 262 zonkTopBndrs :: [TcId] -> TcM [Id]
 263 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 264 \end{code}
 265
 266
 267 \begin{code}
 268 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
 269 zonkTopExpr e = zonkExpr emptyZonkEnv e
 270
 271 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
 272              -> TcM ([Id],
 273                         TypecheckedMonoBinds,
 274                         [TypecheckedForeignDecl],
 275                         [TypecheckedRuleDecl])
 276 zonkTopDecls binds rules fords  -- Top level is implicitly recursive
 277   = fixM (\ ~(new_ids, _, _, _) ->
 278         let
 279            zonk_env = mkZonkEnv new_ids
 280         in
 281         zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
 282         zonkRules zonk_env rules                `thenM` \ rules' ->
 283         zonkForeignExports zonk_env fords       `thenM` \ fords' ->
 284
 285         returnM (bagToList new_ids, binds', fords', rules')
 286     )
 287
 288 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
 289 zonkTopBinds binds
 290   = fixM (\ ~(new_ids, _) ->
 291         let
 292            zonk_env = mkZonkEnv new_ids
 293         in
 294         zonkMonoBinds zonk_env binds            `thenM` \ (binds', new_ids) ->
 295         returnM (bagToList new_ids, binds')
 296     )
 297
 298 ---------------------------------------------
 299 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
 300 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
 301
 302 zonkBinds env (ThenBinds b1 b2)
 303   = zonkBinds env b1    `thenM` \ (env1, b1') ->
 304     zonkBinds env1 b2   `thenM` \ (env2, b2') ->
 305     returnM (env2, b1' `ThenBinds` b2')
 306
 307 zonkBinds env (MonoBind bind sigs is_rec)
 308   = ASSERT( null sigs )
 309     fixM (\ ~(_, _, new_ids) ->
 310         let
 311            env1 = extendZonkEnv env (bagToList new_ids)
 312         in
 313         zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
 314         returnM (env1, new_bind, new_ids)
 315     )                           `thenM` \ (env1, new_bind, _) ->
 316    returnM (env1, mkMonoBind new_bind [] is_rec)
 317
 318 ---------------------------------------------
 319 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
 320               -> TcM (TypecheckedMonoBinds, Bag Id)
 321
 322 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
 323
 324 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
 325   = zonkMonoBinds env mbinds1           `thenM` \ (b1', ids1) ->
 326     zonkMonoBinds env mbinds2           `thenM` \ (b2', ids2) ->
 327     returnM (b1' `AndMonoBinds` b2',
 328                  ids1 `unionBags` ids2)
 329
 330 zonkMonoBinds env (PatMonoBind pat grhss locn)
 331   = zonkPat env pat     `thenM` \ (new_pat, ids) ->
 332     zonkGRHSs env grhss `thenM` \ new_grhss ->
 333     returnM (PatMonoBind new_pat new_grhss locn, ids)
 334
 335 zonkMonoBinds env (VarMonoBind var expr)
 336   = zonkIdBndr env var  `thenM` \ new_var ->
 337     zonkExpr env expr   `thenM` \ new_expr ->
 338     returnM (VarMonoBind new_var new_expr, unitBag new_var)
 339
 340 zonkMonoBinds env (CoreMonoBind var core_expr)
 341   = zonkIdBndr env var          `thenM` \ new_var ->
 342     returnM (CoreMonoBind new_var core_expr, unitBag new_var)
 343
 344 zonkMonoBinds env (FunMonoBind var inf ms locn)
 345   = zonkIdBndr env var                  `thenM` \ new_var ->
 346     mappM (zonkMatch env) ms            `thenM` \ new_ms ->
 347     returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
 348
 349
 350 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
 351   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 352         -- No need to extend tyvar env: the effects are
 353         -- propagated through binding the tyvars themselves
 354
 355     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 356     fixM (\ ~(_, _, val_bind_ids) ->
 357         let
 358           env1 = extendZonkEnv (extendZonkEnv env new_dicts)
 359                                (bagToList val_bind_ids)
 360         in
 361         zonkMonoBinds env1 val_bind             `thenM` \ (new_val_bind, val_bind_ids) ->
 362         mappM (zonkExport env1) exports `thenM` \ new_exports ->
 363         returnM (new_val_bind, new_exports, val_bind_ids)
 364     )                                           `thenM ` \ (new_val_bind, new_exports, _) ->
 365     let
 366         new_globals = listToBag [global | (_, global, local) <- new_exports]
 367     in
 368     returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
 369                  new_globals)
 370   where
 371     zonkExport env (tyvars, global, local)
 372         = zonkTcTyVars tyvars           `thenM` \ tys ->
 373           let
 374                 new_tyvars = map (tcGetTyVar "zonkExport") tys
 375                 -- This isn't the binding occurrence of these tyvars
 376                 -- but they should *be* tyvars.  Hence tcGetTyVar.
 377           in
 378           zonkIdBndr env global         `thenM` \ new_global ->
 379           returnM (new_tyvars, new_global, zonkIdOcc env local)
 380 \end{code}
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
 390
 391 zonkMatch env (Match pats _ grhss)
 392   = zonkPats env pats                                           `thenM` \ (new_pats, new_ids) ->
 393     zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss     `thenM` \ new_grhss ->
 394     returnM (Match new_pats Nothing new_grhss)
 395
 396 -------------------------------------------------------------------------
 397 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
 398
 399 zonkGRHSs env (GRHSs grhss binds ty)
 400   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 401     let
 402         zonk_grhs (GRHS guarded locn)
 403           = zonkStmts new_env guarded  `thenM` \ new_guarded ->
 404             returnM (GRHS new_guarded locn)
 405     in
 406     mappM zonk_grhs grhss       `thenM` \ new_grhss ->
 407     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 408     returnM (GRHSs new_grhss new_binds new_ty)
 409 \end{code}
 410
 411 %************************************************************************
 412 %*                                                                      *
 413 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
 414 %*                                                                      *
 415 %************************************************************************
 416
 417 \begin{code}
 418 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
 419
 420 zonkExpr env (HsVar id)
 421   = returnM (HsVar (zonkIdOcc env id))
 422
 423 zonkExpr env (HsIPVar id)
 424   = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
 425
 426 zonkExpr env (HsLit (HsRat f ty))
 427   = zonkTcTypeToType env ty        `thenM` \ new_ty  ->
 428     returnM (HsLit (HsRat f new_ty))
 429
 430 zonkExpr env (HsLit (HsLitLit lit ty))
 431   = zonkTcTypeToType env ty         `thenM` \ new_ty  ->
 432     returnM (HsLit (HsLitLit lit new_ty))
 433
 434 zonkExpr env (HsLit lit)
 435   = returnM (HsLit lit)
 436
 437 -- HsOverLit doesn't appear in typechecker output
 438
 439 zonkExpr env (HsLam match)
 440   = zonkMatch env match `thenM` \ new_match ->
 441     returnM (HsLam new_match)
 442
 443 zonkExpr env (HsApp e1 e2)
 444   = zonkExpr env e1     `thenM` \ new_e1 ->
 445     zonkExpr env e2     `thenM` \ new_e2 ->
 446     returnM (HsApp new_e1 new_e2)
 447
 448 zonkExpr env (HsBracketOut body bs)
 449   = mappM zonk_b bs     `thenM` \ bs' ->
 450     returnM (HsBracketOut body bs')
 451   where
 452     zonk_b (n,e) = zonkExpr env e       `thenM` \ e' ->
 453                    returnM (n,e')
 454
 455 zonkExpr env (HsSplice n e) = WARN( True, ppr e )       -- Should not happen
 456                               returnM (HsSplice n e)
 457
 458 zonkExpr env (OpApp e1 op fixity e2)
 459   = zonkExpr env e1     `thenM` \ new_e1 ->
 460     zonkExpr env op     `thenM` \ new_op ->
 461     zonkExpr env e2     `thenM` \ new_e2 ->
 462     returnM (OpApp new_e1 new_op fixity new_e2)
 463
 464 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
 465
 466 zonkExpr env (HsPar e)
 467   = zonkExpr env e      `thenM` \new_e ->
 468     returnM (HsPar new_e)
 469
 470 zonkExpr env (SectionL expr op)
 471   = zonkExpr env expr   `thenM` \ new_expr ->
 472     zonkExpr env op             `thenM` \ new_op ->
 473     returnM (SectionL new_expr new_op)
 474
 475 zonkExpr env (SectionR op expr)
 476   = zonkExpr env op             `thenM` \ new_op ->
 477     zonkExpr env expr           `thenM` \ new_expr ->
 478     returnM (SectionR new_op new_expr)
 479
 480 zonkExpr env (HsCase expr ms src_loc)
 481   = zonkExpr env expr           `thenM` \ new_expr ->
 482     mappM (zonkMatch env) ms    `thenM` \ new_ms ->
 483     returnM (HsCase new_expr new_ms src_loc)
 484
 485 zonkExpr env (HsIf e1 e2 e3 src_loc)
 486   = zonkExpr env e1     `thenM` \ new_e1 ->
 487     zonkExpr env e2     `thenM` \ new_e2 ->
 488     zonkExpr env e3     `thenM` \ new_e3 ->
 489     returnM (HsIf new_e1 new_e2 new_e3 src_loc)
 490
 491 zonkExpr env (HsLet binds expr)
 492   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 493     zonkExpr new_env expr       `thenM` \ new_expr ->
 494     returnM (HsLet new_binds new_expr)
 495
 496 zonkExpr env (HsWith expr binds is_with)
 497   = mappM zonk_ip_bind binds    `thenM` \ new_binds ->
 498     let
 499         env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
 500     in
 501     zonkExpr env1 expr          `thenM` \ new_expr ->
 502     returnM (HsWith new_expr new_binds is_with)
 503     where
 504         zonk_ip_bind (n, e)
 505             = mapIPNameTc (zonkIdBndr env) n    `thenM` \ n' ->
 506               zonkExpr env e                    `thenM` \ e' ->
 507               returnM (n', e')
 508
 509 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
 510   = zonkStmts env stmts         `thenM` \ new_stmts ->
 511     zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 512     returnM (HsDo do_or_lc new_stmts
 513                       (zonkIdOccs env ids)
 514                       new_ty src_loc)
 515
 516 zonkExpr env (ExplicitList ty exprs)
 517   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 518     mappM (zonkExpr env) exprs  `thenM` \ new_exprs ->
 519     returnM (ExplicitList new_ty new_exprs)
 520
 521 zonkExpr env (ExplicitPArr ty exprs)
 522   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 523     mappM (zonkExpr env) exprs  `thenM` \ new_exprs ->
 524     returnM (ExplicitPArr new_ty new_exprs)
 525
 526 zonkExpr env (ExplicitTuple exprs boxed)
 527   = mappM (zonkExpr env) exprs          `thenM` \ new_exprs ->
 528     returnM (ExplicitTuple new_exprs boxed)
 529
 530 zonkExpr env (RecordConOut data_con con_expr rbinds)
 531   = zonkExpr env con_expr       `thenM` \ new_con_expr ->
 532     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 533     returnM (RecordConOut data_con new_con_expr new_rbinds)
 534
 535 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
 536
 537 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
 538   = zonkExpr env expr           `thenM` \ new_expr ->
 539     zonkTcTypeToType env in_ty  `thenM` \ new_in_ty ->
 540     zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
 541     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 542     returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 543
 544 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 545 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 546 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
 547
 548 zonkExpr env (ArithSeqOut expr info)
 549   = zonkExpr env expr           `thenM` \ new_expr ->
 550     zonkArithSeq env info       `thenM` \ new_info ->
 551     returnM (ArithSeqOut new_expr new_info)
 552
 553 zonkExpr env (PArrSeqOut expr info)
 554   = zonkExpr env expr           `thenM` \ new_expr ->
 555     zonkArithSeq env info       `thenM` \ new_info ->
 556     returnM (PArrSeqOut new_expr new_info)
 557
 558 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
 559   = mappM (zonkExpr env) args           `thenM` \ new_args ->
 560     zonkTcTypeToType env result_ty      `thenM` \ new_result_ty ->
 561     returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
 562
 563 zonkExpr env (HsSCC lbl expr)
 564   = zonkExpr env expr   `thenM` \ new_expr ->
 565     returnM (HsSCC lbl new_expr)
 566
 567 zonkExpr env (TyLam tyvars expr)
 568   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 569         -- No need to extend tyvar env; see AbsBinds
 570
 571     zonkExpr env expr                   `thenM` \ new_expr ->
 572     returnM (TyLam new_tyvars new_expr)
 573
 574 zonkExpr env (TyApp expr tys)
 575   = zonkExpr env expr                   `thenM` \ new_expr ->
 576     mappM (zonkTcTypeToType env) tys    `thenM` \ new_tys ->
 577     returnM (TyApp new_expr new_tys)
 578
 579 zonkExpr env (DictLam dicts expr)
 580   = zonkIdBndrs env dicts       `thenM` \ new_dicts ->
 581     let
 582         env1 = extendZonkEnv env new_dicts
 583     in
 584     zonkExpr env1 expr          `thenM` \ new_expr ->
 585     returnM (DictLam new_dicts new_expr)
 586
 587 zonkExpr env (DictApp expr dicts)
 588   = zonkExpr env expr                   `thenM` \ new_expr ->
 589     returnM (DictApp new_expr (zonkIdOccs env dicts))
 590
 591
 592
 593 -------------------------------------------------------------------------
 594 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
 595
 596 zonkArithSeq env (From e)
 597   = zonkExpr env e              `thenM` \ new_e ->
 598     returnM (From new_e)
 599
 600 zonkArithSeq env (FromThen e1 e2)
 601   = zonkExpr env e1     `thenM` \ new_e1 ->
 602     zonkExpr env e2     `thenM` \ new_e2 ->
 603     returnM (FromThen new_e1 new_e2)
 604
 605 zonkArithSeq env (FromTo e1 e2)
 606   = zonkExpr env e1     `thenM` \ new_e1 ->
 607     zonkExpr env e2     `thenM` \ new_e2 ->
 608     returnM (FromTo new_e1 new_e2)
 609
 610 zonkArithSeq env (FromThenTo e1 e2 e3)
 611   = zonkExpr env e1     `thenM` \ new_e1 ->
 612     zonkExpr env e2     `thenM` \ new_e2 ->
 613     zonkExpr env e3     `thenM` \ new_e3 ->
 614     returnM (FromThenTo new_e1 new_e2 new_e3)
 615
 616 -------------------------------------------------------------------------
 617 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
 618
 619 zonkStmts env [] = returnM []
 620
 621 zonkStmts env (ParStmtOut bndrstmtss : stmts)
 622   = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
 623     mappM (zonkStmts env) stmtss        `thenM` \ new_stmtss ->
 624     let
 625         new_binders = concat new_bndrss
 626         env1 = extendZonkEnv env new_binders
 627     in
 628     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 629     returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 630   where
 631     (bndrss, stmtss) = unzip bndrstmtss
 632
 633 zonkStmts env (ResultStmt expr locn : stmts)
 634   = zonkExpr env expr   `thenM` \ new_expr ->
 635     zonkStmts env stmts `thenM` \ new_stmts ->
 636     returnM (ResultStmt new_expr locn : new_stmts)
 637
 638 zonkStmts env (ExprStmt expr ty locn : stmts)
 639   = zonkExpr env expr           `thenM` \ new_expr ->
 640     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 641     zonkStmts env stmts         `thenM` \ new_stmts ->
 642     returnM (ExprStmt new_expr new_ty locn : new_stmts)
 643
 644 zonkStmts env (LetStmt binds : stmts)
 645   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 646     zonkStmts new_env stmts     `thenM` \ new_stmts ->
 647     returnM (LetStmt new_binds : new_stmts)
 648
 649 zonkStmts env (BindStmt pat expr locn : stmts)
 650   = zonkExpr env expr                   `thenM` \ new_expr ->
 651     zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 652     let
 653         env1 = extendZonkEnv env (bagToList new_ids)
 654     in
 655     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 656     returnM (BindStmt new_pat new_expr locn : new_stmts)
 657
 658
 659
 660 -------------------------------------------------------------------------
 661 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
 662
 663 zonkRbinds env rbinds
 664   = mappM zonk_rbind rbinds
 665   where
 666     zonk_rbind (field, expr)
 667       = zonkExpr env expr       `thenM` \ new_expr ->
 668         returnM (zonkIdOcc env field, new_expr)
 669
 670 -------------------------------------------------------------------------
 671 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 672 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 673 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 674 \end{code}
 675
 676
 677 %************************************************************************
 678 %*                                                                      *
 679 \subsection[BackSubst-Pats]{Patterns}
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 \begin{code}
 684 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
 685
 686 zonkPat env (ParPat p)
 687   = zonkPat env p       `thenM` \ (new_p, ids) ->
 688     returnM (ParPat new_p, ids)
 689
 690 zonkPat env (WildPat ty)
 691   = zonkTcTypeToType env ty   `thenM` \ new_ty ->
 692     returnM (WildPat new_ty, emptyBag)
 693
 694 zonkPat env (VarPat v)
 695   = zonkIdBndr env v        `thenM` \ new_v ->
 696     returnM (VarPat new_v, unitBag new_v)
 697
 698 zonkPat env (LazyPat pat)
 699   = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 700     returnM (LazyPat new_pat, ids)
 701
 702 zonkPat env (AsPat n pat)
 703   = zonkIdBndr env n        `thenM` \ new_n ->
 704     zonkPat env pat         `thenM` \ (new_pat, ids) ->
 705     returnM (AsPat new_n new_pat, new_n `consBag` ids)
 706
 707 zonkPat env (ListPat pats ty)
 708   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 709     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 710     returnM (ListPat new_pats new_ty, ids)
 711
 712 zonkPat env (PArrPat pats ty)
 713   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 714     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 715     returnM (PArrPat new_pats new_ty, ids)
 716
 717 zonkPat env (TuplePat pats boxed)
 718   = zonkPats env pats                   `thenM` \ (new_pats, ids) ->
 719     returnM (TuplePat new_pats boxed, ids)
 720
 721 zonkPat env (ConPatOut n stuff ty tvs dicts)
 722   = zonkTcTypeToType env ty             `thenM` \ new_ty ->
 723     mappM zonkTcTyVarToTyVar tvs        `thenM` \ new_tvs ->
 724     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 725     let
 726         env1 = extendZonkEnv env new_dicts
 727     in
 728     zonkConStuff env stuff              `thenM` \ (new_stuff, ids) ->
 729     returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
 730                  listToBag new_dicts `unionBags` ids)
 731
 732 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
 733
 734 zonkPat env (SigPatOut pat ty expr)
 735   = zonkPat env pat             `thenM` \ (new_pat, ids) ->
 736     zonkTcTypeToType env ty     `thenM` \ new_ty  ->
 737     zonkExpr env expr           `thenM` \ new_expr ->
 738     returnM (SigPatOut new_pat new_ty new_expr, ids)
 739
 740 zonkPat env (NPatOut lit ty expr)
 741   = zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 742     zonkExpr env expr           `thenM` \ new_expr ->
 743     returnM (NPatOut lit new_ty new_expr, emptyBag)
 744
 745 zonkPat env (NPlusKPatOut n k e1 e2)
 746   = zonkIdBndr env n            `thenM` \ new_n ->
 747     zonkExpr env e1                     `thenM` \ new_e1 ->
 748     zonkExpr env e2                     `thenM` \ new_e2 ->
 749     returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
 750
 751 zonkPat env (DictPat ds ms)
 752   = zonkIdBndrs env ds      `thenM` \ new_ds ->
 753     zonkIdBndrs env ms     `thenM` \ new_ms ->
 754     returnM (DictPat new_ds new_ms,
 755                  listToBag new_ds `unionBags` listToBag new_ms)
 756
 757 ---------------------------
 758 zonkConStuff env (PrefixCon pats)
 759   = zonkPats env pats           `thenM` \ (new_pats, ids) ->
 760     returnM (PrefixCon new_pats, ids)
 761
 762 zonkConStuff env (InfixCon p1 p2)
 763   = zonkPat env p1              `thenM` \ (new_p1, ids1) ->
 764     zonkPat env p2              `thenM` \ (new_p2, ids2) ->
 765     returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
 766
 767 zonkConStuff env (RecCon rpats)
 768   = mapAndUnzipM zonk_rpat rpats        `thenM` \ (new_rpats, ids_s) ->
 769     returnM (RecCon new_rpats, unionManyBags ids_s)
 770   where
 771     zonk_rpat (f, pat)
 772       = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 773         returnM ((f, new_pat), ids)
 774
 775 ---------------------------
 776 zonkPats env []
 777   = returnM ([], emptyBag)
 778
 779 zonkPats env (pat:pats)
 780   = zonkPat env pat     `thenM` \ (pat',  ids1) ->
 781     zonkPats env pats   `thenM` \ (pats', ids2) ->
 782     returnM (pat':pats', ids1 `unionBags` ids2)
 783 \end{code}
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsection[BackSubst-Foreign]{Foreign exports}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791
 792 \begin{code}
 793 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
 794 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 795
 796 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 797 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
 798    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
 799 \end{code}
 800
 801 \begin{code}
 802 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
 803 zonkRules env rs = mappM (zonkRule env) rs
 804
 805 zonkRule env (HsRule name act vars lhs rhs loc)
 806   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 807     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 808     let
 809         env_rhs = extendZonkEnv env (filter isId new_bndrs)
 810         -- Type variables don't need an envt
 811         -- They are bound through the mutable mechanism
 812
 813         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 814         -- We need to gather the type variables mentioned on the LHS so we can
 815         -- quantify over them.  Example:
 816         --   data T a = C
 817         --
 818         --   foo :: T a -> Int
 819         --   foo C = 1
 820         --
 821         --   {-# RULES "myrule"  foo C = 1 #-}
 822         --
 823         -- After type checking the LHS becomes (foo a (C a))
 824         -- and we do not want to zap the unbound tyvar 'a' to (), because
 825         -- that limits the applicability of the rule.  Instead, we
 826         -- want to quantify over it!
 827         --
 828         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 829         -- are tiresome, because (a) the data type is big and (b) finding the
 830         -- free type vars of an expression is necessarily monadic operation.
 831         --      (consider /\a -> f @ b, where b is side-effected to a)
 832     in
 833     zonkExpr env_lhs lhs                `thenM` \ new_lhs ->
 834     zonkExpr env_rhs rhs                `thenM` \ new_rhs ->
 835
 836     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 837     let
 838         final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
 839         -- I hate this map RuleBndr stuff
 840     in
 841     returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
 842   where
 843    zonk_bndr (RuleBndr v)
 844         | isId v    = zonkIdBndr env v
 845         | otherwise = zonkTcTyVarToTyVar v
 846
 847 zonkRule env (IfaceRuleOut fun rule)
 848   = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
 849 \end{code}
 850
 851
 852 %************************************************************************
 853 %*                                                                      *
 854 \subsection[BackSubst-Foreign]{Foreign exports}
 855 %*                                                                      *
 856 %************************************************************************
 857
 858 \begin{code}
 859 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 860 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 861
 862 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 863 -- This variant collects unbound type variables in a mutable variable
 864 zonkTypeCollecting unbound_tv_set
 865   = zonkType zonk_unbound_tyvar
 866   where
 867     zonk_unbound_tyvar tv
 868         = zonkTcTyVarToTyVar tv                                 `thenM` \ tv' ->
 869           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 870           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 871           return (mkTyVarTy tv')
 872
 873 zonkTypeZapping :: TcType -> TcM Type
 874 -- This variant is used for everything except the LHS of rules
 875 -- It zaps unbound type variables to (), or some other arbitrary type
 876 zonkTypeZapping ty
 877   = zonkType zonk_unbound_tyvar ty
 878   where
 879         -- Zonk a mutable but unbound type variable to an arbitrary type
 880         -- We know it's unbound even though we don't carry an environment,
 881         -- because at the binding site for a type variable we bind the
 882         -- mutable tyvar to a fresh immutable one.  So the mutable store
 883         -- plays the role of an environment.  If we come across a mutable
 884         -- type variable that isn't so bound, it must be completely free.
 885     zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
 886
 887
 888 -- When the type checker finds a type variable with no binding,
 889 -- which means it can be instantiated with an arbitrary type, it
 890 -- usually instantiates it to Void.  Eg.
 891 --
 892 --      length []
 893 -- ===>
 894 --      length Void (Nil Void)
 895 --
 896 -- But in really obscure programs, the type variable might have
 897 -- a kind other than *, so we need to invent a suitably-kinded type.
 898 --
 899 -- This commit uses
 900 --      Void for kind *
 901 --      List for kind *->*
 902 --      Tuple for kind *->...*->*
 903 --
 904 -- which deals with most cases.  (Previously, it only dealt with
 905 -- kind *.)
 906 --
 907 -- In the other cases, it just makes up a TyCon with a suitable
 908 -- kind.  If this gets into an interface file, anyone reading that
 909 -- file won't understand it.  This is fixable (by making the client
 910 -- of the interface file make up a TyCon too) but it is tiresome and
 911 -- never happens, so I am leaving it
 912
 913 mkArbitraryType :: TcTyVar -> Type
 914 -- Make up an arbitrary type whose kind is the same as the tyvar.
 915 -- We'll use this to instantiate the (unbound) tyvar.
 916 mkArbitraryType tv
 917   | isAnyTypeKind kind = voidTy         -- The vastly common case
 918   | otherwise          = mkTyConApp tycon []
 919   where
 920     kind       = tyVarKind tv
 921     (args,res) = Type.splitFunTys kind  -- Kinds are simple; use Type.splitFunTys
 922
 923     tycon | kind `eqKind` tyConKind listTyCon   -- *->*
 924           = listTyCon                           -- No tuples this size
 925
 926           | all isTypeKind args && isTypeKind res
 927           = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
 928
 929           | otherwise
 930           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
 931             mkPrimTyCon tc_name kind 0 [] VoidRep
 932                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
 933                 -- I dread to think what will happen if this gets out into an
 934                 -- interface file.  Catastrophe likely.  Major sigh.
 935
 936     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 937 \end{code}