summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Names.hs118
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs24
-rw-r--r--compiler/GHC/Builtin/Types.hs27
-rw-r--r--compiler/GHC/Builtin/Types.hs-boot1
-rw-r--r--compiler/GHC/Builtin/Types/Literals.hs224
-rw-r--r--compiler/GHC/Core/Lint.hs1
-rw-r--r--compiler/GHC/Core/Map/Type.hs20
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs14
-rw-r--r--compiler/GHC/Core/Type.hs16
-rw-r--r--compiler/GHC/CoreToIface.hs1
-rw-r--r--compiler/GHC/Data/FastString.hs7
-rw-r--r--compiler/GHC/Hs/Utils.hs4
-rw-r--r--compiler/GHC/HsToCore/Binds.hs3
-rw-r--r--compiler/GHC/HsToCore/Quote.hs3
-rw-r--r--compiler/GHC/Iface/Type.hs10
-rw-r--r--compiler/GHC/IfaceToCore.hs1
-rw-r--r--compiler/GHC/Parser.y2
-rw-r--r--compiler/GHC/Rename/HsType.hs1
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs1
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs1
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs15
-rw-r--r--compiler/GHC/Tc/Instance/Typeable.hs7
-rw-r--r--compiler/GHC/Tc/Utils/TcType.hs1
-rw-r--r--compiler/GHC/ThToHs.hs1
-rw-r--r--compiler/GHC/Utils/Binary.hs3
-rw-r--r--compiler/GHC/Utils/Binary/Typeable.hs10
27 files changed, 404 insertions, 115 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index e04c2e81b7..0764e5c536 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -247,12 +247,13 @@ basicKnownKeyNames
typeLitSortTyConName,
typeLitSymbolDataConName,
typeLitNatDataConName,
+ typeLitCharDataConName,
typeRepIdName,
mkTrTypeName,
mkTrConName,
mkTrAppName,
mkTrFunName,
- typeSymbolTypeRepName, typeNatTypeRepName,
+ typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,
trGhcPrimModuleName,
-- KindReps for common cases
@@ -439,7 +440,7 @@ basicKnownKeyNames
randomClassName, randomGenClassName, monadPlusClassName,
-- Type-level naturals
- knownNatClassName, knownSymbolClassName,
+ knownNatClassName, knownSymbolClassName, knownCharClassName,
-- Overloaded labels
isLabelClassName,
@@ -1405,10 +1406,12 @@ kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kind
typeLitSortTyConName
, typeLitSymbolDataConName
, typeLitNatDataConName
+ , typeLitCharDataConName
:: Name
typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey
typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey
typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey
+typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey
-- Class Typeable, and functions for constructing `Typeable` dictionaries
typeableClassName
@@ -1422,6 +1425,7 @@ typeableClassName
, typeRepIdName
, typeNatTypeRepName
, typeSymbolTypeRepName
+ , typeCharTypeRepName
, trGhcPrimModuleName
:: Name
typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey
@@ -1435,6 +1439,7 @@ mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrA
mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey
typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey
+typeCharTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey
-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)
-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.
trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey
@@ -1617,6 +1622,8 @@ knownNatClassName :: Name
knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey
knownSymbolClassName :: Name
knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey
+knownCharClassName :: Name
+knownCharClassName = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey
-- Overloaded labels
isLabelClassName :: Name
@@ -1773,23 +1780,26 @@ knownNatClassNameKey = mkPreludeClassUnique 42
knownSymbolClassNameKey :: Unique
knownSymbolClassNameKey = mkPreludeClassUnique 43
+knownCharClassNameKey :: Unique
+knownCharClassNameKey = mkPreludeClassUnique 44
+
ghciIoClassKey :: Unique
-ghciIoClassKey = mkPreludeClassUnique 44
+ghciIoClassKey = mkPreludeClassUnique 45
isLabelClassNameKey :: Unique
-isLabelClassNameKey = mkPreludeClassUnique 45
+isLabelClassNameKey = mkPreludeClassUnique 46
semigroupClassKey, monoidClassKey :: Unique
-semigroupClassKey = mkPreludeClassUnique 46
-monoidClassKey = mkPreludeClassUnique 47
+semigroupClassKey = mkPreludeClassUnique 47
+monoidClassKey = mkPreludeClassUnique 48
-- Implicit Parameters
ipClassKey :: Unique
-ipClassKey = mkPreludeClassUnique 48
+ipClassKey = mkPreludeClassUnique 49
-- Overloaded record fields
hasFieldClassNameKey :: Unique
-hasFieldClassNameKey = mkPreludeClassUnique 49
+hasFieldClassNameKey = mkPreludeClassUnique 50
---------------- Template Haskell -------------------
@@ -1973,81 +1983,88 @@ uIntTyConKey = mkPreludeTyConUnique 162
uWordTyConKey = mkPreludeTyConUnique 163
-- Type-level naturals
-typeSymbolKindConNameKey,
+typeSymbolKindConNameKey, typeCharKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
- , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
+ , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey
+ , typeLeqCharTyFamNameKey
, typeNatDivTyFamNameKey
, typeNatModTyFamNameKey
, typeNatLogTyFamNameKey
+ , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey
:: Unique
typeSymbolKindConNameKey = mkPreludeTyConUnique 165
-typeNatAddTyFamNameKey = mkPreludeTyConUnique 166
-typeNatMulTyFamNameKey = mkPreludeTyConUnique 167
-typeNatExpTyFamNameKey = mkPreludeTyConUnique 168
-typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169
-typeNatSubTyFamNameKey = mkPreludeTyConUnique 170
-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
-typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172
-typeNatDivTyFamNameKey = mkPreludeTyConUnique 173
-typeNatModTyFamNameKey = mkPreludeTyConUnique 174
-typeNatLogTyFamNameKey = mkPreludeTyConUnique 175
+typeCharKindConNameKey = mkPreludeTyConUnique 166
+typeNatAddTyFamNameKey = mkPreludeTyConUnique 167
+typeNatMulTyFamNameKey = mkPreludeTyConUnique 168
+typeNatExpTyFamNameKey = mkPreludeTyConUnique 169
+typeNatLeqTyFamNameKey = mkPreludeTyConUnique 170
+typeNatSubTyFamNameKey = mkPreludeTyConUnique 171
+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 172
+typeNatCmpTyFamNameKey = mkPreludeTyConUnique 173
+typeCharCmpTyFamNameKey = mkPreludeTyConUnique 174
+typeLeqCharTyFamNameKey = mkPreludeTyConUnique 175
+typeNatDivTyFamNameKey = mkPreludeTyConUnique 176
+typeNatModTyFamNameKey = mkPreludeTyConUnique 177
+typeNatLogTyFamNameKey = mkPreludeTyConUnique 178
+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 179
+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 180
-- Custom user type-errors
errorMessageTypeErrorFamKey :: Unique
-errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176
+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181
ntTyConKey:: Unique
-ntTyConKey = mkPreludeTyConUnique 177
+ntTyConKey = mkPreludeTyConUnique 182
coercibleTyConKey :: Unique
-coercibleTyConKey = mkPreludeTyConUnique 178
+coercibleTyConKey = mkPreludeTyConUnique 183
proxyPrimTyConKey :: Unique
-proxyPrimTyConKey = mkPreludeTyConUnique 179
+proxyPrimTyConKey = mkPreludeTyConUnique 184
specTyConKey :: Unique
-specTyConKey = mkPreludeTyConUnique 180
+specTyConKey = mkPreludeTyConUnique 185
anyTyConKey :: Unique
-anyTyConKey = mkPreludeTyConUnique 181
+anyTyConKey = mkPreludeTyConUnique 186
-smallArrayPrimTyConKey = mkPreludeTyConUnique 182
-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183
+smallArrayPrimTyConKey = mkPreludeTyConUnique 187
+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188
staticPtrTyConKey :: Unique
-staticPtrTyConKey = mkPreludeTyConUnique 184
+staticPtrTyConKey = mkPreludeTyConUnique 189
staticPtrInfoTyConKey :: Unique
-staticPtrInfoTyConKey = mkPreludeTyConUnique 185
+staticPtrInfoTyConKey = mkPreludeTyConUnique 190
callStackTyConKey :: Unique
-callStackTyConKey = mkPreludeTyConUnique 186
+callStackTyConKey = mkPreludeTyConUnique 191
-- Typeables
typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique
-typeRepTyConKey = mkPreludeTyConUnique 187
-someTypeRepTyConKey = mkPreludeTyConUnique 188
-someTypeRepDataConKey = mkPreludeTyConUnique 189
+typeRepTyConKey = mkPreludeTyConUnique 192
+someTypeRepTyConKey = mkPreludeTyConUnique 193
+someTypeRepDataConKey = mkPreludeTyConUnique 194
typeSymbolAppendFamNameKey :: Unique
-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190
+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195
-- Unsafe equality
unsafeEqualityTyConKey :: Unique
-unsafeEqualityTyConKey = mkPreludeTyConUnique 191
+unsafeEqualityTyConKey = mkPreludeTyConUnique 196
-- Linear types
multiplicityTyConKey :: Unique
-multiplicityTyConKey = mkPreludeTyConUnique 192
+multiplicityTyConKey = mkPreludeTyConUnique 197
unrestrictedFunTyConKey :: Unique
-unrestrictedFunTyConKey = mkPreludeTyConUnique 193
+unrestrictedFunTyConKey = mkPreludeTyConUnique 198
multMulTyConKey :: Unique
-multMulTyConKey = mkPreludeTyConUnique 194
+multMulTyConKey = mkPreludeTyConUnique 199
---------------- Template Haskell -------------------
-- GHC.Builtin.Names.TH: USES TyConUniques 200-299
@@ -2212,19 +2229,20 @@ kindRepTYPEDataConKey = mkPreludeDataConUnique 109
kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110
kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111
-typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique
+typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique
typeLitSymbolDataConKey = mkPreludeDataConUnique 112
typeLitNatDataConKey = mkPreludeDataConUnique 113
+typeLitCharDataConKey = mkPreludeDataConUnique 114
-- Unsafe equality
unsafeReflDataConKey :: Unique
-unsafeReflDataConKey = mkPreludeDataConUnique 114
+unsafeReflDataConKey = mkPreludeDataConUnique 115
-- Multiplicity
oneDataConKey, manyDataConKey :: Unique
-oneDataConKey = mkPreludeDataConUnique 115
-manyDataConKey = mkPreludeDataConUnique 116
+oneDataConKey = mkPreludeDataConUnique 116
+manyDataConKey = mkPreludeDataConUnique 117
-- ghc-bignum
integerISDataConKey, integerINDataConKey, integerIPDataConKey,
@@ -2451,6 +2469,7 @@ mkTyConKey
, mkTrFunKey
, typeNatTypeRepKey
, typeSymbolTypeRepKey
+ , typeCharTypeRepKey
, typeRepIdKey
:: Unique
mkTyConKey = mkPreludeMiscIdUnique 503
@@ -2459,8 +2478,9 @@ mkTrConKey = mkPreludeMiscIdUnique 505
mkTrAppKey = mkPreludeMiscIdUnique 506
typeNatTypeRepKey = mkPreludeMiscIdUnique 507
typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508
-typeRepIdKey = mkPreludeMiscIdUnique 509
-mkTrFunKey = mkPreludeMiscIdUnique 510
+typeCharTypeRepKey = mkPreludeMiscIdUnique 509
+typeRepIdKey = mkPreludeMiscIdUnique 510
+mkTrFunKey = mkPreludeMiscIdUnique 511
-- Representations for primitive types
trTYPEKey
@@ -2468,10 +2488,10 @@ trTYPEKey
, trRuntimeRepKey
, tr'PtrRepLiftedKey
:: Unique
-trTYPEKey = mkPreludeMiscIdUnique 511
-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512
-trRuntimeRepKey = mkPreludeMiscIdUnique 513
-tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514
+trTYPEKey = mkPreludeMiscIdUnique 512
+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513
+trRuntimeRepKey = mkPreludeMiscIdUnique 514
+tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 515
-- KindReps for common cases
starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index 1580151028..07a8583662 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -104,7 +104,7 @@ templateHaskellNames = [
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, implicitParamTName,
-- TyLit
- numTyLitName, strTyLitName,
+ numTyLitName, strTyLitName, charTyLitName,
-- TyVarBndr
plainTVName, kindedTVName,
plainInvisTVName, kindedInvisTVName,
@@ -470,9 +470,10 @@ infixTName = libFun (fsLit "infixT") infixTIdKey
implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey
-- data TyLit = ...
-numTyLitName, strTyLitName :: Name
+numTyLitName, strTyLitName, charTyLitName :: Name
numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
+charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey
-- data TyVarBndr = ...
plainTVName, kindedTVName :: Name
@@ -991,14 +992,15 @@ implicitParamTIdKey = mkPreludeMiscIdUnique 409
infixTIdKey = mkPreludeMiscIdUnique 410
-- data TyLit = ...
-numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 411
-strTyLitIdKey = mkPreludeMiscIdUnique 412
+numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique
+numTyLitIdKey = mkPreludeMiscIdUnique 411
+strTyLitIdKey = mkPreludeMiscIdUnique 412
+charTyLitIdKey = mkPreludeMiscIdUnique 413
-- data TyVarBndr = ...
plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey = mkPreludeMiscIdUnique 413
-kindedTVIdKey = mkPreludeMiscIdUnique 414
+plainTVIdKey = mkPreludeMiscIdUnique 414
+kindedTVIdKey = mkPreludeMiscIdUnique 415
plainInvisTVIdKey, kindedInvisTVIdKey :: Unique
plainInvisTVIdKey = mkPreludeMiscIdUnique 482
@@ -1006,10 +1008,10 @@ kindedInvisTVIdKey = mkPreludeMiscIdUnique 483
-- data Role = ...
nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey = mkPreludeMiscIdUnique 415
-representationalRIdKey = mkPreludeMiscIdUnique 416
-phantomRIdKey = mkPreludeMiscIdUnique 417
-inferRIdKey = mkPreludeMiscIdUnique 418
+nominalRIdKey = mkPreludeMiscIdUnique 416
+representationalRIdKey = mkPreludeMiscIdUnique 417
+phantomRIdKey = mkPreludeMiscIdUnique 418
+inferRIdKey = mkPreludeMiscIdUnique 419
-- data Kind = ...
starKIdKey, constraintKIdKey :: Unique
diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs
index 3339e0a020..9957e0bed7 100644
--- a/compiler/GHC/Builtin/Types.hs
+++ b/compiler/GHC/Builtin/Types.hs
@@ -68,13 +68,14 @@ module GHC.Builtin.Types (
maybeTyCon, maybeTyConName,
nothingDataCon, nothingDataConName, promotedNothingDataCon,
justDataCon, justDataConName, promotedJustDataCon,
+ mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,
-- * Tuples
mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,
tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,
promotedTupleDataCon,
unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,
- pairTyCon,
+ pairTyCon, mkPromotedPairTy, isPromotedPairType,
unboxedUnitTy,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedTupleKind, unboxedSumKind,
@@ -1005,6 +1006,16 @@ tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)
tupleDataConName :: Boxity -> Arity -> Name
tupleDataConName sort i = dataConName (tupleDataCon sort i)
+mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type
+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]
+
+isPromotedPairType :: Type -> Maybe (Type, Type)
+isPromotedPairType t
+ | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t
+ , tc == promotedTupleDataCon Boxed 2
+ = Just (x, y)
+ | otherwise = Nothing
+
boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)
boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]]
unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]
@@ -1791,6 +1802,20 @@ nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon
justDataCon :: DataCon
justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon
+mkPromotedMaybeTy :: Kind -> Maybe Type -> Type
+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]
+mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k]
+
+mkMaybeTy :: Type -> Kind
+mkMaybeTy t = mkTyConApp maybeTyCon [t]
+
+isPromotedMaybeTy :: Type -> Maybe (Maybe Type)
+isPromotedMaybeTy t
+ | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x
+ | Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing
+ | otherwise = Nothing
+
+
{-
** *********************************************************************
* *
diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot
index 000df212c3..c19137e148 100644
--- a/compiler/GHC/Builtin/Types.hs-boot
+++ b/compiler/GHC/Builtin/Types.hs-boot
@@ -9,6 +9,7 @@ import {-# SOURCE #-} GHC.Types.Name (Name)
listTyCon :: TyCon
typeSymbolKind :: Type
+charTy :: Type
mkBoxedTupleTy :: [Type] -> Type
coercibleTyCon, heqTyCon :: TyCon
diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs
index 0f609eaad8..59fd758293 100644
--- a/compiler/GHC/Builtin/Types/Literals.hs
+++ b/compiler/GHC/Builtin/Types/Literals.hs
@@ -19,6 +19,9 @@ module GHC.Builtin.Types.Literals
, typeNatCmpTyCon
, typeSymbolCmpTyCon
, typeSymbolAppendTyCon
+ , typeCharCmpTyCon
+ , typeConsSymbolTyCon
+ , typeUnconsSymbolTyCon
) where
import GHC.Prelude
@@ -49,6 +52,9 @@ import GHC.Builtin.Names
, typeNatCmpTyFamNameKey
, typeSymbolCmpTyFamNameKey
, typeSymbolAppendFamNameKey
+ , typeCharCmpTyFamNameKey
+ , typeConsSymbolTyFamNameKey
+ , typeUnconsSymbolTyFamNameKey
)
import GHC.Data.FastString
import Data.Maybe ( isJust )
@@ -58,8 +64,8 @@ import Data.List ( isPrefixOf, isSuffixOf )
{-
Note [Type-level literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are currently two forms of type-level literals: natural numbers, and
-symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both).
+There are currently three forms of type-level literals: natural numbers, symbols, and
+characters.
Type-level literals are supported by CoAxiomRules (conditional axioms), which
power the built-in type families (see Note [Adding built-in type families]).
@@ -148,6 +154,9 @@ typeNatTyCons =
, typeNatCmpTyCon
, typeSymbolCmpTyCon
, typeSymbolAppendTyCon
+ , typeCharCmpTyCon
+ , typeConsSymbolTyCon
+ , typeUnconsSymbolTyCon
]
typeNatAddTyCon :: TyCon
@@ -205,10 +214,6 @@ typeNatModTyCon = mkTypeNatFunTyCon2 name
name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")
typeNatModTyFamNameKey typeNatModTyCon
-
-
-
-
typeNatExpTyCon :: TyCon
typeNatExpTyCon = mkTypeNatFunTyCon2 name
BuiltInSynFamily
@@ -231,8 +236,6 @@ typeNatLogTyCon = mkTypeNatFunTyCon1 name
name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")
typeNatLogTyFamNameKey typeNatLogTyCon
-
-
typeNatLeqTyCon :: TyCon
typeNatLeqTyCon =
mkFamilyTyCon name
@@ -301,6 +304,42 @@ typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name
name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")
typeSymbolAppendFamNameKey typeSymbolAppendTyCon
+typeConsSymbolTyCon :: TyCon
+typeConsSymbolTyCon =
+ mkFamilyTyCon name
+ (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])
+ typeSymbolKind
+ Nothing
+ (BuiltInSynFamTyCon ops)
+ Nothing
+ (Injective [True, True])
+ where
+ name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol")
+ typeConsSymbolTyFamNameKey typeConsSymbolTyCon
+ ops = BuiltInSynFamily
+ { sfMatchFam = matchFamConsSymbol
+ , sfInteractTop = interactTopConsSymbol
+ , sfInteractInert = interactInertConsSymbol
+ }
+
+typeUnconsSymbolTyCon :: TyCon
+typeUnconsSymbolTyCon =
+ mkFamilyTyCon name
+ (mkTemplateAnonTyConBinders [ typeSymbolKind ])
+ (mkMaybeTy charSymbolPairKind)
+ Nothing
+ (BuiltInSynFamTyCon ops)
+ Nothing
+ (Injective [True])
+ where
+ name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol")
+ typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon
+ ops = BuiltInSynFamily
+ { sfMatchFam = matchFamUnconsSymbol
+ , sfInteractTop = interactTopUnconsSymbol
+ , sfInteractInert = interactInertUnconsSymbol
+ }
+
-- Make a unary built-in constructor of kind: Nat -> Nat
mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon
mkTypeNatFunTyCon1 op tcb =
@@ -312,7 +351,6 @@ mkTypeNatFunTyCon1 op tcb =
Nothing
NotInjective
-
-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
mkTypeNatFunTyCon2 op tcb =
@@ -335,7 +373,6 @@ mkTypeSymbolFunTyCon2 op tcb =
Nothing
NotInjective
-
{-------------------------------------------------------------------------------
Built-in rules axioms
-------------------------------------------------------------------------------}
@@ -350,6 +387,8 @@ axAddDef
, axCmpNatDef
, axCmpSymbolDef
, axAppendSymbolDef
+ , axConsSymbolDef
+ , axUnconsSymbolDef
, axAdd0L
, axAdd0R
, axMul0L
@@ -374,19 +413,19 @@ axAddDef
, axLogDef
:: CoAxiomRule
-axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $
+axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $
\x y -> Just $ num (x + y)
-axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $
+axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $
\x y -> Just $ num (x * y)
-axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $
+axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $
\x y -> Just $ num (x ^ y)
-axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $
+axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon isNumLitTy isNumLitTy $
\x y -> Just $ bool (x <= y)
-axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon
+axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy
$ \x y -> Just $ ordering (compare x y)
axCmpSymbolDef =
@@ -413,18 +452,27 @@ axAppendSymbolDef = CoAxiomRule
return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)
}
-axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $
+axConsSymbolDef =
+ mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $
+ \c str -> Just $ mkStrLitTy (consFS c str)
+
+axUnconsSymbolDef =
+ mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $
+ \str -> Just $
+ mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str))
+
+axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $
\x y -> fmap num (minus x y)
-axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $
+axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $
\x y -> do guard (y /= 0)
return (num (div x y))
-axModDef = mkBinAxiom "ModDef" typeNatModTyCon $
+axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $
\x y -> do guard (y /= 0)
return (num (mod x y))
-axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $
+axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $
\x -> do (a,_) <- genLog x 2
return (num a)
@@ -463,7 +511,10 @@ typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x))
, axLeqDef
, axCmpNatDef
, axCmpSymbolDef
+ , axCmpCharDef
, axAppendSymbolDef
+ , axConsSymbolDef
+ , axUnconsSymbolDef
, axAdd0L
, axAdd0R
, axMul0L
@@ -476,6 +527,7 @@ typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x))
, axLeqRefl
, axCmpNatRefl
, axCmpSymbolRefl
+ , axCmpCharRefl
, axLeq0L
, axSubDef
, axSub0R
@@ -534,6 +586,12 @@ bool :: Bool -> Type
bool b = if b then mkTyConApp promotedTrueDataCon []
else mkTyConApp promotedFalseDataCon []
+charSymbolPair :: Type -> Type -> Type
+charSymbolPair = mkPromotedPairTy charTy typeSymbolKind
+
+charSymbolPairKind :: Kind
+charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]
+
isBoolLitTy :: Type -> Maybe Bool
isBoolLitTy tc =
do (tc,[]) <- splitTyConApp_maybe tc
@@ -566,40 +624,37 @@ known p x = case isNumLitTy x of
Just a -> p a
Nothing -> False
-
-mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule
-mkUnAxiom str tc f =
+mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule
+mkUnAxiom str tc isReqTy f =
CoAxiomRule
{ coaxrName = fsLit str
, coaxrAsmpRoles = [Nominal]
, coaxrRole = Nominal
, coaxrProves = \cs ->
do [Pair s1 s2] <- return cs
- s2' <- isNumLitTy s2
+ s2' <- isReqTy s2
z <- f s2'
return (mkTyConApp tc [s1] === z)
}
-
-
-- For the definitional axioms
mkBinAxiom :: String -> TyCon ->
- (Integer -> Integer -> Maybe Type) -> CoAxiomRule
-mkBinAxiom str tc f =
+ (Type -> Maybe a) ->
+ (Type -> Maybe b) ->
+ (a -> b -> Maybe Type) -> CoAxiomRule
+mkBinAxiom str tc isReqTy1 isReqTy2 f =
CoAxiomRule
{ coaxrName = fsLit str
, coaxrAsmpRoles = [Nominal, Nominal]
, coaxrRole = Nominal
, coaxrProves = \cs ->
do [Pair s1 s2, Pair t1 t2] <- return cs
- s2' <- isNumLitTy s2
- t2' <- isNumLitTy t2
+ s2' <- isReqTy1 s2
+ t2' <- isReqTy2 t2
z <- f s2' t2'
return (mkTyConApp tc [s1,t1] === z)
}
-
-
mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule
mkAxiom1 str f =
CoAxiomRule
@@ -662,8 +717,6 @@ matchFamMod [s,t]
mbY = isNumLitTy t
matchFamMod _ = Nothing
-
-
matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
matchFamExp [s,t]
| Just 0 <- mbY = Just (axExp0R, [s], num 1)
@@ -681,7 +734,6 @@ matchFamLog [s]
where mbX = isNumLitTy s
matchFamLog _ = Nothing
-
matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
matchFamLeq [s,t]
| Just 0 <- mbX = Just (axLeq0L, [t], bool True)
@@ -721,6 +773,27 @@ matchFamAppendSymbol [s,t]
mbY = isStrLitTy t
matchFamAppendSymbol _ = Nothing
+matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamConsSymbol [s,t]
+ | Just x <- mbX, Just y <- mbY =
+ Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y))
+ where
+ mbX = isCharLitTy s
+ mbY = isStrLitTy t
+matchFamConsSymbol _ = Nothing
+
+reifyCharSymbolPairTy :: (Char, FastString) -> Type
+reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)
+
+matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamUnconsSymbol [s]
+ | Just x <- mbX =
+ Just (axUnconsSymbolDef, [s]
+ , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x)))
+ where
+ mbX = isStrLitTy s
+matchFamUnconsSymbol _ = Nothing
+
{-------------------------------------------------------------------------------
Interact with axioms
-------------------------------------------------------------------------------}
@@ -810,7 +883,6 @@ interactTopLog :: [Xi] -> Xi -> [Pair Type]
interactTopLog _ _ = [] -- I can't think of anything...
-
interactTopLeq :: [Xi] -> Xi -> [Pair Type]
interactTopLeq [s,t] r
| Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0)
@@ -850,6 +922,33 @@ interactTopAppendSymbol [s,t] r
interactTopAppendSymbol _ _ = []
+interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopConsSymbol [s,t] r
+ -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah")
+ | Just fs <- isStrLitTy r
+ , Just (x, xs) <- unconsFS fs =
+ [ s === mkCharLitTy x, t === mkStrLitTy xs ]
+
+interactTopConsSymbol _ _ = []
+
+interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopUnconsSymbol [s] r
+ -- (UnconsSymbol b ~ Nothing) => (b ~ "")
+ | Just Nothing <- mbX =
+ [ s === mkStrLitTy nilFS ]
+ -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")
+ | Just (Just r) <- mbX
+ , Just (c, str) <- isPromotedPairType r
+ , Just chr <- isCharLitTy c
+ , Just str1 <- isStrLitTy str =
+ [ s === (mkStrLitTy $ consFS chr str1) ]
+
+ where
+ mbX = isPromotedMaybeTy r
+
+interactTopUnconsSymbol _ _ = []
+
+
{-------------------------------------------------------------------------------
Interaction with inerts
-------------------------------------------------------------------------------}
@@ -914,6 +1013,17 @@ interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2
interactInertAppendSymbol _ _ _ _ = []
+interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertConsSymbol [x1, y1] z1 [x2, y2] z2
+ | sameZ = [ x1 === x2, y1 === y2 ]
+ where sameZ = tcEqType z1 z2
+interactInertConsSymbol _ _ _ _ = []
+
+interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertUnconsSymbol [x1] z1 [x2] z2
+ | tcEqType z1 z2 = [ x1 === x2 ]
+interactInertUnconsSymbol _ _ _ _ = []
+
{- -----------------------------------------------------------------------------
These inverse functions are used for simplifying propositions using
@@ -987,3 +1097,47 @@ genLog x base = Just (exactLoop 0 x)
underLoop s i
| i < base = s
| otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
+
+-----------------------------------------------------------------------------
+
+typeCharCmpTyCon :: TyCon
+typeCharCmpTyCon =
+ mkFamilyTyCon name
+ (mkTemplateAnonTyConBinders [ charTy, charTy ])
+ orderingKind
+ Nothing
+ (BuiltInSynFamTyCon ops)
+ Nothing
+ NotInjective
+ where
+ name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpChar")
+ typeCharCmpTyFamNameKey typeCharCmpTyCon
+ ops = BuiltInSynFamily
+ { sfMatchFam = matchFamCmpChar
+ , sfInteractTop = interactTopCmpChar
+ , sfInteractInert = \_ _ _ _ -> []
+ }
+
+interactTopCmpChar :: [Xi] -> Xi -> [Pair Type]
+interactTopCmpChar [s,t] r
+ | Just EQ <- isOrderingLitTy r = [ s === t ]
+interactTopCmpChar _ _ = []
+
+cmpChar :: Type -> Type -> Type
+cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t]
+
+axCmpCharDef, axCmpCharRefl :: CoAxiomRule
+axCmpCharDef =
+ mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $
+ \chr1 chr2 -> Just $ ordering $ compare chr1 chr2
+axCmpCharRefl = mkAxiom1 "CmpCharRefl"
+ $ \(Pair s _) -> (cmpChar s s) === ordering EQ
+
+matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamCmpChar [s,t]
+ | Just x <- mbX, Just y <- mbY =
+ Just (axCmpCharDef, [s,t], ordering (compare x y))
+ | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ)
+ where mbX = isCharLitTy s
+ mbY = isCharLitTy t
+matchFamCmpChar _ = Nothing
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 0746b54811..f014a20817 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -1767,6 +1767,7 @@ lintTyLit (NumTyLit n)
| otherwise = failWithL msg
where msg = text "Negative type literal:" <+> integer n
lintTyLit (StrTyLit _) = return ()
+lintTyLit (CharTyLit _) = return ()
lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()
-- (lint_app d fun_kind arg_tys)
diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs
index 8056211314..a50549ffdd 100644
--- a/compiler/GHC/Core/Map/Type.hs
+++ b/compiler/GHC/Core/Map/Type.hs
@@ -307,6 +307,7 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon
------------------------
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_string :: UniqFM FastString a
+ , tlm_char :: Map.Map Char a
}
instance TrieMap TyLitMap where
@@ -319,31 +320,34 @@ instance TrieMap TyLitMap where
filterTM = filterTyLit
emptyTyLitMap :: TyLitMap a
-emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM }
+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }
mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b
-mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })
- = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts }
+mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
+ = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
NumTyLit n -> tlm_number >.> Map.lookup n
StrTyLit n -> tlm_string >.> (`lookupUFM` n)
+ CharTyLit n -> tlm_char >.> Map.lookup n
xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
xtTyLit l f m =
case l of
- NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }
- StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n }
+ NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) }
+ StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n }
+ CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }
foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
foldTyLit l m = flip (foldUFM l) (tlm_string m)
- . flip (Map.foldr l) (tlm_number m)
+ . flip (Map.foldr l) (tlm_number m)
+ . flip (Map.foldr l) (tlm_char m)
filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a
-filterTyLit f (TLM { tlm_number = tn, tlm_string = ts })
- = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts }
+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })
+ = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }
-------------------------------------------------
-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index be7bdb3aef..69db14e7f0 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -192,13 +192,19 @@ instance Outputable Type where
data TyLit
= NumTyLit Integer
| StrTyLit FastString
+ | CharTyLit Char
deriving (Eq, Data.Data)
instance Ord TyLit where
- compare (NumTyLit _) (StrTyLit _) = LT
- compare (StrTyLit _) (NumTyLit _) = GT
- compare (NumTyLit x) (NumTyLit y) = compare x y
- compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y
+ compare (NumTyLit x) (NumTyLit y) = compare x y
+ compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y
+ compare (CharTyLit x) (CharTyLit y) = compare x y
+ compare a b = compare (tag a) (tag b)
+ where
+ tag :: TyLit -> Int
+ tag NumTyLit{} = 0
+ tag StrTyLit{} = 1
+ tag CharTyLit{} = 2
instance Outputable TyLit where
ppr = pprTyLit
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index af92b92e52..21f03d653e 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -63,6 +63,7 @@ module GHC.Core.Type (
mkNumLitTy, isNumLitTy,
mkStrLitTy, isStrLitTy,
+ mkCharLitTy, isCharLitTy,
isLitTy,
isPredTy,
@@ -255,7 +256,7 @@ import GHC.Types.Unique.Set
import GHC.Core.TyCon
import GHC.Builtin.Types.Prim
import {-# SOURCE #-} GHC.Builtin.Types
- ( naturalTy, listTyCon
+ ( charTy, naturalTy, listTyCon
, typeSymbolKind, liftedTypeKind
, constraintKind
, unrestrictedFunTyCon
@@ -1074,7 +1075,17 @@ isStrLitTy ty
| LitTy (StrTyLit s) <- coreFullView ty = Just s
| otherwise = Nothing
--- | Is this a type literal (symbol or numeric).
+mkCharLitTy :: Char -> Type
+mkCharLitTy c = LitTy (CharTyLit c)
+
+-- | Is this a char literal? We also look through type synonyms.
+isCharLitTy :: Type -> Maybe Char
+isCharLitTy ty
+ | LitTy (CharTyLit s) <- coreFullView ty = Just s
+ | otherwise = Nothing
+
+
+-- | Is this a type literal (symbol, numeric, or char)?
isLitTy :: Type -> Maybe TyLit
isLitTy ty
| LitTy l <- coreFullView ty = Just l
@@ -2684,6 +2695,7 @@ tcReturnsConstraintKind _ = False
typeLiteralKind :: TyLit -> Kind
typeLiteralKind (NumTyLit {}) = naturalTy
typeLiteralKind (StrTyLit {}) = typeSymbolKind
+typeLiteralKind (CharTyLit {}) = charTy
-- | Returns True if a type is levity polymorphic. Should be the same
-- as (isKindLevPoly . typeKind) but much faster.
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 8c18a13eb6..1437208925 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -259,6 +259,7 @@ toIfaceTyCon_name n = IfaceTyCon n info
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
+toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
----------------
toIfaceCoercion :: Coercion -> IfaceCoercion
diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs
index 90d1c61594..d9363fe2e4 100644
--- a/compiler/GHC/Data/FastString.hs
+++ b/compiler/GHC/Data/FastString.hs
@@ -72,6 +72,7 @@ module GHC.Data.FastString
-- ** Deconstruction
unpackFS, -- :: FastString -> String
+ unconsFS, -- :: FastString -> Maybe (Char, FastString)
-- ** Encoding
zEncodeFS,
@@ -608,6 +609,12 @@ headFS fs = head $ unpackFS fs
consFS :: Char -> FastString -> FastString
consFS c fs = mkFastString (c : unpackFS fs)
+unconsFS :: FastString -> Maybe (Char, FastString)
+unconsFS fs =
+ case unpackFS fs of
+ [] -> Nothing
+ (chr : str) -> Just (chr, mkFastString str)
+
uniqueOfFS :: FastString -> Int
uniqueOfFS fs = uniq fs
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 7219ac381b..e90f0a9c0f 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -62,6 +62,7 @@ module GHC.Hs.Utils(
-- * Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
+ mkHsCharPrimLit,
-- * Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
@@ -412,6 +413,9 @@ mkHsString s = HsString NoSourceText (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)
+mkHsCharPrimLit :: Char -> HsLit (GhcPass p)
+mkHsCharPrimLit c = HsChar NoSourceText c
+
{-
************************************************************************
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 664ce3edb4..6ac30e599a 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -53,7 +53,7 @@ import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Multiplicity
-import GHC.Builtin.Types ( naturalTy, typeSymbolKind )
+import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var.Set
@@ -1306,6 +1306,7 @@ ds_ev_typeable ty (EvTypeableTyLit ev)
-- of typeSymbolTypeRep :: KnownSymbol a => TypeRep a
tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepName
| ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+ | ty_kind `eqType` charTy = typeCharTypeRepName
| otherwise = panic "dsEvTypeable: unknown type lit kind"
ds_ev_typeable ty ev
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 2851a2862f..767914127a 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1418,6 +1418,9 @@ repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
; rep2 strTyLitName [s']
}
+repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c)
+ ; rep2 charTyLitName [c']
+ }
-- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn)
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 1e83aa2f10..4cb9178f98 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -190,6 +190,7 @@ type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
+ | IfaceCharTyLit Char
deriving (Eq)
type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis
@@ -1619,6 +1620,7 @@ pprTuple ctxt_prec sort promoted args =
pprIfaceTyLit :: IfaceTyLit -> SDoc
pprIfaceTyLit (IfaceNumTyLit n) = integer n
pprIfaceTyLit (IfaceStrTyLit n) = text (show n)
+pprIfaceTyLit (IfaceCharTyLit c) = text (show c)
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
pprIfaceCoercion = ppr_co topPrec
@@ -1766,8 +1768,9 @@ instance Outputable IfaceTyLit where
ppr = pprIfaceTyLit
instance Binary IfaceTyLit where
- put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
- put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
+ put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
+ put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
+ put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh n
get bh =
do tag <- getByte bh
@@ -1776,6 +1779,8 @@ instance Binary IfaceTyLit where
; return (IfaceNumTyLit n) }
2 -> do { n <- get bh
; return (IfaceStrTyLit n) }
+ 3 -> do { n <- get bh
+ ; return (IfaceCharTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceAppArgs where
@@ -2108,6 +2113,7 @@ instance NFData IfaceTyLit where
rnf = \case
IfaceNumTyLit f1 -> rnf f1
IfaceStrTyLit f1 -> rnf f1
+ IfaceCharTyLit f1 -> rnf f1
instance NFData IfaceCoercion where
rnf = \case
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 862112060c..ded7ab007e 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1347,6 +1347,7 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
{-
%************************************************************************
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 7997f5d182..4b165b1586 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2188,6 +2188,8 @@ atype :: { LHsType GhcPs }
[mos $1,mcs $5] }
| INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)
(il_value (getINTEGER $1)) }
+ | CHAR { sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)
+ (getCHAR $1) }
| STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)
(getSTRING $1) }
| '_' { sL1 $1 $ mkAnonWildCardTy }
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 2a6f82589d..b0e82ced7a 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -690,6 +690,7 @@ rnHsTyKi env tyLit@(HsTyLit _ t)
where
negLit (HsStrTy _ _) = False
negLit (HsNumTy _ i) = i < 0
+ negLit (HsCharTy _ _) = False
negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
rnHsTyKi env (HsAppTy _ ty1 ty2)
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index cacb783a16..ddd8a8a988 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -899,6 +899,7 @@ getTyLitDescription l =
case l of
NumTyLit n -> show n
StrTyLit n -> show n
+ CharTyLit n -> show n
--------------------------------------
-- CmmInfoTable-related things
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 39b18e063c..698f81185d 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -1225,6 +1225,9 @@ tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
= do { checkWiredInTyCon typeSymbolKindCon
; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
+tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind
+ = do { checkWiredInTyCon charTyCon
+ ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }
--------- Wildcards
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 4e26509606..e04f22be8f 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -2162,6 +2162,7 @@ reify_for_all argf ty
reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
+reifyTyLit (CharTyLit c) = return (TH.CharTyLit c)
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index d15777cc5f..54749efcbf 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -39,7 +39,7 @@ import GHC.Types.Id
import GHC.Core.Predicate
import GHC.Core.InstEnv
import GHC.Core.Type
-import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )
+import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
@@ -141,6 +141,8 @@ matchGlobalInst dflags short_cut clas tys
= matchKnownNat dflags short_cut clas tys
| cls_name == knownSymbolClassName
= matchKnownSymbol dflags short_cut clas tys
+ | cls_name == knownCharClassName
+ = matchKnownChar dflags short_cut clas tys
| isCTupleClass clas = matchCTuple clas tys
| cls_name == typeableClassName = matchTypeable clas tys
| clas `hasKey` heqTyConKey = matchHeteroEquality tys
@@ -377,6 +379,16 @@ matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys
-- See Note [Fabricating Evidence for Literals in Backpack] for why
-- this lookup into the instance environment is required.
+matchKnownChar :: DynFlags
+ -> Bool -- True <=> caller is the short-cut solver
+ -- See Note [Shortcut solving: overlap]
+ -> Class -> [Type] -> TcM ClsInstResult
+matchKnownChar _ _ clas [ty] -- clas = KnownChar
+ | Just s <- isCharLitTy ty = makeLitDict clas ty (mkCharExpr s)
+matchKnownChar df sc clas tys = matchInstEnv df sc clas tys
+ -- See Note [Fabricating Evidence for Literals in Backpack] for why
+ -- this lookup into the instance environment is required.
+
makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
-- makeLitDict adds a coercion that will convert the literal into a dictionary
-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]
@@ -424,6 +436,7 @@ matchTypeable clas [k,t] -- clas = Typeable
-- Now cases that do work
| k `eqType` naturalTy = doTyLit knownNatClassName t
| k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t
+ | k `eqType` charTy = doTyLit knownCharClassName t
| tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon []
| Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret
| Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
index e4eb7a1b2d..0f0b7a0a11 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ b/compiler/GHC/Tc/Instance/Typeable.hs
@@ -371,6 +371,7 @@ data TypeableStuff
, kindRepTYPEDataCon :: DataCon
, kindRepTypeLitSDataCon :: DataCon
, typeLitSymbolDataCon :: DataCon
+ , typeLitCharDataCon :: DataCon
, typeLitNatDataCon :: DataCon
}
@@ -388,6 +389,7 @@ collect_stuff = do
kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName
typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName
+ typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName
trNameLit <- mkTrNameLit
return Stuff {..}
@@ -611,6 +613,11 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
`nlHsApp` nlHsDataCon typeLitSymbolDataCon
`nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
+ new_kind_rep (LitTy (CharTyLit c))
+ = return $ nlHsDataCon kindRepTypeLitSDataCon
+ `nlHsApp` nlHsDataCon typeLitCharDataCon
+ `nlHsApp` nlHsLit (mkHsCharPrimLit c)
+
-- See Note [Typeable instances for casted types]
new_kind_rep (CastTy ty co)
= pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index 6f009e9065..c928433a0e 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -1171,6 +1171,7 @@ getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t)
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)
getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm
+getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n)
{- *********************************************************************
* *
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 49fc1bd912..8a9ea3486c 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1729,6 +1729,7 @@ split_ty_app ty = go ty []
cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
+cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c
{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
application @x `op` y@. The produced tree of infix types will be right-biased,
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 1579eeb5a8..aed156aa8e 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -8,6 +8,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+#if MIN_VERSION_base(4,16,0)
+#define HAS_TYPELITCHAR
+#endif
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs
index 580b245ded..c5b89bf35a 100644
--- a/compiler/GHC/Utils/Binary/Typeable.hs
+++ b/compiler/GHC/Utils/Binary/Typeable.hs
@@ -5,6 +5,9 @@
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{-# OPTIONS_GHC -Wno-orphans #-}
+#if MIN_VERSION_base(4,16,0)
+#define HAS_TYPELITCHAR
+#endif
-- | Orphan Binary instances for Data.Typeable stuff
module GHC.Utils.Binary.Typeable
@@ -177,11 +180,17 @@ instance Binary KindRep where
instance Binary TypeLitSort where
put_ bh TypeLitSymbol = putByte bh 0
put_ bh TypeLitNat = putByte bh 1
+#if defined(HAS_TYPELITCHAR)
+ put_ bh TypeLitChar = putByte bh 2
+#endif
get bh = do
tag <- getByte bh
case tag of
0 -> pure TypeLitSymbol
1 -> pure TypeLitNat
+#if defined(HAS_TYPELITCHAR)
+ 2 -> pure TypeLitChar
+#endif
_ -> fail "Binary.putTypeLitSort: invalid tag"
putTypeRep :: BinHandle -> TypeRep a -> IO ()
@@ -212,4 +221,3 @@ instance Binary Serialized where
the_type <- get bh
bytes <- get bh
return (Serialized the_type bytes)
-