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