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