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