diff options
author | Daniel Rogozin <daniel.rogozin@serokell.io> | 2020-05-27 13:35:24 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-02-06 09:26:51 -0500 |
commit | 7f3524efcbd58ca6837ec0ffca6ddd121d64e4de (patch) | |
tree | aa296d28ed6475799ef369b0608736afcb467495 | |
parent | 640a3ece333d1b0d0af8f353c3e1df9dd0cb9ef3 (diff) | |
download | haskell-7f3524efcbd58ca6837ec0ffca6ddd121d64e4de.tar.gz |
The Char kind (#11342)
Co-authored-by: Rinat Stryungis <rinat.stryungis@serokell.io>
Implement GHC Proposal #387
* Parse char literals 'x' at the type level
* New built-in type families CmpChar, ConsSymbol, UnconsSymbol
* New KnownChar class (cf. KnownSymbol and KnownNat)
* New SomeChar type (cf. SomeSymbol and SomeNat)
* CharTyLit support in template-haskell
Updated submodules: binary, haddock.
Metric Decrease:
T5205
haddock.base
Metric Increase:
Naperian
T13035
49 files changed, 666 insertions, 131 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) - diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 6b0d61d025..0427fd65f3 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -910,6 +910,7 @@ type HsCoreTy = Type data HsTyLit = HsNumTy SourceText Integer | HsStrTy SourceText FastString + | HsCharTy SourceText Char deriving Data -- | Denotes the type of arrows in the surface language @@ -1302,3 +1303,4 @@ instance Outputable HsTyLit where ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index 1e73770c5d..a51875d3f4 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -166,3 +166,16 @@ Runtime system The ``Numeric`` module recieves ``showBin`` and ``readBin`` to show and read integer numbers in binary. +- ``Char`` gets type-level support by analogy with strings and natural numbers. + We extend the ``GHC.TypeLits`` module with these built-in type-families: :: + + type family CmpChar (a :: Char) (b :: Char) :: Ordering + type family ConsSymbol (a :: Char) (b :: Symbol) :: Symbol + type family UnconsSymbol (a :: Symbol) :: Maybe (Char, Symbol) + + and with the type class ``KnownChar`` (and such additional functions as ``charVal`` and ``charVal'``): :: + + class KnownChar (n :: Char) + + charVal :: forall n proxy. KnownChar n => proxy n -> Char + charVal' :: forall n. KnownChar n => Proxy# n -> Char diff --git a/docs/users_guide/exts/type_literals.rst b/docs/users_guide/exts/type_literals.rst index 202577668d..c019426444 100644 --- a/docs/users_guide/exts/type_literals.rst +++ b/docs/users_guide/exts/type_literals.rst @@ -3,11 +3,11 @@ Type-Level Literals =================== -GHC supports numeric and string literals at the type level, giving +GHC supports numeric, string, and character literals at the type level, giving convenient access to a large number of predefined type-level constants. -Numeric literals are of kind ``Natural``, while string literals are of kind -``Symbol``. This feature is enabled by the :extension:`DataKinds` language -extension. +Numeric literals are of kind ``Natural``, string literals are of kind ``Symbol``, +and character literals are of kind ``Char``. +This feature is enabled by the :extension:`DataKinds` language extension. The kinds of the literals and all other low-level operations for this feature are defined in modules ``GHC.TypeLits`` and ``GHC.TypeNats``. @@ -127,5 +127,3 @@ the type level: GHC.TypeLits> natVal (lg (Proxy :: Proxy 2) (Proxy :: Proxy 8)) 3 - - diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 547fd13d62..008ac1b81b 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -79,7 +79,7 @@ module Data.Typeable.Internal ( -- | These are for internal use only mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, - typeSymbolTypeRep, typeNatTypeRep, + typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep ) where import GHC.Prim ( FUN ) @@ -90,7 +90,7 @@ import Data.Type.Equality import GHC.List ( splitAt, foldl', elem ) import GHC.Word import GHC.Show -import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol ) +import GHC.TypeLits ( KnownChar, charVal', KnownSymbol, symbolVal', AppendSymbol ) import GHC.TypeNats ( KnownNat, Nat, natVal' ) import Unsafe.Coerce ( unsafeCoerce ) @@ -986,11 +986,17 @@ typeNatTypeRep = typeLitTypeRep (show (natVal' (proxy# @a))) tcNat typeSymbolTypeRep :: forall a. KnownSymbol a => TypeRep a typeSymbolTypeRep = typeLitTypeRep (show (symbolVal' (proxy# @a))) tcSymbol +-- | Used to make `'Typeable' instance for things of kind Char +typeCharTypeRep :: forall a. KnownChar a => TypeRep a +typeCharTypeRep = typeLitTypeRep (show (charVal' (proxy# @a))) tcChar + mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep mkTypeLitFromString TypeLitSymbol s = SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol) mkTypeLitFromString TypeLitNat s = SomeTypeRep $ (typeLitTypeRep s tcNat :: TypeRep Nat) +mkTypeLitFromString TypeLitChar s = + SomeTypeRep $ (typeLitTypeRep s tcChar :: TypeRep Char) tcSymbol :: TyCon tcSymbol = typeRepTyCon (typeRep @Symbol) @@ -998,6 +1004,9 @@ tcSymbol = typeRepTyCon (typeRep @Symbol) tcNat :: TyCon tcNat = typeRepTyCon (typeRep @Nat) +tcChar :: TyCon +tcChar = typeRepTyCon (typeRep @Char) + -- | An internal function, to make representations for type literals. typeLitTypeRep :: forall k (a :: k). (Typeable k) => String -> TyCon -> TypeRep a diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 6cee76b2e3..206fd385ea 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -15,8 +15,8 @@ {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the -primitives needed for working with type-level numbers (the 'Nat' kind) -and strings (the 'Symbol') kind. It also defines the 'TypeError' type +primitives needed for working with type-level numbers (the 'Nat' kind), +strings (the 'Symbol' kind), and characters (the 'Char' kind). It also defines the 'TypeError' type family, a feature that makes use of type-level strings to support user defined type errors. @@ -36,16 +36,18 @@ module GHC.TypeLits -- * Linking type and value level , N.KnownNat, natVal, natVal' , KnownSymbol, symbolVal, symbolVal' - , N.SomeNat(..), SomeSymbol(..) - , someNatVal, someSymbolVal - , N.sameNat, sameSymbol + , KnownChar, charVal, charVal' + , N.SomeNat(..), SomeSymbol(..), SomeChar(..) + , someNatVal, someSymbolVal, someCharVal + , N.sameNat, sameSymbol, sameChar -- * Functions on type literals , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-) , type N.Div, type N.Mod, type N.Log2 , AppendSymbol - , N.CmpNat, CmpSymbol + , N.CmpNat, CmpSymbol, CmpChar + , ConsSymbol, UnconsSymbol -- * User-defined type errors , TypeError @@ -54,7 +56,7 @@ module GHC.TypeLits ) where import GHC.Base(Eq(..), Ord(..), Ordering(..), String, otherwise) -import GHC.Types(Symbol) +import GHC.Types(Symbol, Char) import GHC.Num(Integer, fromInteger) import GHC.Show(Show(..)) import GHC.Read(Read(..)) @@ -100,6 +102,20 @@ symbolVal' _ = case symbolSing :: SSymbol n of data SomeSymbol = forall n. KnownSymbol n => SomeSymbol (Proxy n) -- ^ @since 4.7.0.0 +-- | @since 4.16.0.0 +class KnownChar (n :: Char) where + charSing :: SChar n + +charVal :: forall n proxy. KnownChar n => proxy n -> Char +charVal _ = case charSing :: SChar n of + SChar x -> x + +charVal' :: forall n. KnownChar n => Proxy# n -> Char +charVal' _ = case charSing :: SChar n of + SChar x -> x + +data SomeChar = forall n. KnownChar n => SomeChar (Proxy n) + -- | Convert an integer into an unknown type-level natural. -- -- @since 4.7.0.0 @@ -133,6 +149,26 @@ instance Show SomeSymbol where instance Read SomeSymbol where readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ] + +-- | Convert a character into an unknown type-level char. +-- +-- | @since 4.16.0.0 +someCharVal :: Char -> SomeChar +someCharVal n = withSChar SomeChar (SChar n) Proxy +{-# NOINLINE someCharVal #-} + +instance Eq SomeChar where + SomeChar x == SomeChar y = charVal x == charVal y + +instance Ord SomeChar where + compare (SomeChar x) (SomeChar y) = compare (charVal x) (charVal y) + +instance Show SomeChar where + showsPrec p (SomeChar x) = showsPrec p (charVal x) + +instance Read SomeChar where + readsPrec p xs = [ (someCharVal a, ys) | (a,ys) <- readsPrec p xs ] + -------------------------------------------------------------------------------- -- | Comparison of type-level symbols, as a function. @@ -193,6 +229,24 @@ infixl 6 :<>: type family TypeError (a :: ErrorMessage) :: b where +-- Char-related type families + +-- | Comparison of type-level characters. +-- +-- @since 4.16.0.0 +type family CmpChar (a :: Char) (b :: Char) :: Ordering + +-- | Extending a type-level symbol with a type-level character +-- +-- @since 4.16.0.0 +type family ConsSymbol (a :: Char) (b :: Symbol) :: Symbol + +-- | This type family yields type-level `Just` storing the first character +-- of a symbol and its tail if it is defined and `Nothing` otherwise. +-- +-- @since 4.16.0.0 +type family UnconsSymbol (a :: Symbol) :: Maybe (Char, Symbol) + -------------------------------------------------------------------------------- -- | We either get evidence that this function was instantiated with the @@ -205,6 +259,17 @@ sameSymbol x y | symbolVal x == symbolVal y = Just (unsafeCoerce Refl) | otherwise = Nothing + +-- | We either get evidence that this function was instantiated with the +-- same type-level characters, or 'Nothing'. +-- +-- @since 4.16.0.0 +sameChar :: (KnownChar a, KnownChar b) => + proxy1 a -> proxy2 b -> Maybe (a :~: b) +sameChar x y + | charVal x == charVal y = Just (unsafeCoerce Refl) + | otherwise = Nothing + -------------------------------------------------------------------------------- -- PRIVATE: @@ -216,3 +281,12 @@ data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b) withSSymbol :: (KnownSymbol a => Proxy a -> b) -> SSymbol a -> Proxy a -> b withSSymbol f x y = magicDict (WrapS f) x y + +newtype SChar (s :: Char) = SChar Char + +data WrapC a b = WrapC (KnownChar a => Proxy a -> b) + +-- See Note [q] in "basicType/MkId.hs" +withSChar :: (KnownChar a => Proxy a -> b) + -> SChar a -> Proxy a -> b +withSChar f x y = magicDict (WrapC f) x y diff --git a/libraries/binary b/libraries/binary -Subproject b224410161f112dd1133a787ded9831799589ce +Subproject f797e935ad5bcc082f9cfe4b7a650cf0df3224a diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index dc81a9b8d3..f558619ac1 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -526,6 +526,7 @@ data KindRep = KindRepTyConApp TyCon [KindRep] data TypeLitSort = TypeLitSymbol | TypeLitNat + | TypeLitChar -- Show instance for TyCon found in GHC.Show data TyCon = TyCon WORD64_TY -- ^ Fingerprint (high) diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 1f8175a735..3e05081619 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -61,7 +61,7 @@ module Language.Haskell.TH.Lib ( sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, -- **** Type literals - numTyLit, strTyLit, + numTyLit, strTyLit, charTyLit, -- **** Strictness noSourceUnpackedness, sourceNoUnpack, sourceUnpack, noSourceStrictness, sourceLazy, sourceStrict, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index ed1aa022c5..67017d4926 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -832,6 +832,9 @@ numTyLit n = if n >= 0 then pure (NumTyLit n) strTyLit :: Quote m => String -> m TyLit strTyLit s = pure (StrTyLit s) +charTyLit :: Quote m => Char -> m TyLit +charTyLit c = pure (CharTyLit c) + ------------------------------------------------------------------------------- -- * Kind diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index b19c74f6fb..54f138539f 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -869,6 +869,7 @@ split t = go t [] pprTyLit :: TyLit -> Doc pprTyLit (NumTyLit n) = integer n pprTyLit (StrTyLit s) = text (show s) +pprTyLit (CharTyLit c) = text (show c) instance Ppr TyLit where ppr = pprTyLit diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a3104ed684..6508c07a65 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2562,6 +2562,7 @@ data InjectivityAnn = InjectivityAnn Name [Name] data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @\"Hello\"@ + | CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0 deriving ( Show, Eq, Ord, Data, Generic ) -- | Role annotations diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 356f651fd5..6d6e06b8ce 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -37,6 +37,9 @@ * The types of `ConP` and `conP` have been changed to allow for an additional list of type applications preceding the argument patterns. + * Add support for the `Char` kind (#11342): we extend the `TyLit` data type with + the constructor `CharTyLit` that reflects type-level characters. + ## 2.16.0.0 *TBA* * Add support for tuple sections. (#15843) The type signatures of `TupE` and diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout index 170e17b995..d4e869f073 100644 --- a/testsuite/tests/ghci/scripts/T9181.stdout +++ b/testsuite/tests/ghci/scripts/T9181.stdout @@ -1,9 +1,14 @@ type GHC.TypeLits.AppendSymbol :: GHC.Types.Symbol -> GHC.Types.Symbol -> GHC.Types.Symbol type family GHC.TypeLits.AppendSymbol a b +type GHC.TypeLits.CmpChar :: Char -> Char -> Ordering +type family GHC.TypeLits.CmpChar a b type GHC.TypeLits.CmpSymbol :: GHC.Types.Symbol -> GHC.Types.Symbol -> Ordering type family GHC.TypeLits.CmpSymbol a b +type GHC.TypeLits.ConsSymbol :: Char + -> GHC.Types.Symbol -> GHC.Types.Symbol +type family GHC.TypeLits.ConsSymbol a b type GHC.TypeLits.ErrorMessage :: * data GHC.TypeLits.ErrorMessage = GHC.TypeLits.Text GHC.Types.Symbol @@ -14,10 +19,19 @@ data GHC.TypeLits.ErrorMessage | GHC.TypeLits.ErrorMessage GHC.TypeLits.:$$: GHC.TypeLits.ErrorMessage +type GHC.TypeLits.KnownChar :: Char -> Constraint +class GHC.TypeLits.KnownChar n where + GHC.TypeLits.charSing :: GHC.TypeLits.SChar n + {-# MINIMAL charSing #-} type GHC.TypeLits.KnownSymbol :: GHC.Types.Symbol -> Constraint class GHC.TypeLits.KnownSymbol n where GHC.TypeLits.symbolSing :: GHC.TypeLits.SSymbol n {-# MINIMAL symbolSing #-} +type GHC.TypeLits.SomeChar :: * +data GHC.TypeLits.SomeChar + = forall (n :: Char). + GHC.TypeLits.KnownChar n => + GHC.TypeLits.SomeChar (Data.Proxy.Proxy n) type GHC.TypeLits.SomeSymbol :: * data GHC.TypeLits.SomeSymbol = forall (n :: GHC.Types.Symbol). @@ -26,13 +40,23 @@ data GHC.TypeLits.SomeSymbol type GHC.TypeLits.TypeError :: forall b. GHC.TypeLits.ErrorMessage -> b type family GHC.TypeLits.TypeError a where +type GHC.TypeLits.UnconsSymbol :: GHC.Types.Symbol + -> Maybe (Char, GHC.Types.Symbol) +type family GHC.TypeLits.UnconsSymbol a +GHC.TypeLits.charVal :: GHC.TypeLits.KnownChar n => proxy n -> Char +GHC.TypeLits.charVal' :: + GHC.TypeLits.KnownChar n => GHC.Prim.Proxy# n -> Char GHC.TypeLits.natVal :: GHC.TypeNats.KnownNat n => proxy n -> Integer GHC.TypeLits.natVal' :: GHC.TypeNats.KnownNat n => GHC.Prim.Proxy# n -> Integer +GHC.TypeLits.sameChar :: + (GHC.TypeLits.KnownChar a, GHC.TypeLits.KnownChar b) => + proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) GHC.TypeLits.sameSymbol :: (GHC.TypeLits.KnownSymbol a, GHC.TypeLits.KnownSymbol b) => proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) +GHC.TypeLits.someCharVal :: Char -> GHC.TypeLits.SomeChar GHC.TypeLits.someNatVal :: Integer -> Maybe GHC.TypeNats.SomeNat GHC.TypeLits.someSymbolVal :: String -> GHC.TypeLits.SomeSymbol GHC.TypeLits.symbolVal :: diff --git a/testsuite/tests/th/T11342b.hs b/testsuite/tests/th/T11342b.hs new file mode 100644 index 0000000000..04e2353f3b --- /dev/null +++ b/testsuite/tests/th/T11342b.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} + +module T11342b where + +type X = $( [t| 'x' :: Char |] ) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 7e4f389b84..3dc58ea302 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -345,6 +345,7 @@ test('T10819', [], multimod_compile, ['T10819.hs', '-v0 ' + config.ghc_th_way_flags]) test('T10820', normal, compile_and_run, ['-v0']) test('T11341', normal, compile, ['-v0 -dsuppress-uniques']) +test('T11342b', normal, compile, ['-v0']) test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques']) test('TH_finalizer', normal, compile, ['-v0']) test('TH_finalizer2', diff --git a/testsuite/tests/typecheck/T11342/T11342a.hs b/testsuite/tests/typecheck/T11342/T11342a.hs new file mode 100644 index 0000000000..aae37ee658 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T11342a where + +import Data.Type.Equality + +type A = 'a' :: Char + +t :: 'x' :~: 'x' +t = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342c.hs b/testsuite/tests/typecheck/T11342/T11342c.hs new file mode 100644 index 0000000000..51dc6a634f --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342c.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} + +module T11342c where + +import Data.Typeable +import GHC.TypeLits + +x :: TypeRep +x = typeRep (Proxy :: Proxy 'x') diff --git a/testsuite/tests/typecheck/T11342/T11342d.hs b/testsuite/tests/typecheck/T11342/T11342d.hs new file mode 100644 index 0000000000..9c973d8c8c --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342d.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T11342d where + +import GHC.TypeLits +import Data.Type.Equality + +f1 :: CmpChar 'x' 'x' :~: EQ +f1 = Refl + +f2 :: CmpChar 'x' 'y' :~: LT +f2 = Refl + +f3 :: forall (a :: Char). CmpChar a a :~: EQ +f3 = Refl + +testConsSymbol + :: '[ConsSymbol 'a' "bcd", ConsSymbol ' ' "hi mark"] :~: '["abcd", " hi mark"] +testConsSymbol = Refl + +testUnconsSymbol + :: '[UnconsSymbol "abc", UnconsSymbol "a", UnconsSymbol ""] :~: [Just '( 'a', "bc" ), Just '( 'a', ""), Nothing] +testUnconsSymbol = Refl + +testUncons :: ConsSymbol '\xD800' "foo" :~: "\55296foo" +testUncons = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342e.hs b/testsuite/tests/typecheck/T11342/T11342e.hs new file mode 100644 index 0000000000..33c5e63e57 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342e.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T11342e where + +import GHC.TypeLits ( Symbol, ConsSymbol, UnconsSymbol ) +import Data.Type.Equality ( (:~:)(..) ) + +type Reverse :: Symbol -> Symbol +type family Reverse word where + Reverse word = Reverse1 (UnconsSymbol word) "" + +type Reverse1 :: Maybe (Char, Symbol) -> Symbol -> Symbol +type family Reverse1 xs ys where + Reverse1 Nothing acc = acc + Reverse1 (Just '(x, xs)) acc = Reverse1 (UnconsSymbol xs) (ConsSymbol x acc) + +reverseTest + :: Reverse "tiw fo luos eht si ytiverB" :~: "Brevity is the soul of wit" +reverseTest = Refl + +reverseTest2 :: Reverse (Reverse "know thyself") :~: "know thyself" +reverseTest2 = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342f.hs b/testsuite/tests/typecheck/T11342/T11342f.hs new file mode 100644 index 0000000000..ad59191fb1 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342f.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module T11342f where + +import Data.Proxy +import GHC.TypeLits + +f :: forall str a b. (KnownChar a, KnownSymbol b, ConsSymbol a b ~ str) => (Char, String) +f = (charVal @a Proxy, symbolVal @b Proxy) + +f' :: (Char, String) +f' = f @"hello" + +g :: forall str. (KnownSymbol str, UnconsSymbol str ~ 'Nothing) => String +g = symbolVal @str Proxy + +h :: forall a tail str. (KnownSymbol tail, KnownChar a, UnconsSymbol str ~ 'Just '(a, tail) ) => (Char, String) +h = (charVal @a Proxy, symbolVal @tail Proxy) + +h' :: (Char, String) +h' = h @'h' @"ello" diff --git a/testsuite/tests/typecheck/T11342/all.T b/testsuite/tests/typecheck/T11342/all.T new file mode 100644 index 0000000000..663f2a3b3f --- /dev/null +++ b/testsuite/tests/typecheck/T11342/all.T @@ -0,0 +1,5 @@ +test('T11342a', normal, compile, ['-v0']) +test('T11342c', normal, compile, ['-v0']) +test('T11342d', normal, compile, ['-v0']) +test('T11342e', normal, compile, ['-v0']) +test('T11342f', normal, compile, ['-v0']) diff --git a/utils/haddock b/utils/haddock -Subproject a917dfd29f3103b69378138477514cbfa38558a +Subproject 41964cb2fd54b5a10f8c0f28147015b7d5ad2c0 |