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