Commit 5851f847 authored by Iavor S. Diatchki's avatar Iavor S. Diatchki

Add support for type-level "strings".

These are types that look like "this" and "that".
They are of kind `Symbol`, defined in module `GHC.TypeLits`.

For each type-level symbol `X`, we have a singleton type, `TSymbol X`.

The value of the singleton type can be named with the overloaded
constant `tSymbol`.  Here is an example:

tSymbol :: TSymbol "Hello"
parent 9c157522
......@@ -1107,5 +1107,6 @@ getTyDescription ty
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumberTyLit n -> show n
NumTyLit n -> show n
StrTyLit n -> show n
\end{code}
......@@ -873,7 +873,8 @@ getTyDescription ty
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumberTyLit n -> show n
NumTyLit n -> show n
StrTyLit n -> show n
--------------------------------------
-- CmmInfoTable-related things
......
......@@ -855,10 +855,12 @@ lintType (ForAllTy tv ty)
---
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumberTyLit n)
lintTyLit (NumTyLit n)
| n >= 0 = return ()
| otherwise = failWithL msg
where msg = ptext (sLit "Negative type literal:") <+> integer n
lintTyLit (StrTyLit _) = return ()
----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
......
......@@ -30,6 +30,7 @@ import TypeRep
import Var
import UniqFM
import Unique( Unique )
import FastString(FastString)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
......@@ -553,24 +554,28 @@ fdT k m = foldTM k (tm_var m)
------------------------
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a }
data TyLitMap a = TLM { tlm_number :: Map.Map Integer a
, tlm_string :: Map.Map FastString a
}
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = TLM { tlm_number = Map.empty }
emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
NumberTyLit n -> tlm_number >.> Map.lookup n
NumTyLit n -> tlm_number >.> Map.lookup n
StrTyLit n -> tlm_string >.> Map.lookup n
xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
xtTyLit l f m =
case l of
NumberTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }
NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }
StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n }
foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
foldTyLit l m x = Map.fold l x (tlm_number m)
foldTyLit l m = flip (Map.fold l) (tlm_string m)
. flip (Map.fold l) (tlm_number m)
\end{code}
......
......@@ -737,7 +737,10 @@ dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps`
errorId = rUNTIME_ERROR_ID
litMsg = Lit (MachStr msg)
dsEvTerm (EvInteger n) = mkIntegerExpr n
dsEvTerm (EvLit l) =
case l of
EvNum n -> mkIntegerExpr n
EvStr s -> mkStringExprFS s
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
......
......@@ -22,6 +22,7 @@ module HsTypes (
HsContext, LHsContext,
HsQuasiQuote(..),
HsTyWrapper(..),
HsTyLit(..),
LBangType, BangType, HsBang(..),
getBangType, getBangStrictness,
......@@ -181,11 +182,17 @@ data HsType name
[PostTcKind] -- See Note [Promoted lists and tuples]
[LHsType name]
| HsNumberTy Integer -- A promoted numeric literal.
| HsTyLit HsTyLit -- A promoted numeric literal.
| HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output
deriving (Data, Typeable)
data HsTyLit
= HsNumTy Integer
| HsStrTy FastString
deriving (Data, Typeable)
data HsTyWrapper
= WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn
deriving (Data, Typeable)
......@@ -568,7 +575,7 @@ ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsNumberTy n) = integer n
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
= ppr_mono_ty ctxt_prec ty
......@@ -620,6 +627,11 @@ ppr_fun_ty ctxt_prec ty1 ty2
--------------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
--------------------------
ppr_tylit :: HsTyLit -> SDoc
ppr_tylit (HsNumTy i) = integer i
ppr_tylit (HsStrTy s) = text (show s)
\end{code}
......@@ -1075,13 +1075,16 @@ instance Binary IfaceType where
_ -> panic ("get IfaceType " ++ show h)
instance Binary IfaceTyLit where
put_ bh (IfaceNumberTyLit n) = putByte bh 1 >> put_ bh n
put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n
put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n
get bh =
do tag <- getByte bh
case tag of
1 -> do { n <- get bh
; return (IfaceNumberTyLit n) }
; return (IfaceNumTyLit n) }
2 -> do { n <- get bh
; return (IfaceStrTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceTyCon where
......
......@@ -90,7 +90,8 @@ type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumberTyLit Integer
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
data IfaceTyCon -- Encodes type constructors, kind constructors
-- coercion constructors, the lot
......@@ -310,7 +311,8 @@ ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc)
ppr_tc tc = ppr tc
ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumberTyLit n) = integer n
ppr_tylit (IfaceNumTyLit n) = integer n
ppr_tylit (IfaceStrTyLit n) = text (show n)
-------------------
instance Outputable IfaceTyCon where
......@@ -417,7 +419,8 @@ toIfaceWiredInTyCon tc nm
| otherwise = IfaceTc nm
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumberTyLit x) = IfaceNumberTyLit x
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x
----------------
toIfaceTypes :: [Type] -> [IfaceType]
......
......@@ -870,7 +870,8 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
-----------------------------------------
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumberTyLit n) = return (NumberTyLit n)
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
\end{code}
%************************************************************************
......
......@@ -1071,7 +1071,8 @@ atype :: { LHsType RdrName }
| SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
| SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 }
| '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) }
| INTEGER { LL $ HsNumberTy $ getINTEGER $1 }
| INTEGER { LL $ HsTyLit $ HsNumberTy $ getINTEGER $1 }
| STRING { LL $ HsTyLit $ HsStringTy $ getSTRING $1 }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
......
......@@ -143,7 +143,7 @@ extract_lty (L loc ty) acc
HsDocTy ty _ -> extract_lty ty acc
HsExplicitListTy _ tys -> extract_ltys tys acc
HsExplicitTupleTy _ tys -> extract_ltys tys acc
HsNumberTy _ -> acc
HsTyLit _ -> acc
HsWrapTy _ _ -> panic "extract_lty"
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
......
......@@ -275,7 +275,9 @@ basicKnownKeyNames
-- Type-level naturals
typeNatKindConName,
typeStringKindConName,
typeNatClassName,
typeStringClassName,
typeNatLeqClassName,
typeNatAddTyFamName,
typeNatMulTyFamName,
......@@ -341,7 +343,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
cONTROL_EXCEPTION_BASE, gHC_TYPENATS :: Module
cONTROL_EXCEPTION_BASE, gHC_TYPELITS :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
......@@ -393,7 +395,7 @@ gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
rANDOM = mkBaseModule (fsLit "System.Random")
gHC_EXTS = mkBaseModule (fsLit "GHC.Exts")
cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats")
gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
......@@ -1049,15 +1051,19 @@ randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey
isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey
-- Type-level naturals
typeNatKindConName,
typeNatClassName, typeNatLeqClassName,
typeNatKindConName, typeStringKindConName,
typeNatClassName, typeStringClassName, typeNatLeqClassName,
typeNatAddTyFamName, typeNatMulTyFamName, typeNatExpTyFamName :: Name
typeNatKindConName = tcQual gHC_TYPENATS (fsLit "Nat") typeNatKindConNameKey
typeNatClassName = clsQual gHC_TYPENATS (fsLit "NatI") typeNatClassNameKey
typeNatLeqClassName = clsQual gHC_TYPENATS (fsLit ":<=") typeNatLeqClassNameKey
typeNatAddTyFamName = tcQual gHC_TYPENATS (fsLit ":+") typeNatAddTyFamNameKey
typeNatMulTyFamName = tcQual gHC_TYPENATS (fsLit ":*") typeNatMulTyFamNameKey
typeNatExpTyFamName = tcQual gHC_TYPENATS (fsLit ":^") typeNatExpTyFamNameKey
typeNatKindConName = tcQual gHC_TYPELITS (fsLit "Nat") typeNatKindConNameKey
typeStringKindConName = tcQual gHC_TYPELITS (fsLit "Symbol")
typeStringKindConNameKey
typeNatClassName = clsQual gHC_TYPELITS (fsLit "NatI") typeNatClassNameKey
typeStringClassName = clsQual gHC_TYPELITS (fsLit "SymbolI")
typeStringClassNameKey
typeNatLeqClassName = clsQual gHC_TYPELITS (fsLit "<=") typeNatLeqClassNameKey
typeNatAddTyFamName = tcQual gHC_TYPELITS (fsLit "+") typeNatAddTyFamNameKey
typeNatMulTyFamName = tcQual gHC_TYPELITS (fsLit "*") typeNatMulTyFamNameKey
typeNatExpTyFamName = tcQual gHC_TYPELITS (fsLit "^") typeNatExpTyFamNameKey
-- dotnet interop
objectTyConName :: Name
......@@ -1173,9 +1179,10 @@ datatypeClassKey = mkPreludeClassUnique 39
constructorClassKey = mkPreludeClassUnique 40
selectorClassKey = mkPreludeClassUnique 41
typeNatClassNameKey, typeNatLeqClassNameKey :: Unique
typeNatClassNameKey, typeStringClassNameKey, typeNatLeqClassNameKey :: Unique
typeNatClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43
typeStringClassNameKey = mkPreludeClassUnique 43
typeNatLeqClassNameKey = mkPreludeClassUnique 44
\end{code}
%************************************************************************
......@@ -1359,13 +1366,14 @@ repTyConKey = mkPreludeTyConUnique 155
rep1TyConKey = mkPreludeTyConUnique 156
-- Type-level naturals
typeNatKindConNameKey,
typeNatKindConNameKey, typeStringKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey
:: Unique
typeNatKindConNameKey = mkPreludeTyConUnique 160
typeNatAddTyFamNameKey = mkPreludeTyConUnique 161
typeNatMulTyFamNameKey = mkPreludeTyConUnique 162
typeNatExpTyFamNameKey = mkPreludeTyConUnique 163
typeNatKindConNameKey = mkPreludeTyConUnique 160
typeStringKindConNameKey = mkPreludeTyConUnique 161
typeNatAddTyFamNameKey = mkPreludeTyConUnique 162
typeNatMulTyFamNameKey = mkPreludeTyConUnique 163
typeNatExpTyFamNameKey = mkPreludeTyConUnique 164
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
......
......@@ -38,7 +38,7 @@ module TysPrim(
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind,
typeNatKind, typeStringKind,
funTyCon, funTyConName,
primTyCons,
......@@ -345,6 +345,8 @@ constraintKind = kindTyConType constraintKindTyCon
typeNatKind :: Kind
typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName tySuperKind)
typeStringKind :: Kind
typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName tySuperKind)
-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
mkArrowKind :: Kind -> Kind -> Kind
......
......@@ -88,7 +88,7 @@ extractHsTyNames ty
-- but I don't think it matters
get (HsExplicitListTy _ tys) = extractHsTyNames_s tys
get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys
get (HsNumberTy _) = emptyNameSet
get (HsTyLit _) = emptyNameSet
get (HsWrapTy {}) = panic "extractHsTyNames"
extractHsTyNames_s :: [LHsType Name] -> NameSet
......
......@@ -223,10 +223,10 @@ rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
-- 1. Perhaps we should use a separate extension here?
-- 2. Check that the integer is positive?
rnHsTyKi isType _ numberTy@(HsNumberTy n) = do
poly_kinds <- xoptM Opt_PolyKinds
unless (poly_kinds || isType) (addErr (polyKindsErr numberTy))
return (HsNumberTy n)
rnHsTyKi isType _ tyLit@(HsTyLit t) = do
data_kinds <- xoptM Opt_DataKinds
unless (data_kinds || isType) (addErr (polyKindsErr tyLit))
return (HsTyLit t)
rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
ty1' <- rnLHsTyKi isType doc ty1
......@@ -271,6 +271,7 @@ rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
do tys' <- mapM (rnLHsType doc) tys
return (HsExplicitTupleTy kis tys')
--------------
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
......
......@@ -17,6 +17,7 @@ module TcEvidence (
EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast,
EvLit(..),
-- TcCoercion
TcCoercion(..),
......@@ -470,11 +471,18 @@ data EvTerm
-- dictionaries, even though the former have no
-- selector Id. We count up from _0_
| EvKindCast EvVar TcCoercion -- See Note [EvKindCast]
| EvInteger Integer -- The dictionary for class "NatI"
-- Note [EvInteger]
| EvLit EvLit -- The dictionary for class "NatI"
-- Note [EvLit]
deriving( Data.Data, Data.Typeable)
data EvLit
= EvNum Integer
| EvStr FastString
deriving( Data.Data, Data.Typeable)
\end{code}
Note [EvKindCast]
......@@ -510,38 +518,37 @@ Conclusion: a new wanted coercion variable should be made mutable.
from super classes will be "given" and hence rigid]
Note [EvInteger]
~~~~~~~~~~~~~~~~
A part of the type-level naturals implementation is the class "NatI",
which provides a "smart" constructor for defining singleton values.
newtype NatS (n :: Nat) = NatS Integer
class NatI n where
natS :: NatS n
Conceptually, this class has infinitely many instances:
instance NatI 0 where natS = NatS 0
instance NatI 1 where natS = NatS 1
instance NatI 2 where natS = NatS 2
...
In practice, we solve "NatI" predicates in the type-checker because we can't
have infinately many instances. The evidence (aka "dictionary")
for "NatI n" is of the form "EvInteger n".
We make the following assumptions about dictionaries in GHC:
1. The "dictionary" for classes with a single method---like NatI---is
a newtype for the type of the method, so using a evidence amounts
to a coercion, and
2. Newtypes use the same representation as their definition types.
So, the evidence for "NatI" is just an integer wrapped in 2 newtypes:
one to make it into a "NatS" value, and another to make it into "NatI" evidence.
Note [EvLit]
~~~~~~~~~~~~
A part of the type-level naturals implementation is the class "NatI",
which provides a "smart" constructor for defining singleton values.
newtype TNat (n :: Nat) = TNat Integer
class NatI n where
tNat :: TNat n
Conceptually, this class has infinitely many instances:
instance NatI 0 where natS = TNat 0
instance NatI 1 where natS = TNat 1
instance NatI 2 where natS = TNat 2
...
In practice, we solve "NatI" predicates in the type-checker because we can't
have infinately many instances. The evidence (aka "dictionary")
for "NatI n" is of the form "EvLit (EvNum n)".
We make the following assumptions about dictionaries in GHC:
1. The "dictionary" for classes with a single method---like NatI---is
a newtype for the type of the method, so using a evidence amounts
to a coercion, and
2. Newtypes use the same representation as their definition types.
So, the evidence for "NatI" is just an integer wrapped in 2 newtypes:
one to make it into a "TNat" value, and another to make it into "NatI" evidence.
\begin{code}
mkEvCast :: EvVar -> TcCoercion -> EvTerm
mkEvCast ev lco
......@@ -571,7 +578,7 @@ evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
evVarsOfTerm (EvTupleMk evs) = evs
evVarsOfTerm (EvDelayedError _ _) = []
evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co)
evVarsOfTerm (EvInteger _) = []
evVarsOfTerm (EvLit _) = []
\end{code}
......@@ -631,8 +638,12 @@ instance Outputable EvTerm where
ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
ppr (EvInteger n) = integer n
ppr (EvLit l) = ppr l
ppr (EvDelayedError ty msg) = ptext (sLit "error")
<+> sep [ char '@' <> ppr ty, ppr msg ]
instance Outputable EvLit where
ppr (EvNum n) = integer n
ppr (EvStr s) = text (show s)
\end{code}
......@@ -1112,7 +1112,7 @@ zonkEvTerm env (EvKindCast v co) = ASSERT( isId v)
zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n)
zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs))
zonkEvTerm _ (EvInteger n) = return (EvInteger n)
zonkEvTerm _ (EvLit l) = return (EvLit l)
zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
zonkEvTerm env (EvDFunApp df tys tms)
= do { tys' <- zonkTcTypeToTypes env tys
......
......@@ -520,13 +520,17 @@ kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do
checkExpectedKind ty tupleKi exp_kind
return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s))
kc_hs_type ty@(HsNumberTy n) exp_kind = do
checkExpectedKind ty typeNatKind exp_kind
return (HsNumberTy n)
kc_hs_type ty@(HsTyLit tl) exp_kind = do
let k = case tl of
HsNumTy _ -> typeNatKind
HsStrTy _ -> typeStringKind
checkExpectedKind ty k exp_kind
return ty
kc_hs_type (HsWrapTy {}) _exp_kind =
panic "kc_hs_type HsWrapTy" -- We kind checked something twice
---------------------------
kcApps :: Outputable a
=> a
......@@ -759,7 +763,9 @@ ds_type (HsExplicitTupleTy kis tys) = do
tys' <- mapM dsHsType tys
return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
ds_type (HsNumberTy n) = return (mkNumberTy n)
ds_type (HsTyLit tl) = return $ case tl of
HsNumTy n -> mkNumLitTy n
HsStrTy s -> mkStrLitTy s
ds_type (HsWrapTy (WpKiApps kappas) ty) = do
tau <- ds_type ty
......
......@@ -26,7 +26,7 @@ import Id
import Var
import TcType
import PrelNames (typeNatClassName)
import PrelNames (typeNatClassName, typeStringClassName)
import Class
import TyCon
......@@ -1777,7 +1777,10 @@ matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResu
matchClassInst _ clas [ ty ] _
| className clas == typeNatClassName
, Just n <- isNumberTy ty = return (GenInst [] (EvInteger n))
, Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n
| className clas == typeStringClassName
, Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s
matchClassInst inerts clas tys loc
......
......@@ -808,7 +808,8 @@ getDFunTyKey (FunTy _ _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumberTyLit n) = mkOccName Name.varName (show n)
getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n)
getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm
\end{code}
......
......@@ -18,7 +18,7 @@ module Kind (
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind,
typeNatKind, typeStringKind,
-- Kind constructors...
anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
......
......@@ -42,7 +42,8 @@ module Type (
mkPiKinds, mkPiType, mkPiTypes,
applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
mkLiteralTy, mkNumberTyLit, mkNumberTy, isNumberTy,
mkNumLitTy, isNumLitTy,
mkStrLitTy, isStrLitTy,
-- (Newtypes)
newTyConInstRhs, carefullySplitNewType_maybe,
......@@ -407,21 +408,23 @@ splitAppTys ty = split ty ty []
LitTy
~~~~~~~~~
~~~~~
\begin{code}
mkLiteralTy :: TyLit -> Type
mkLiteralTy = LitTy
mkNumLitTy :: Integer -> Type
mkNumLitTy n = LitTy (NumTyLit n)
mkNumberTyLit :: Integer -> TyLit
mkNumberTyLit = NumberTyLit
isNumLitTy :: Type -> Maybe Integer
isNumLitTy (LitTy (NumTyLit n)) = Just n
isNumLitTy _ = Nothing
mkNumberTy :: Integer -> Type
mkNumberTy n = mkLiteralTy (mkNumberTyLit n)
mkStrLitTy :: FastString -> Type
mkStrLitTy s = LitTy (StrTyLit s)
isStrLitTy :: Type -> Maybe FastString
isStrLitTy (LitTy (StrTyLit s)) = Just s
isStrLitTy _ = Nothing
isNumberTy :: Type -> Maybe Integer
isNumberTy (LitTy (NumberTyLit n)) = Just n
isNumberTy _ = Nothing
\end{code}
......@@ -1592,7 +1595,8 @@ typeKind (FunTy _arg res)
typeLiteralKind :: TyLit -> Kind
typeLiteralKind l =
case l of
NumberTyLit _ -> typeNatKind
NumTyLit _ -> typeNatKind
StrTyLit _ -> typeStringKind
\end{code}
......
......@@ -121,7 +121,8 @@ data Type
-- NOTE: Other parts of the code assume that type literals do not contain
-- types or type variables.
data TyLit
= NumberTyLit Integer
= NumTyLit Integer
| StrTyLit FastString
deriving (Eq, Ord, Data.Data, Data.Typeable)
type KindOrType = Type -- See Note [Arguments to type constructors]
......@@ -574,7 +575,10 @@ ppr_tvar tv -- Note [Infix type variables]
= parenSymOcc (getOccName tv) (ppr tv)
ppr_tylit :: Prec -> TyLit -> SDoc
ppr_tylit _ (NumberTyLit n) = integer n
ppr_tylit _ tl =
case tl of
NumTyLit n -> integer n
StrTyLit s -> text (show s)
-------------------
pprForAll :: [TyVar] -> SDoc
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment