Commit 7f79d0c7 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactoring around super-kinds

And in particular we now have BOX :: BOX
See Note [SuperKind (BOX)] in TysPrim
parent 95d2e12c
...@@ -53,6 +53,7 @@ module DataCon ( ...@@ -53,6 +53,7 @@ module DataCon (
import Type import Type
import TypeRep( Type(..) ) -- Used in promoteType import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import Kind import Kind
import Unify import Unify
import Coercion import Coercion
...@@ -983,7 +984,7 @@ These two 'buildPromoted..' functions are here because ...@@ -983,7 +984,7 @@ These two 'buildPromoted..' functions are here because
\begin{code} \begin{code}
buildPromotedTyCon :: TyCon -> TyCon buildPromotedTyCon :: TyCon -> TyCon
buildPromotedTyCon tc buildPromotedTyCon tc
= mkPromotedTyCon tc tySuperKind = mkPromotedTyCon tc (promoteKind (tyConKind tc))
buildPromotedDataCon :: DataCon -> TyCon buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc buildPromotedDataCon dc
...@@ -1040,7 +1041,7 @@ promoteType ty ...@@ -1040,7 +1041,7 @@ promoteType ty
= mkForAllTys kvs (go rho) = mkForAllTys kvs (go rho)
where where
(tvs, rho) = splitForAllTys ty (tvs, rho) = splitForAllTys ty
kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
...@@ -1048,4 +1049,12 @@ promoteType ty ...@@ -1048,4 +1049,12 @@ promoteType ty
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv = TyVarTy kv
go _ = panic "promoteType" -- Argument did not satisfy isPromotableType go _ = panic "promoteType" -- Argument did not satisfy isPromotableType
promoteKind :: Kind -> SuperKind
-- Promote the kind of a type constructor
-- from (* -> * -> *) to (BOX -> BOX -> BOX)
promoteKind (TyConApp tc [])
| tc `hasKey` liftedTypeKindTyConKey = superKind
promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res)
promoteKind k = pprPanic "promoteKind" (ppr k)
\end{code} \end{code}
...@@ -329,7 +329,7 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details } ...@@ -329,7 +329,7 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details }
mkKindVar :: Name -> SuperKind -> KindVar mkKindVar :: Name -> SuperKind -> KindVar
-- mkKindVar take a SuperKind as argument because we don't have access -- mkKindVar take a SuperKind as argument because we don't have access
-- to tySuperKind here. -- to superKind here.
mkKindVar name kind = TyVar mkKindVar name kind = TyVar
{ varName = name { varName = name
, realUnique = getKeyFastInt (nameUnique name) , realUnique = getKeyFastInt (nameUnique name)
......
...@@ -416,7 +416,7 @@ varTypeTcTyVars :: Var -> TyVarSet ...@@ -416,7 +416,7 @@ varTypeTcTyVars :: Var -> TyVarSet
-- Find the type variables free in the type of the variable -- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables... -- Remember, coercion variables can mention type variables...
varTypeTcTyVars var varTypeTcTyVars var
| isLocalId var = tcTyVarsOfType (idType var) | isLocalId var = tyVarsOfType (idType var)
| otherwise = emptyVarSet -- Global Ids and non-coercion TyVars | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
idFreeVars :: Id -> VarSet idFreeVars :: Id -> VarSet
......
...@@ -732,7 +732,7 @@ dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg] ...@@ -732,7 +732,7 @@ dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
--------------------------------------- ---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- This is the crucial function that moves -- This is the crucial function that moves
-- from LCoercions to Coercions; see Note [TcCoercions] in Coercion -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k -- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# -> -- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# -> -- case g2 of EqBox g2# ->
......
...@@ -123,7 +123,7 @@ ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName ...@@ -123,7 +123,7 @@ ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName
ifaceTyConName IfaceSuperKindTc = tySuperKindTyConName ifaceTyConName IfaceSuperKindTc = superKindTyConName
ifaceTyConName (IfaceTc ext) = ext ifaceTyConName (IfaceTc ext) = ext
ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n) ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n)
-- Note [The Name of an IfaceAnyTc] -- Note [The Name of an IfaceAnyTc]
...@@ -399,7 +399,7 @@ toIfaceWiredInTyCon tc nm ...@@ -399,7 +399,7 @@ toIfaceWiredInTyCon tc nm
| nm == argTypeKindTyConName = IfaceArgTypeKindTc | nm == argTypeKindTyConName = IfaceArgTypeKindTc
| nm == constraintKindTyConName = IfaceConstraintKindTc | nm == constraintKindTyConName = IfaceConstraintKindTc
| nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc
| nm == tySuperKindTyConName = IfaceSuperKindTc | nm == superKindTyConName = IfaceSuperKindTc
| otherwise = IfaceTc nm | otherwise = IfaceTc nm
---------------- ----------------
......
...@@ -41,7 +41,7 @@ import TyCon ...@@ -41,7 +41,7 @@ import TyCon
import DataCon import DataCon
import PrelNames import PrelNames
import TysWiredIn import TysWiredIn
import TysPrim ( tySuperKindTyCon ) import TysPrim ( superKindTyCon )
import BasicTypes ( Arity, strongLoopBreaker ) import BasicTypes ( Arity, strongLoopBreaker )
import Literal import Literal
import qualified Var import qualified Var
...@@ -1302,7 +1302,7 @@ tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon ...@@ -1302,7 +1302,7 @@ tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon
tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon
tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon
tcIfaceTyCon IfaceSuperKindTc = return tySuperKindTyCon tcIfaceTyCon IfaceSuperKindTc = return superKindTyCon
-- Even though we are in an interface file, we want to make -- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded -- sure the instances and RULES of this tycon are loaded
......
...@@ -1255,8 +1255,8 @@ eitherTyConKey :: Unique ...@@ -1255,8 +1255,8 @@ eitherTyConKey :: Unique
eitherTyConKey = mkPreludeTyConUnique 84 eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors -- Super Kinds constructors
tySuperKindTyConKey :: Unique superKindTyConKey :: Unique
tySuperKindTyConKey = mkPreludeTyConUnique 85 superKindTyConKey = mkPreludeTyConUnique 85
-- Kind constructors -- Kind constructors
liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey,
......
...@@ -25,11 +25,11 @@ module TysPrim( ...@@ -25,11 +25,11 @@ module TysPrim(
kKiVar, kKiVar,
-- Kind constructors... -- Kind constructors...
tySuperKindTyCon, tySuperKind, anyKindTyCon, superKindTyCon, superKind, anyKindTyCon,
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon,
tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
openTypeKindTyConName, unliftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName,
constraintKindTyConName, constraintKindTyConName,
...@@ -232,7 +232,7 @@ argAlphaTy = mkTyVarTy argAlphaTyVar ...@@ -232,7 +232,7 @@ argAlphaTy = mkTyVarTy argAlphaTyVar
argBetaTy = mkTyVarTy argBetaTyVar argBetaTy = mkTyVarTy argBetaTyVar
kKiVar :: KindVar kKiVar :: KindVar
kKiVar = (tyVarList tySuperKind) !! 10 kKiVar = (tyVarList superKind) !! 10
\end{code} \end{code}
...@@ -281,33 +281,53 @@ funTyCon = mkFunTyCon funTyConName $ ...@@ -281,33 +281,53 @@ funTyCon = mkFunTyCon funTyConName $
%* * %* *
%************************************************************************ %************************************************************************
Note [SuperKind (BOX)]
~~~~~~~~~~~~~~~~~~~~~~
Kinds are classified by "super-kinds". There is only one super-kind, namely BOX.
Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX
Reason: we want to have kind equalities, thus (without the kind applications)
keq :: * ~ * = Eq# <refl *>
Remember that
(~) :: forall (k:BOX). k -> k -> Constraint
(~#) :: forall (k:BOX). k -> k -> #
Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b
So the full defn of keq is
keq :: (~) BOX * * = Eq# BOX * * <refl *>
So you can see it's convenient to have BOX:BOX
\begin{code} \begin{code}
-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon, superKindTyCon, anyKindTyCon, liftedTypeKindTyCon,
openTypeKindTyCon, unliftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
ubxTupleKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, argTypeKindTyCon,
constraintKindTyCon constraintKindTyCon
:: TyCon :: TyCon
tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, superKindTyConName, anyKindTyConName, liftedTypeKindTyConName,
openTypeKindTyConName, unliftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName,
constraintKindTyConName constraintKindTyConName
:: Name :: Name
tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName superKindTyCon = mkKindTyCon superKindTyConName superKind
anyKindTyCon = mkKindTyCon anyKindTyConName tySuperKind -- See Note [SuperKind (BOX)]
liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind anyKindTyCon = mkKindTyCon anyKindTyConName superKind
unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind
ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind
argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind
constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName superKind
argTypeKindTyCon = mkKindTyCon argTypeKindTyConName superKind
constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind
-------------------------- --------------------------
-- ... and now their names -- ... and now their names
tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon
anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon
liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon
unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
...@@ -330,10 +350,12 @@ kindTyConType :: TyCon -> Type ...@@ -330,10 +350,12 @@ kindTyConType :: TyCon -> Type
kindTyConType kind = TyConApp kind [] kindTyConType kind = TyConApp kind []
-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind,
superKind :: Kind
-- See Note [Any kinds] superKind = kindTyConType superKindTyCon
anyKind = kindTyConType anyKindTyCon anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds]
liftedTypeKind = kindTyConType liftedTypeKindTyCon liftedTypeKind = kindTyConType liftedTypeKindTyCon
unliftedTypeKind = kindTyConType unliftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon
...@@ -348,9 +370,6 @@ mkArrowKind k1 k2 = FunTy k1 k2 ...@@ -348,9 +370,6 @@ mkArrowKind k1 k2 = FunTy k1 k2
-- | Iterated application of 'mkArrowKind' -- | Iterated application of 'mkArrowKind'
mkArrowKinds :: [Kind] -> Kind -> Kind mkArrowKinds :: [Kind] -> Kind -> Kind
mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
tySuperKind :: SuperKind
tySuperKind = kindTyConType tySuperKindTyCon
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -389,7 +389,7 @@ mkKindName unique = mkSystemName unique kind_var_occ ...@@ -389,7 +389,7 @@ mkKindName unique = mkSystemName unique kind_var_occ
mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar
mkMetaKindVar u r mkMetaKindVar u r
= mkTcTyVar (mkKindName u) = mkTcTyVar (mkKindName u)
tySuperKind -- not sure this is right, superKind -- not sure this is right,
-- do we need kind vars for -- do we need kind vars for
-- coercions? -- coercions?
(MetaTv TauTv r) (MetaTv TauTv r)
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
module Kind ( module Kind (
-- * Main data type -- * Main data type
Kind, typeKind, SuperKind, Kind, typeKind,
-- Kinds -- Kinds
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
...@@ -25,7 +25,7 @@ module Kind ( ...@@ -25,7 +25,7 @@ module Kind (
constraintKindTyCon, constraintKindTyCon,
-- Super Kinds -- Super Kinds
tySuperKind, tySuperKindTyCon, superKind, superKindTyCon,
pprKind, pprParendKind, pprKind, pprParendKind,
...@@ -37,7 +37,7 @@ module Kind ( ...@@ -37,7 +37,7 @@ module Kind (
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isConstraintKind, isUbxTupleKind, isArgTypeKind, isConstraintKind,
isConstraintOrLiftedKind, isKind, isConstraintOrLiftedKind, isKind,
isSuperKind, noHashInKind, isSuperKind, isSuperKindTyCon, noHashInKind,
isLiftedTypeKindCon, isConstraintKindCon, isLiftedTypeKindCon, isConstraintKindCon,
isAnyKind, isAnyKindCon, isAnyKind, isAnyKindCon,
...@@ -223,8 +223,11 @@ tcIsSubArgTypeKind _ = False ...@@ -223,8 +223,11 @@ tcIsSubArgTypeKind _ = False
-- | Is this a super-kind (i.e. a type-of-kinds)? -- | Is this a super-kind (i.e. a type-of-kinds)?
isSuperKind :: Type -> Bool isSuperKind :: Type -> Bool
isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc isSuperKind (TyConApp skc []) = isSuperKindTyCon skc
isSuperKind _ = False isSuperKind _ = False
isSuperKindTyCon :: TyCon -> Bool
isSuperKindTyCon tc = tc `hasKey` superKindTyConKey
-- | Is this a kind (i.e. a type-of-types)? -- | Is this a kind (i.e. a type-of-types)?
isKind :: Kind -> Bool isKind :: Kind -> Bool
......
...@@ -36,7 +36,6 @@ module TyCon( ...@@ -36,7 +36,6 @@ module TyCon(
mkLiftedPrimTyCon, mkLiftedPrimTyCon,
mkTupleTyCon, mkTupleTyCon,
mkSynTyCon, mkSynTyCon,
mkSuperKindTyCon,
mkForeignTyCon, mkForeignTyCon,
mkPromotedDataTyCon, mkPromotedDataTyCon,
mkPromotedTyCon, mkPromotedTyCon,
...@@ -48,8 +47,8 @@ module TyCon( ...@@ -48,8 +47,8 @@ module TyCon(
isPrimTyCon, isPrimTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
isSynTyCon, isClosedSynTyCon, isSynTyCon, isClosedSynTyCon,
isSuperKindTyCon, isDecomposableTyCon, isDecomposableTyCon,
isForeignTyCon, tyConHasKind, isForeignTyCon,
isPromotedDataTyCon, isPromotedTypeTyCon, isPromotedDataTyCon, isPromotedTypeTyCon,
isInjectiveTyCon, isInjectiveTyCon,
...@@ -84,6 +83,7 @@ module TyCon( ...@@ -84,6 +83,7 @@ module TyCon(
tcExpandTyCon_maybe, coreExpandTyCon_maybe, tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract, makeTyConAbstract,
newTyConCo, newTyConCo_maybe, newTyConCo, newTyConCo_maybe,
pprPromotionQuote,
-- * Primitive representations of Types -- * Primitive representations of Types
PrimRep(..), PrimRep(..),
...@@ -394,18 +394,6 @@ data TyCon ...@@ -394,18 +394,6 @@ data TyCon
-- holds the name of the imported thing -- holds the name of the imported thing
} }
-- | Super-kinds. These are "kinds-of-kinds" and are never seen in
-- Haskell source programs. There are only two super-kinds: TY (aka
-- "box"), which is the super-kind of kinds that construct types
-- eventually, and CO (aka "diamond"), which is the super-kind of
-- kinds that just represent coercions.
--
-- Super-kinds have no kind themselves, and have arity zero
| SuperKindTyCon {
tyConUnique :: Unique,
tyConName :: Name
}
-- | Represents promoted data constructor. -- | Represents promoted data constructor.
| PromotedDataTyCon { -- See Note [Promoted data constructors] | PromotedDataTyCon { -- See Note [Promoted data constructors]
tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConUnique :: Unique, -- ^ Same Unique as the data constructor
...@@ -420,7 +408,7 @@ data TyCon ...@@ -420,7 +408,7 @@ data TyCon
tyConUnique :: Unique, -- ^ Same Unique as the type constructor tyConUnique :: Unique, -- ^ Same Unique as the type constructor
tyConName :: Name, -- ^ Same Name as the type constructor tyConName :: Name, -- ^ Same Name as the type constructor
tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times
tc_kind :: Kind, -- ^ Always tySuperKind tc_kind :: Kind, -- ^ Always TysPrim.superKind
ty_con :: TyCon -- ^ Corresponding type constructor ty_con :: TyCon -- ^ Corresponding type constructor
} }
...@@ -954,14 +942,6 @@ mkSynTyCon name kind tyvars rhs parent ...@@ -954,14 +942,6 @@ mkSynTyCon name kind tyvars rhs parent
synTcParent = parent synTcParent = parent
} }
-- | Create a super-kind 'TyCon'
mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero
mkSuperKindTyCon name
= SuperKindTyCon {
tyConName = name,
tyConUnique = nameUnique name
}
-- | Create a promoted data constructor 'TyCon' -- | Create a promoted data constructor 'TyCon'
-- Somewhat dodgily, we give it the same Name -- Somewhat dodgily, we give it the same Name
-- as the data constructor itself -- as the data constructor itself
...@@ -1215,11 +1195,6 @@ isForeignTyCon :: TyCon -> Bool ...@@ -1215,11 +1195,6 @@ isForeignTyCon :: TyCon -> Bool
isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True
isForeignTyCon _ = False isForeignTyCon _ = False
-- | Is this a super-kind 'TyCon'?
isSuperKindTyCon :: TyCon -> Bool
isSuperKindTyCon (SuperKindTyCon {}) = True
isSuperKindTyCon _ = False
-- | Is this a PromotedDataTyCon? -- | Is this a PromotedDataTyCon?
isPromotedDataTyCon :: TyCon -> Bool isPromotedDataTyCon :: TyCon -> Bool
isPromotedDataTyCon (PromotedDataTyCon {}) = True isPromotedDataTyCon (PromotedDataTyCon {}) = True
...@@ -1248,7 +1223,7 @@ isImplicitTyCon tycon ...@@ -1248,7 +1223,7 @@ isImplicitTyCon tycon
| isAlgTyCon tycon = isTupleTyCon tycon | isAlgTyCon tycon = isTupleTyCon tycon
| otherwise = True | otherwise = True
-- 'otherwise' catches: FunTyCon, PrimTyCon, -- 'otherwise' catches: FunTyCon, PrimTyCon,
-- PromotedDataCon, PomotedTypeTyCon, SuperKindTyCon -- PromotedDataCon, PomotedTypeTyCon
\end{code} \end{code}
...@@ -1296,12 +1271,7 @@ expand tvs rhs tys ...@@ -1296,12 +1271,7 @@ expand tvs rhs tys
\begin{code} \begin{code}
tyConKind :: TyCon -> Kind tyConKind :: TyCon -> Kind
tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty tyConKind = tc_kind
tyConKind tc = tc_kind tc
tyConHasKind :: TyCon -> Bool
tyConHasKind (SuperKindTyCon {}) = False
tyConHasKind _ = True
-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors
-- could be found -- could be found
...@@ -1500,7 +1470,14 @@ instance Uniquable TyCon where ...@@ -1500,7 +1470,14 @@ instance Uniquable TyCon where
getUnique tc = tyConUnique tc getUnique tc = tyConUnique tc
instance Outputable TyCon where instance Outputable TyCon where
ppr tc = ppr (tyConName tc) -- At the moment a promoted TyCon has the same Name as its
-- corresponding TyCon, so we add the quote to distinguish it here
ppr tc = pprPromotionQuote tc <> ppr (tyConName tc)
pprPromotionQuote :: TyCon -> SDoc
pprPromotionQuote (PromotedTypeTyCon {}) = char '\''
pprPromotionQuote (PromotedDataTyCon {}) = char '\''
pprPromotionQuote _ = empty
instance NamedThing TyCon where instance NamedThing TyCon where
getName = tyConName getName = tyConName
......
...@@ -79,7 +79,7 @@ module Type ( ...@@ -79,7 +79,7 @@ module Type (
-- ** Common Kinds and SuperKinds -- ** Common Kinds and SuperKinds
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind, argTypeKind, ubxTupleKind, constraintKind,
tySuperKind, superKind,
-- ** Common Kind type constructors -- ** Common Kind type constructors
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
...@@ -1544,7 +1544,7 @@ type SimpleKind = Kind ...@@ -1544,7 +1544,7 @@ type SimpleKind = Kind
typeKind :: Type -> Kind typeKind :: Type -> Kind
typeKind (TyConApp tc tys) typeKind (TyConApp tc tys)
| isPromotedTypeTyCon tc | isPromotedTypeTyCon tc
= ASSERT( tyConArity tc == length tys ) tySuperKind = ASSERT( tyConArity tc == length tys ) superKind
| otherwise | otherwise
= kindAppResult (tyConKind tc) tys = kindAppResult (tyConKind tc) tys
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment