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