diff options
Diffstat (limited to 'compiler/GHC')
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) - |