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"

23 files changed, 176 insertions, 104 deletions

diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index fd27684732..d8fd07fead 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -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}
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 7789ae865b..d4ba62c6ca 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -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
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index a8ec371441..6f6e58b25b 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -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
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index 11a30a54c9..5855ed6d93 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -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}
 
 
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 172545daaf..03f0f80082 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -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
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index aa96ed9f5e..a999c238a5 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -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}
 
 
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 94462c5191..8bf6594df5 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -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
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 94e29d732e..77f4b700d2 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -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]
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 5e7d25895a..a081fbe36e 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -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}
 
 %************************************************************************
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b664861c44..c0f5041774 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -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
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 66db883d71..8900f9fdec 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -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]
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 131c86bda2..aa04fe7090 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -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
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 60fad552e8..7634089ded 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -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
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 43494bbded..8df896b5a2 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -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
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index c6c64e8b33..7840c4ab3a 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -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]
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index 8b724a4cac..7a4a1b5843 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -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}
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 934b1be361..bb3a994669 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -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
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 6221bcd270..0df0a9b97c 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -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
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 8e63ecf53b..7c5957f7fb 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -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
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index fb43f15d2e..bf4e1b203c 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -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}
 
 
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index 755bf57942..0acc967507 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -18,7 +18,7 @@ module Kind (
 	anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
-        typeNatKind,
+        typeNatKind, typeStringKind,
 
         -- Kind constructors...
         anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 81075c0e7a..69e91b5975 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -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}
 
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 1ab2f2e788..8c60e79bb2 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -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