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 (HsReify r) = returnM (HsReify r)  -- Nothing to zonk; only top
 512                                                 -- level things can be reified (for now)
 513 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e )   -- Should not happen
 514                                   returnM (HsSplice n e loc)
 515
 516 zonkExpr env (OpApp e1 op fixity e2)
 517   = zonkExpr env e1     `thenM` \ new_e1 ->
 518     zonkExpr env op     `thenM` \ new_op ->
 519     zonkExpr env e2     `thenM` \ new_e2 ->
 520     returnM (OpApp new_e1 new_op fixity new_e2)
 521
 522 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
 523
 524 zonkExpr env (HsPar e)
 525   = zonkExpr env e      `thenM` \new_e ->
 526     returnM (HsPar new_e)
 527
 528 zonkExpr env (SectionL expr op)
 529   = zonkExpr env expr   `thenM` \ new_expr ->
 530     zonkExpr env op             `thenM` \ new_op ->
 531     returnM (SectionL new_expr new_op)
 532
 533 zonkExpr env (SectionR op expr)
 534   = zonkExpr env op             `thenM` \ new_op ->
 535     zonkExpr env expr           `thenM` \ new_expr ->
 536     returnM (SectionR new_op new_expr)
 537
 538 zonkExpr env (HsCase expr ms src_loc)
 539   = zonkExpr env expr           `thenM` \ new_expr ->
 540     mappM (zonkMatch env) ms    `thenM` \ new_ms ->
 541     returnM (HsCase new_expr new_ms src_loc)
 542
 543 zonkExpr env (HsIf e1 e2 e3 src_loc)
 544   = zonkExpr env e1     `thenM` \ new_e1 ->
 545     zonkExpr env e2     `thenM` \ new_e2 ->
 546     zonkExpr env e3     `thenM` \ new_e3 ->
 547     returnM (HsIf new_e1 new_e2 new_e3 src_loc)
 548
 549 zonkExpr env (HsLet binds expr)
 550   = zonkBinds env binds         `thenM` \ (new_env, new_binds) ->
 551     zonkExpr new_env expr       `thenM` \ new_expr ->
 552     returnM (HsLet new_binds new_expr)
 553
 554 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
 555   = zonkStmts env stmts         `thenM` \ new_stmts ->
 556     zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 557     zonkReboundNames env ids    `thenM` \ new_ids ->
 558     returnM (HsDo do_or_lc new_stmts new_ids
 559                   new_ty src_loc)
 560
 561 zonkExpr env (ExplicitList ty exprs)
 562   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 563     zonkExprs env exprs         `thenM` \ new_exprs ->
 564     returnM (ExplicitList new_ty new_exprs)
 565
 566 zonkExpr env (ExplicitPArr ty exprs)
 567   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 568     zonkExprs env exprs         `thenM` \ new_exprs ->
 569     returnM (ExplicitPArr new_ty new_exprs)
 570
 571 zonkExpr env (ExplicitTuple exprs boxed)
 572   = zonkExprs env exprs         `thenM` \ new_exprs ->
 573     returnM (ExplicitTuple new_exprs boxed)
 574
 575 zonkExpr env (RecordConOut data_con con_expr rbinds)
 576   = zonkExpr env con_expr       `thenM` \ new_con_expr ->
 577     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 578     returnM (RecordConOut data_con new_con_expr new_rbinds)
 579
 580 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
 581
 582 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
 583   = zonkExpr env expr           `thenM` \ new_expr ->
 584     zonkTcTypeToType env in_ty  `thenM` \ new_in_ty ->
 585     zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
 586     zonkRbinds env rbinds       `thenM` \ new_rbinds ->
 587     returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 588
 589 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 590 zonkExpr env (ArithSeqIn _)      = panic "zonkExpr env:ArithSeqIn"
 591 zonkExpr env (PArrSeqIn _)       = panic "zonkExpr env:PArrSeqIn"
 592
 593 zonkExpr env (ArithSeqOut expr info)
 594   = zonkExpr env expr           `thenM` \ new_expr ->
 595     zonkArithSeq env info       `thenM` \ new_info ->
 596     returnM (ArithSeqOut new_expr new_info)
 597
 598 zonkExpr env (PArrSeqOut expr info)
 599   = zonkExpr env expr           `thenM` \ new_expr ->
 600     zonkArithSeq env info       `thenM` \ new_info ->
 601     returnM (PArrSeqOut new_expr new_info)
 602
 603 zonkExpr env (HsSCC lbl expr)
 604   = zonkExpr env expr   `thenM` \ new_expr ->
 605     returnM (HsSCC lbl new_expr)
 606
 607 -- hdaume: core annotations
 608 zonkExpr env (HsCoreAnn lbl expr)
 609   = zonkExpr env expr   `thenM` \ new_expr ->
 610     returnM (HsCoreAnn lbl new_expr)
 611
 612 zonkExpr env (TyLam tyvars expr)
 613   = mappM zonkTcTyVarToTyVar tyvars     `thenM` \ new_tyvars ->
 614         -- No need to extend tyvar env; see AbsBinds
 615
 616     zonkExpr env expr                   `thenM` \ new_expr ->
 617     returnM (TyLam new_tyvars new_expr)
 618
 619 zonkExpr env (TyApp expr tys)
 620   = zonkExpr env expr                   `thenM` \ new_expr ->
 621     mappM (zonkTcTypeToType env) tys    `thenM` \ new_tys ->
 622     returnM (TyApp new_expr new_tys)
 623
 624 zonkExpr env (DictLam dicts expr)
 625   = zonkIdBndrs env dicts       `thenM` \ new_dicts ->
 626     let
 627         env1 = extendZonkEnv env new_dicts
 628     in
 629     zonkExpr env1 expr          `thenM` \ new_expr ->
 630     returnM (DictLam new_dicts new_expr)
 631
 632 zonkExpr env (DictApp expr dicts)
 633   = zonkExpr env expr                   `thenM` \ new_expr ->
 634     returnM (DictApp new_expr (zonkIdOccs env dicts))
 635
 636 -- arrow notation extensions
 637 zonkExpr env (HsProc pat body src_loc)
 638   = zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 639     let
 640         env1 = extendZonkEnv env (bagToList new_ids)
 641     in
 642     zonkCmdTop env1 body                `thenM` \ new_body ->
 643     returnM (HsProc new_pat new_body src_loc)
 644
 645 zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
 646   = zonkExpr env e1                     `thenM` \ new_e1 ->
 647     zonkExpr env e2                     `thenM` \ new_e2 ->
 648     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 649     returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
 650
 651 zonkExpr env (HsArrForm op fixity args src_loc)
 652   = zonkExpr env op                     `thenM` \ new_op ->
 653     mappM (zonkCmdTop env) args         `thenM` \ new_args ->
 654     returnM (HsArrForm new_op fixity new_args src_loc)
 655
 656 zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
 657 zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
 658   = zonkExpr env cmd                    `thenM` \ new_cmd ->
 659     mappM (zonkTcTypeToType env) stack_tys
 660                                         `thenM` \ new_stack_tys ->
 661     zonkTcTypeToType env ty             `thenM` \ new_ty ->
 662     zonkReboundNames env ids            `thenM` \ new_ids ->
 663     returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
 664
 665 -------------------------------------------------------------------------
 666 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
 667 zonkReboundNames env prs
 668   = mapM zonk prs
 669   where
 670     zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
 671                   returnM (n, new_e)
 672
 673
 674 -------------------------------------------------------------------------
 675 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
 676
 677 zonkArithSeq env (From e)
 678   = zonkExpr env e              `thenM` \ new_e ->
 679     returnM (From new_e)
 680
 681 zonkArithSeq env (FromThen e1 e2)
 682   = zonkExpr env e1     `thenM` \ new_e1 ->
 683     zonkExpr env e2     `thenM` \ new_e2 ->
 684     returnM (FromThen new_e1 new_e2)
 685
 686 zonkArithSeq env (FromTo e1 e2)
 687   = zonkExpr env e1     `thenM` \ new_e1 ->
 688     zonkExpr env e2     `thenM` \ new_e2 ->
 689     returnM (FromTo new_e1 new_e2)
 690
 691 zonkArithSeq env (FromThenTo e1 e2 e3)
 692   = zonkExpr env e1     `thenM` \ new_e1 ->
 693     zonkExpr env e2     `thenM` \ new_e2 ->
 694     zonkExpr env e3     `thenM` \ new_e3 ->
 695     returnM (FromThenTo new_e1 new_e2 new_e3)
 696
 697
 698 -------------------------------------------------------------------------
 699 zonkStmts  :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
 700
 701 zonkStmts env stmts = zonk_stmts env stmts      `thenM` \ (_, stmts) ->
 702                       returnM stmts
 703
 704 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
 705
 706 zonk_stmts env [] = returnM (env, [])
 707
 708 zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
 709   = mappM zonk_branch stmts_w_bndrs     `thenM` \ new_stmts_w_bndrs ->
 710     let
 711         new_binders = concat (map snd new_stmts_w_bndrs)
 712         env1 = extendZonkEnv env new_binders
 713     in
 714     zonk_stmts env1 stmts               `thenM` \ (env2, new_stmts) ->
 715     returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
 716   where
 717     zonk_branch (stmts, bndrs) = zonk_stmts env stmts   `thenM` \ (env1, new_stmts) ->
 718                                  returnM (new_stmts, zonkIdOccs env1 bndrs)
 719
 720 zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
 721   = zonkIdBndrs env rvs         `thenM` \ new_rvs ->
 722     let
 723         env1 = extendZonkEnv env new_rvs
 724     in
 725     zonk_stmts env1 segStmts    `thenM` \ (env2, new_segStmts) ->
 726         -- Zonk the ret-expressions in an envt that
 727         -- has the polymorphic bindings in the envt
 728     zonkExprs env2 rets         `thenM` \ new_rets ->
 729     let
 730         new_lvs = zonkIdOccs env2 lvs
 731         env3 = extendZonkEnv env new_lvs        -- Only the lvs are needed
 732     in
 733     zonk_stmts env3 stmts       `thenM` \ (env4, new_stmts) ->
 734     returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
 735
 736 zonk_stmts env (ResultStmt expr locn : stmts)
 737   = ASSERT( null stmts )
 738     zonkExpr env expr   `thenM` \ new_expr ->
 739     returnM (env, [ResultStmt new_expr locn])
 740
 741 zonk_stmts env (ExprStmt expr ty locn : stmts)
 742   = zonkExpr env expr           `thenM` \ new_expr ->
 743     zonkTcTypeToType env ty     `thenM` \ new_ty ->
 744     zonk_stmts env stmts        `thenM` \ (env1, new_stmts) ->
 745     returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
 746
 747 zonk_stmts env (LetStmt binds : stmts)
 748   = zonkBinds env binds         `thenM` \ (env1, new_binds) ->
 749     zonk_stmts env1 stmts       `thenM` \ (env2, new_stmts) ->
 750     returnM (env2, LetStmt new_binds : new_stmts)
 751
 752 zonk_stmts env (BindStmt pat expr locn : stmts)
 753   = zonkExpr env expr                   `thenM` \ new_expr ->
 754     zonkPat env pat                     `thenM` \ (new_pat, new_ids) ->
 755     let
 756         env1 = extendZonkEnv env (bagToList new_ids)
 757     in
 758     zonk_stmts env1 stmts               `thenM` \ (env2, new_stmts) ->
 759     returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
 760
 761
 762
 763 -------------------------------------------------------------------------
 764 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
 765
 766 zonkRbinds env rbinds
 767   = mappM zonk_rbind rbinds
 768   where
 769     zonk_rbind (field, expr)
 770       = zonkExpr env expr       `thenM` \ new_expr ->
 771         returnM (zonkIdOcc env field, new_expr)
 772
 773 -------------------------------------------------------------------------
 774 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
 775 mapIPNameTc f (Dupable n) = f n  `thenM` \ r -> returnM (Dupable r)
 776 mapIPNameTc f (Linear  n) = f n  `thenM` \ r -> returnM (Linear r)
 777 \end{code}
 778
 779
 780 %************************************************************************
 781 %*                                                                      *
 782 \subsection[BackSubst-Pats]{Patterns}
 783 %*                                                                      *
 784 %************************************************************************
 785
 786 \begin{code}
 787 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
 788
 789 zonkPat env (ParPat p)
 790   = zonkPat env p       `thenM` \ (new_p, ids) ->
 791     returnM (ParPat new_p, ids)
 792
 793 zonkPat env (WildPat ty)
 794   = zonkTcTypeToType env ty   `thenM` \ new_ty ->
 795     returnM (WildPat new_ty, emptyBag)
 796
 797 zonkPat env (VarPat v)
 798   = zonkIdBndr env v        `thenM` \ new_v ->
 799     returnM (VarPat new_v, unitBag new_v)
 800
 801 zonkPat env (LazyPat pat)
 802   = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 803     returnM (LazyPat new_pat, ids)
 804
 805 zonkPat env (AsPat n pat)
 806   = zonkIdBndr env n        `thenM` \ new_n ->
 807     zonkPat env pat         `thenM` \ (new_pat, ids) ->
 808     returnM (AsPat new_n new_pat, new_n `consBag` ids)
 809
 810 zonkPat env (ListPat pats ty)
 811   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 812     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 813     returnM (ListPat new_pats new_ty, ids)
 814
 815 zonkPat env (PArrPat pats ty)
 816   = zonkTcTypeToType env ty     `thenM` \ new_ty ->
 817     zonkPats env pats           `thenM` \ (new_pats, ids) ->
 818     returnM (PArrPat new_pats new_ty, ids)
 819
 820 zonkPat env (TuplePat pats boxed)
 821   = zonkPats env pats                   `thenM` \ (new_pats, ids) ->
 822     returnM (TuplePat new_pats boxed, ids)
 823
 824 zonkPat env (ConPatOut n stuff ty tvs dicts)
 825   = zonkTcTypeToType env ty             `thenM` \ new_ty ->
 826     mappM zonkTcTyVarToTyVar tvs        `thenM` \ new_tvs ->
 827     zonkIdBndrs env dicts               `thenM` \ new_dicts ->
 828     let
 829         env1 = extendZonkEnv env new_dicts
 830     in
 831     zonkConStuff env1 stuff             `thenM` \ (new_stuff, ids) ->
 832     returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
 833                  listToBag new_dicts `unionBags` ids)
 834
 835 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
 836
 837 zonkPat env (SigPatOut pat ty expr)
 838   = zonkPat env pat             `thenM` \ (new_pat, ids) ->
 839     zonkTcTypeToType env ty     `thenM` \ new_ty  ->
 840     zonkExpr env expr           `thenM` \ new_expr ->
 841     returnM (SigPatOut new_pat new_ty new_expr, ids)
 842
 843 zonkPat env (NPatOut lit ty expr)
 844   = zonkTcTypeToType env ty     `thenM` \ new_ty   ->
 845     zonkExpr env expr           `thenM` \ new_expr ->
 846     returnM (NPatOut lit new_ty new_expr, emptyBag)
 847
 848 zonkPat env (NPlusKPatOut n k e1 e2)
 849   = zonkIdBndr env n            `thenM` \ new_n ->
 850     zonkExpr env e1                     `thenM` \ new_e1 ->
 851     zonkExpr env e2                     `thenM` \ new_e2 ->
 852     returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
 853
 854 zonkPat env (DictPat ds ms)
 855   = zonkIdBndrs env ds      `thenM` \ new_ds ->
 856     zonkIdBndrs env ms     `thenM` \ new_ms ->
 857     returnM (DictPat new_ds new_ms,
 858                  listToBag new_ds `unionBags` listToBag new_ms)
 859
 860 ---------------------------
 861 zonkConStuff env (PrefixCon pats)
 862   = zonkPats env pats           `thenM` \ (new_pats, ids) ->
 863     returnM (PrefixCon new_pats, ids)
 864
 865 zonkConStuff env (InfixCon p1 p2)
 866   = zonkPat env p1              `thenM` \ (new_p1, ids1) ->
 867     zonkPat env p2              `thenM` \ (new_p2, ids2) ->
 868     returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
 869
 870 zonkConStuff env (RecCon rpats)
 871   = mapAndUnzipM zonk_rpat rpats        `thenM` \ (new_rpats, ids_s) ->
 872     returnM (RecCon new_rpats, unionManyBags ids_s)
 873   where
 874     zonk_rpat (f, pat)
 875       = zonkPat env pat         `thenM` \ (new_pat, ids) ->
 876         returnM ((f, new_pat), ids)
 877
 878 ---------------------------
 879 zonkPats env []
 880   = returnM ([], emptyBag)
 881
 882 zonkPats env (pat:pats)
 883   = zonkPat env pat     `thenM` \ (pat',  ids1) ->
 884     zonkPats env pats   `thenM` \ (pats', ids2) ->
 885     returnM (pat':pats', ids1 `unionBags` ids2)
 886 \end{code}
 887
 888 %************************************************************************
 889 %*                                                                      *
 890 \subsection[BackSubst-Foreign]{Foreign exports}
 891 %*                                                                      *
 892 %************************************************************************
 893
 894
 895 \begin{code}
 896 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
 897 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
 898
 899 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
 900 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
 901    returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
 902 zonkForeignExport env for_imp
 903   = returnM for_imp     -- Foreign imports don't need zonking
 904 \end{code}
 905
 906 \begin{code}
 907 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
 908 zonkRules env rs = mappM (zonkRule env) rs
 909
 910 zonkRule env (HsRule name act vars lhs rhs loc)
 911   = mappM zonk_bndr vars                `thenM` \ new_bndrs ->
 912     newMutVar emptyVarSet               `thenM` \ unbound_tv_set ->
 913     let
 914         env_rhs = extendZonkEnv env (filter isId new_bndrs)
 915         -- Type variables don't need an envt
 916         -- They are bound through the mutable mechanism
 917
 918         env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 919         -- We need to gather the type variables mentioned on the LHS so we can
 920         -- quantify over them.  Example:
 921         --   data T a = C
 922         --
 923         --   foo :: T a -> Int
 924         --   foo C = 1
 925         --
 926         --   {-# RULES "myrule"  foo C = 1 #-}
 927         --
 928         -- After type checking the LHS becomes (foo a (C a))
 929         -- and we do not want to zap the unbound tyvar 'a' to (), because
 930         -- that limits the applicability of the rule.  Instead, we
 931         -- want to quantify over it!
 932         --
 933         -- It's easiest to find the free tyvars here. Attempts to do so earlier
 934         -- are tiresome, because (a) the data type is big and (b) finding the
 935         -- free type vars of an expression is necessarily monadic operation.
 936         --      (consider /\a -> f @ b, where b is side-effected to a)
 937     in
 938     zonkExpr env_lhs lhs                `thenM` \ new_lhs ->
 939     zonkExpr env_rhs rhs                `thenM` \ new_rhs ->
 940
 941     readMutVar unbound_tv_set           `thenM` \ unbound_tvs ->
 942     let
 943         final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
 944         -- I hate this map RuleBndr stuff
 945     in
 946     returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
 947   where
 948    zonk_bndr (RuleBndr v)
 949         | isId v    = zonkIdBndr env v
 950         | otherwise = zonkTcTyVarToTyVar v
 951 \end{code}
 952
 953
 954 %************************************************************************
 955 %*                                                                      *
 956 \subsection[BackSubst-Foreign]{Foreign exports}
 957 %*                                                                      *
 958 %************************************************************************
 959
 960 \begin{code}
 961 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 962 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
 963
 964 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 965 -- This variant collects unbound type variables in a mutable variable
 966 zonkTypeCollecting unbound_tv_set
 967   = zonkType zonk_unbound_tyvar
 968   where
 969     zonk_unbound_tyvar tv
 970         = zonkTcTyVarToTyVar tv                                 `thenM` \ tv' ->
 971           readMutVar unbound_tv_set                             `thenM` \ tv_set ->
 972           writeMutVar unbound_tv_set (extendVarSet tv_set tv')  `thenM_`
 973           return (mkTyVarTy tv')
 974
 975 zonkTypeZapping :: TcType -> TcM Type
 976 -- This variant is used for everything except the LHS of rules
 977 -- It zaps unbound type variables to (), or some other arbitrary type
 978 zonkTypeZapping ty
 979   = zonkType zonk_unbound_tyvar ty
 980   where
 981         -- Zonk a mutable but unbound type variable to an arbitrary type
 982         -- We know it's unbound even though we don't carry an environment,
 983         -- because at the binding site for a type variable we bind the
 984         -- mutable tyvar to a fresh immutable one.  So the mutable store
 985         -- plays the role of an environment.  If we come across a mutable
 986         -- type variable that isn't so bound, it must be completely free.
 987     zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
 988
 989
 990 -- When the type checker finds a type variable with no binding,
 991 -- which means it can be instantiated with an arbitrary type, it
 992 -- usually instantiates it to Void.  Eg.
 993 --
 994 --      length []
 995 -- ===>
 996 --      length Void (Nil Void)
 997 --
 998 -- But in really obscure programs, the type variable might have
 999 -- a kind other than *, so we need to invent a suitably-kinded type.
1000 --
1001 -- This commit uses
1002 --      Void for kind *
1003 --      List for kind *->*
1004 --      Tuple for kind *->...*->*
1005 --
1006 -- which deals with most cases.  (Previously, it only dealt with
1007 -- kind *.)
1008 --
1009 -- In the other cases, it just makes up a TyCon with a suitable
1010 -- kind.  If this gets into an interface file, anyone reading that
1011 -- file won't understand it.  This is fixable (by making the client
1012 -- of the interface file make up a TyCon too) but it is tiresome and
1013 -- never happens, so I am leaving it
1014
1015 mkArbitraryType :: TcTyVar -> Type
1016 -- Make up an arbitrary type whose kind is the same as the tyvar.
1017 -- We'll use this to instantiate the (unbound) tyvar.
1018 mkArbitraryType tv
1019   | isAnyTypeKind kind = voidTy         -- The vastly common case
1020   | otherwise          = mkTyConApp tycon []
1021   where
1022     kind       = tyVarKind tv
1023     (args,res) = Type.splitFunTys kind  -- Kinds are simple; use Type.splitFunTys
1024
1025     tycon | kind `eqKind` tyConKind listTyCon   -- *->*
1026           = listTyCon                           -- No tuples this size
1027
1028           | all isTypeKind args && isTypeKind res
1029           = tupleTyCon Boxed (length args)      -- *-> ... ->*->*
1030
1031           | otherwise
1032           = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
1033             mkPrimTyCon tc_name kind 0 [] VoidRep
1034                 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1035                 -- I dread to think what will happen if this gets out into an
1036                 -- interface file.  Catastrophe likely.  Major sigh.
1037
1038     tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
1039 \end{code}