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 -------------------------------------------------------------------------
 618 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
 619
 620 zonkStmts env [] = returnM []
 621
 622 zonkStmts env (ParStmtOut bndrstmtss : stmts)
 623   = mappM (mappM zonkId) bndrss         `thenM` \ new_bndrss ->
 624     mappM (zonkStmts env) stmtss        `thenM` \ new_stmtss ->
 625     let
 626         new_binders = concat new_bndrss
 627         env1 = extendZonkEnv env new_binders
 628     in
 629     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 630     returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
 631   where
 632     (bndrss, stmtss) = unzip bndrstmtss
 633
 634 zonkStmts env (RecStmt vs segStmts : stmts)
 635   = mappM zonkId vs             `thenM` \ new_vs ->
 636     let
 637         env1 = extendZonkEnv env new_vs
 638     in
 639     zonkStmts env1 segStmts     `thenM` \ new_segStmts ->
 640     zonkStmts env1 stmts        `thenM` \ new_stmts ->
 641     returnM (RecStmt new_vs new_segStmts : new_stmts)
 642
 643 zonkStmts env (ResultStmt expr locn : stmts)
 644   = zonkExpr env expr   `thenM` \ new_expr ->
 645     zonkStmts env stmts `thenM` \ new_stmts ->
 646     returnM (ResultStmt new_expr locn : new_stmts)
 647
 648 zonkStmts env (ExprStmt expr ty locn : stmts)
 649   = zonkExpr env expr           `thenM` \ new_expr ->
 650     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 651     zonkStmts env stmts         `thenM` \ new_stmts ->
 652     returnM (ExprStmt new_expr new_ty locn : new_stmts)
 653
 654 zonkStmts env (LetStmt binds : stmts)
 655   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 656     zonkStmts new_env stmts     `thenM` \ new_stmts ->
 657     returnM (LetStmt new_binds : new_stmts)
 658
 659 zonkStmts env (BindStmt pat expr locn : stmts)
 660   = zonkExpr env expr                   `thenM` \ new_expr ->
 661     zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 662     let
 663         env1 = extendZonkEnv env (bagToList new_ids)
 664     in
 665     zonkStmts env1 stmts                `thenM` \ new_stmts ->
 666     returnM (BindStmt new_pat new_expr locn : new_stmts)
 667
 668
 669
 670 -------------------------------------------------------------------------
 671 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
 672
 673 zonkRbinds env rbinds
 674   = mappM zonk_rbind rbinds
 675   where
 676     zonk_rbind (field, expr)
 677       = zonkExpr env expr       `thenM` \ new_expr ->
 678         returnM (zonkIdOcc env field, new_expr)
 679
 680 -------------------------------------------------------------------------
 681 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 682 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 683 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 684 \end{code}
 685
 686
 687 %************************************************************************
 688 %*                                                                      *
 689 \subsection[BackSubst-Pats]{Patterns}
 690 %*                                                                      *
 691 %************************************************************************
 692
 693 \begin{code}
 694 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
 695
 696 zonkPat env (ParPat p)
 697   = zonkPat env p       `thenM` \ (new_p, ids) ->
 698     returnM (ParPat new_p, ids)
 699
 700 zonkPat env (WildPat ty)
 701   = zonkTcTypeToType env ty   `thenM` \ new_ty ->
 702     returnM (WildPat new_ty, emptyBag)
 703
 704 zonkPat env (VarPat v)
 705   = zonkIdBndr env v        `thenM` \ new_v ->
 706     returnM (VarPat new_v, unitBag new_v)
 707
 708 zonkPat env (LazyPat pat)
 709   = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 710     returnM (LazyPat new_pat, ids)
 711
 712 zonkPat env (AsPat n pat)
 713   = zonkIdBndr env n        `thenM` \ new_n ->
 714     zonkPat env pat         `thenM` \ (new_pat, ids) ->
 715     returnM (AsPat new_n new_pat, new_n `consBag` ids)
 716
 717 zonkPat env (ListPat pats ty)
 718   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 719     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 720     returnM (ListPat new_pats new_ty, ids)
 721
 722 zonkPat env (PArrPat pats ty)
 723   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 724     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 725     returnM (PArrPat new_pats new_ty, ids)
 726
 727 zonkPat env (TuplePat pats boxed)
 728   = zonkPats env pats                   `thenM` \ (new_pats, ids) ->
 729     returnM (TuplePat new_pats boxed, ids)
 730
 731 zonkPat env (ConPatOut n stuff ty tvs dicts)
 732   = zonkTcTypeToType env ty             `thenM` \ new_ty ->
 733     mappM zonkTcTyVarToTyVar tvs        `thenM` \ new_tvs ->
 734     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 735     let
 736         env1 = extendZonkEnv env new_dicts
 737     in
 738     zonkConStuff env stuff              `thenM` \ (new_stuff, ids) ->
 739     returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
 740                  listToBag new_dicts `unionBags` ids)
 741
 742 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
 743
 744 zonkPat env (SigPatOut pat ty expr)
 745   = zonkPat env pat             `thenM` \ (new_pat, ids) ->
 746     zonkTcTypeToType env ty     `thenM` \ new_ty  ->
 747     zonkExpr env expr           `thenM` \ new_expr ->
 748     returnM (SigPatOut new_pat new_ty new_expr, ids)
 749
 750 zonkPat env (NPatOut lit ty expr)
 751   = zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 752     zonkExpr env expr           `thenM` \ new_expr ->
 753     returnM (NPatOut lit new_ty new_expr, emptyBag)
 754
 755 zonkPat env (NPlusKPatOut n k e1 e2)
 756   = zonkIdBndr env n            `thenM` \ new_n ->
 757     zonkExpr env e1                     `thenM` \ new_e1 ->
 758     zonkExpr env e2                     `thenM` \ new_e2 ->
 759     returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
 760
 761 zonkPat env (DictPat ds ms)
 762   = zonkIdBndrs env ds      `thenM` \ new_ds ->
 763     zonkIdBndrs env ms     `thenM` \ new_ms ->
 764     returnM (DictPat new_ds new_ms,
 765                  listToBag new_ds `unionBags` listToBag new_ms)
 766
 767 ---------------------------
 768 zonkConStuff env (PrefixCon pats)
 769   = zonkPats env pats           `thenM` \ (new_pats, ids) ->
 770     returnM (PrefixCon new_pats, ids)
 771
 772 zonkConStuff env (InfixCon p1 p2)
 773   = zonkPat env p1              `thenM` \ (new_p1, ids1) ->
 774     zonkPat env p2              `thenM` \ (new_p2, ids2) ->
 775     returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
 776
 777 zonkConStuff env (RecCon rpats)
 778   = mapAndUnzipM zonk_rpat rpats        `thenM` \ (new_rpats, ids_s) ->
 779     returnM (RecCon new_rpats, unionManyBags ids_s)
 780   where
 781     zonk_rpat (f, pat)
 782       = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 783         returnM ((f, new_pat), ids)
 784
 785 ---------------------------
 786 zonkPats env []
 787   = returnM ([], emptyBag)
 788
 789 zonkPats env (pat:pats)
 790   = zonkPat env pat     `thenM` \ (pat',  ids1) ->
 791     zonkPats env pats   `thenM` \ (pats', ids2) ->
 792     returnM (pat':pats', ids1 `unionBags` ids2)
 793 \end{code}
 794
 795 %************************************************************************
 796 %*                                                                      *
 797 \subsection[BackSubst-Foreign]{Foreign exports}
 798 %*                                                                      *
 799 %************************************************************************
 800
 801
 802 \begin{code}
 803 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
 804 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 805
 806 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 807 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
 808    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
 809 \end{code}
 810
 811 \begin{code}
 812 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
 813 zonkRules env rs = mappM (zonkRule env) rs
 814
 815 zonkRule env (HsRule name act vars lhs rhs loc)
 816   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 817     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 818     let
 819         env_rhs = extendZonkEnv env (filter isId new_bndrs)
 820         -- Type variables don't need an envt
 821         -- They are bound through the mutable mechanism
 822
 823         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 824         -- We need to gather the type variables mentioned on the LHS so we can
 825         -- quantify over them.  Example:
 826         --   data T a = C
 827         --
 828         --   foo :: T a -> Int
 829         --   foo C = 1
 830         --
 831         --   {-# RULES "myrule"  foo C = 1 #-}
 832         --
 833         -- After type checking the LHS becomes (foo a (C a))
 834         -- and we do not want to zap the unbound tyvar 'a' to (), because
 835         -- that limits the applicability of the rule.  Instead, we
 836         -- want to quantify over it!
 837         --
 838         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 839         -- are tiresome, because (a) the data type is big and (b) finding the
 840         -- free type vars of an expression is necessarily monadic operation.
 841         --      (consider /\a -> f @ b, where b is side-effected to a)
 842     in
 843     zonkExpr env_lhs lhs                `thenM` \ new_lhs ->
 844     zonkExpr env_rhs rhs                `thenM` \ new_rhs ->
 845
 846     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 847     let
 848         final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
 849         -- I hate this map RuleBndr stuff
 850     in
 851     returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
 852   where
 853    zonk_bndr (RuleBndr v)
 854         | isId v    = zonkIdBndr env v
 855         | otherwise = zonkTcTyVarToTyVar v
 856
 857 zonkRule env (IfaceRuleOut fun rule)
 858   = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
 859 \end{code}
 860
 861
 862 %************************************************************************
 863 %*                                                                      *
 864 \subsection[BackSubst-Foreign]{Foreign exports}
 865 %*                                                                      *
 866 %************************************************************************
 867
 868 \begin{code}
 869 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 870 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 871
 872 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 873 -- This variant collects unbound type variables in a mutable variable
 874 zonkTypeCollecting unbound_tv_set
 875   = zonkType zonk_unbound_tyvar
 876   where
 877     zonk_unbound_tyvar tv
 878         = zonkTcTyVarToTyVar tv                                 `thenM` \ tv' ->
 879           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 880           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 881           return (mkTyVarTy tv')
 882
 883 zonkTypeZapping :: TcType -> TcM Type
 884 -- This variant is used for everything except the LHS of rules
 885 -- It zaps unbound type variables to (), or some other arbitrary type
 886 zonkTypeZapping ty
 887   = zonkType zonk_unbound_tyvar ty
 888   where
 889         -- Zonk a mutable but unbound type variable to an arbitrary type
 890         -- We know it's unbound even though we don't carry an environment,
 891         -- because at the binding site for a type variable we bind the
 892         -- mutable tyvar to a fresh immutable one.  So the mutable store
 893         -- plays the role of an environment.  If we come across a mutable
 894         -- type variable that isn't so bound, it must be completely free.
 895     zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
 896
 897
 898 -- When the type checker finds a type variable with no binding,
 899 -- which means it can be instantiated with an arbitrary type, it
 900 -- usually instantiates it to Void.  Eg.
 901 --
 902 --      length []
 903 -- ===>
 904 --      length Void (Nil Void)
 905 --
 906 -- But in really obscure programs, the type variable might have
 907 -- a kind other than *, so we need to invent a suitably-kinded type.
 908 --
 909 -- This commit uses
 910 --      Void for kind *
 911 --      List for kind *->*
 912 --      Tuple for kind *->...*->*
 913 --
 914 -- which deals with most cases.  (Previously, it only dealt with
 915 -- kind *.)
 916 --
 917 -- In the other cases, it just makes up a TyCon with a suitable
 918 -- kind.  If this gets into an interface file, anyone reading that
 919 -- file won't understand it.  This is fixable (by making the client
 920 -- of the interface file make up a TyCon too) but it is tiresome and
 921 -- never happens, so I am leaving it
 922
 923 mkArbitraryType :: TcTyVar -> Type
 924 -- Make up an arbitrary type whose kind is the same as the tyvar.
 925 -- We'll use this to instantiate the (unbound) tyvar.
 926 mkArbitraryType tv
 927   | isAnyTypeKind kind = voidTy         -- The vastly common case
 928   | otherwise          = mkTyConApp tycon []
 929   where
 930     kind       = tyVarKind tv
 931     (args,res) = Type.splitFunTys kind  -- Kinds are simple; use Type.splitFunTys
 932
 933     tycon | kind `eqKind` tyConKind listTyCon   -- *->*
 934           = listTyCon                           -- No tuples this size
 935
 936           | all isTypeKind args && isTypeKind res
 937           = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
 938
 939           | otherwise
 940           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
 941             mkPrimTyCon tc_name kind 0 [] VoidRep
 942                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
 943                 -- I dread to think what will happen if this gets out into an
 944                 -- interface file.  Catastrophe likely.  Major sigh.
 945
 946     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
 947 \end{code}