Extend GHC's type with a representation for type level literals.

Currently, we support only numeric literals but---hopefully---these
modifications should make it fairly easy to add other ones, if necessary.

27 files changed, 200 insertions, 11 deletions

diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index ac047edb89..682d76096b 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -1099,8 +1099,15 @@ getTyDescription ty
       FunTy _ res      	     -> '-' : '>' : fun_result res
       TyConApp tycon _ 	     -> getOccString tycon
       ForAllTy _ ty          -> getTyDescription ty
+      LiteralTy n            -> getTyLitDescription n
     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other	     = getTyDescription other
+
+
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+  case l of
+    NumberTyLit n -> show n
 \end{code}
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 5c0741a65e..d40ff9e1e5 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -864,11 +864,17 @@ getTyDescription ty
       FunTy _ res      	     -> '-' : '>' : fun_result res
       TyConApp tycon _ 	     -> getOccString tycon
       ForAllTy _ ty          -> getTyDescription ty
+      LiteralTy n            -> getTyLitDescription n
     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other	     = getTyDescription other
 
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+  case l of
+    NumberTyLit n -> show n
+
 --------------------------------------
 --   CmmInfoTable-related things
 --------------------------------------
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index fa22e7efea..984e08b8f9 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -846,10 +846,20 @@ lintType ty@(TyConApp tc tys)
   | otherwise
   = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
 
+lintType ty@(LiteralTy l) = lintTyLit l >> return (typeKind ty)
+
 lintType (ForAllTy tv ty)
   = do { lintTyBndrKind tv
        ; addInScopeVar tv (lintType ty) }
 
+---
+
+lintTyLit :: TyLit -> LintM ()
+lintTyLit (NumberTyLit n)
+  | n >= 0    = return ()
+  | otherwise = failWithL msg
+    where msg = ptext (sLit "Negative type literal:") <+> integer n
+
 ----------------
 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
 lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index d8a134ed87..e481886460 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -486,7 +486,10 @@ data TypeMap a
        , tm_app    :: TypeMap (TypeMap a)
        , tm_fun    :: TypeMap (TypeMap a)
        , tm_tc_app :: NameEnv (ListMap TypeMap a)
-       , tm_forall :: TypeMap (BndrMap a) }
+       , tm_forall :: TypeMap (BndrMap a)
+       , tm_tylit  :: TyLitMap a
+       }
+
 
 instance Outputable a => Outputable (TypeMap a) where
   ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m)
@@ -499,7 +502,8 @@ wrapEmptyTypeMap = TM { tm_var  = emptyTM
                       , tm_app  = EmptyTM
                       , tm_fun  = EmptyTM
                       , tm_tc_app = emptyNameEnv
-                      , tm_forall = EmptyTM }
+                      , tm_forall = EmptyTM
+                      , tm_tylit  = emptyTyLitMap }
 
 instance TrieMap TypeMap where
    type Key TypeMap = Type
@@ -519,6 +523,7 @@ lkT env ty m
     go (AppTy t1 t2)     = tm_app    >.> lkT env t1 >=> lkT env t2
     go (FunTy t1 t2)     = tm_fun    >.> lkT env t1 >=> lkT env t2
     go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys
+    go (LiteralTy l)     = tm_tylit  >.> lkTyLit l
     go (ForAllTy tv ty)  = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
 
 -----------------
@@ -535,6 +540,8 @@ xtT env (ForAllTy tv ty)  f  m = m { tm_forall = tm_forall m |> xtT (extendCME e
 xtT env (TyConApp tc tys) f  m = m { tm_tc_app = tm_tc_app m |> xtNamed tc 
                                                  |>> xtList (xtT env) tys f }
 
+xtT _   (LiteralTy l)     f  m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }
+
 fdT :: (a -> b -> b) -> TypeMap a -> b -> b
 fdT _ EmptyTM = \z -> z
 fdT k m = foldTM k (tm_var m)
@@ -542,6 +549,31 @@ fdT k m = foldTM k (tm_var m)
         . foldTM (foldTM k) (tm_fun m)
         . foldTM (foldTM k) (tm_tc_app m)
         . foldTM (foldTM k) (tm_forall m)
+        . foldTyLit k (tm_tylit m)
+
+
+
+------------------------
+data TyLitMap a
+  = EmptyTLM
+  | TLM { tlm_number :: Map.Map Integer a }
+
+emptyTyLitMap :: TyLitMap a
+emptyTyLitMap = EmptyTLM
+
+lkTyLit :: TyLit -> TyLitMap a -> Maybe a
+lkTyLit l =
+  case l of
+    NumberTyLit n -> tlm_number >.> 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 }
+
+foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
+foldTyLit l m x = Map.fold l x (tlm_number m)
+
 \end{code}
 
 
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 792421daa5..15434f0473 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1037,6 +1037,10 @@ instance Binary IfaceType where
     put_ bh (IfaceTyConApp tc tys)
       = do { putByte bh 21; put_ bh tc; put_ bh tys }
 
+    put_ bh (IfaceLiteralTy n)
+      = do { putByte bh 30; put_ bh n }
+
+
     get bh = do
             h <- getByte bh
             case h of
@@ -1076,8 +1080,21 @@ instance Binary IfaceType where
               21 -> do { tc <- get bh; tys <- get bh
                         ; return (IfaceTyConApp tc tys) }
 
+              30 -> do n <- get bh
+                       return (IfaceLiteralTy n)
+
               _  -> panic ("get IfaceType " ++ show h)
 
+instance Binary IfaceTyLit where
+  put_ bh (IfaceNumberTyLit n)  = putByte bh 1 >> put_ bh n
+
+  get bh =
+    do tag <- getByte bh
+       case tag of
+         1 -> do { n <- get bh
+                 ; return (IfaceNumberTyLit n) }
+         _ -> panic ("get IfaceTyLit " ++ show tag)
+
 instance Binary IfaceTyCon where
         -- Int,Char,Bool can't show up here because they can't not be saturated
    put_ bh IfaceIntTc         = putByte bh 1
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 6f59e38736..541f041589 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -808,6 +808,7 @@ freeNamesIfType (IfaceTyVar _)        = emptyNameSet
 freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
 freeNamesIfType (IfaceTyConApp tc ts) =
    freeNamesIfTc tc &&& fnList freeNamesIfType ts
+freeNamesIfType (IfaceLiteralTy _)    = emptyNameSet
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 5441287eef..1565df1bc7 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -17,6 +17,7 @@ module IfaceType (
 	IfExtName, IfLclName, IfIPName,
 
         IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
+        IfaceTyLit(..),
 	IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
 	ifaceTyConName,
 
@@ -83,10 +84,14 @@ data IfaceType	   -- A kind of universal type, used for types, kinds, and coerci
   | IfaceTyConApp IfaceTyCon [IfaceType]  -- Not necessarily saturated
 					  -- Includes newtypes, synonyms, tuples
   | IfaceCoConApp IfaceCoCon [IfaceType]  -- Always saturated
+  | IfaceLiteralTy IfaceTyLit
 
 type IfacePredType = IfaceType
 type IfaceContext = [IfacePredType]
 
+data IfaceTyLit
+  = IfaceNumberTyLit Integer
+
 data IfaceTyCon 	-- Encodes type constructors, kind constructors
      			-- coercion constructors, the lot
   = IfaceTc IfExtName	-- The common case
@@ -241,6 +246,8 @@ ppr_ty :: Int -> IfaceType -> SDoc
 ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
 
+ppr_ty _ (IfaceLiteralTy n) = ppr_tylit n
+
 ppr_ty ctxt_prec (IfaceCoConApp tc tys) 
   = maybeParen ctxt_prec tYCON_PREC 
 	       (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
@@ -302,6 +309,9 @@ ppr_tc :: IfaceTyCon -> SDoc
 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
+
 -------------------
 instance Outputable IfaceTyCon where
   ppr (IfaceIPTc n)  = ppr (IPName n)
@@ -317,6 +327,9 @@ instance Outputable IfaceCoCon where
   ppr IfaceInstCo      = ptext (sLit "Inst")
   ppr (IfaceNthCo d)   = ptext (sLit "Nth:") <> int d
 
+instance Outputable IfaceTyLit where
+  ppr = ppr_tylit
+
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
@@ -362,6 +375,7 @@ toIfaceType (TyVarTy tv)      = IfaceTyVar (toIfaceTyVar tv)
 toIfaceType (AppTy t1 t2)     = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
 toIfaceType (FunTy t1 t2)     = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
 toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (LiteralTy n)     = IfaceLiteralTy (toIfaceTyLit n)
 toIfaceType (ForAllTy tv t)   = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
 
 toIfaceTyVar :: TyVar -> FastString
@@ -402,6 +416,9 @@ toIfaceWiredInTyCon tc nm
   | nm == tySuperKindTyConName      = IfaceSuperKindTc
   | otherwise		            = IfaceTc nm
 
+toIfaceTyLit :: TyLit -> IfaceTyLit
+toIfaceTyLit (NumberTyLit x) = IfaceNumberTyLit x
+
 ----------------
 toIfaceTypes :: [Type] -> [IfaceType]
 toIfaceTypes ts = map toIfaceType ts
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8a279ca3a1..bb6430e02a 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -815,6 +815,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
 tcIfaceType :: IfaceType -> IfL Type
 tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
 tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
+tcIfaceType (IfaceLiteralTy l)    = do { l1 <- tcIfaceTyLit l; return (LiteralTy l1) }
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
@@ -826,6 +827,10 @@ tcIfaceTypes tys = mapM tcIfaceType tys
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
 tcIfaceCtxt sts = mapM tcIfaceType sts
+
+-----------------------------------------
+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
+tcIfaceTyLit (IfaceNumberTyLit n) = return (NumberTyLit n)
 \end{code}
 
 %************************************************************************
@@ -840,6 +845,7 @@ tcIfaceCo (IfaceTyVar n)        = mkCoVarCo <$> tcIfaceCoVar n
 tcIfaceCo (IfaceAppTy t1 t2)    = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
 tcIfaceCo (IfaceFunTy t1 t2)    = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
 tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo t@(IfaceLiteralTy _)  = mkReflCo <$> tcIfaceType t
 tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
 tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
                                   mkForAllCo tv' <$> tcIfaceCo t
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index a3c2c6bb83..911402c59b 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -38,6 +38,7 @@ module TysPrim(
 	anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
+        typeNatKind,
 
         funTyCon, funTyConName,
         primTyCons,
@@ -341,6 +342,11 @@ argTypeKind      = kindTyConType argTypeKindTyCon
 ubxTupleKind     = kindTyConType ubxTupleKindTyCon
 constraintKind   = kindTyConType constraintKindTyCon
 
+ -- XXX: we should probably be using a different type than Word here...
+typeNatKind :: Kind
+typeNatKind = kindTyConType (mkKindTyCon wordTyConName tySuperKind)
+
+
 -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
 mkArrowKind :: Kind -> Kind -> Kind
 mkArrowKind k1 k2 = FunTy k1 k2
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index 0511aa1051..e1781439f6 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -262,6 +262,7 @@ liftTcCoSubstWith tvs cos ty
                              Nothing -> mkTcReflCo ty

     go (AppTy t1 t2)     = mkTcAppCo (go t1) (go t2)

     go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)

+    go ty@(LiteralTy _)  = mkTcReflCo ty

     go (ForAllTy tv ty)  = mkTcForAllCo tv (go ty)

     go (FunTy t1 t2)     = mkTcFunCo (go t1) (go t2)

 \end{code}

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index c040d6d58f..2996ce954c 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -169,6 +169,9 @@ normaliseFfiType' env ty0 = go [] ty0
     go _ ty@(TyVarTy _)
       = return (Refl ty, ty)
 
+    go _ ty@(LiteralTy _)
+      = return (Refl ty, ty)
+
     add_co co rec_nts ty
         = do (co', ty') <- go rec_nts ty
              return (mkTransCo co co', ty')
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 6741e7b360..f9e7d48dec 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -525,8 +525,7 @@ kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do
   return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s))
 
 kc_hs_type ty@(HsNumberTy n) exp_kind = do
-  -- XXX: Temporarily we use the Word type lifted to the kind level.
-  checkExpectedKind ty wordTy exp_kind
+  checkExpectedKind ty typeNatKind exp_kind
   return (HsNumberTy n)
 
 kc_hs_type (HsWrapTy {}) _exp_kind =
@@ -764,8 +763,7 @@ ds_type (HsExplicitTupleTy kis tys) = do
   tys' <- mapM dsHsType tys
   return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
 
-ds_type (HsNumberTy n) =
-  failWithTc (ptext (sLit "ds_type: NumberTy not yet implemenetd"))
+ds_type (HsNumberTy n) = return (mkNumberTy n)
 
 ds_type (HsWrapTy (WpKiApps kappas) ty) = do
   tau <- ds_type ty
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 2bbb2e11eb..852537223f 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -811,6 +811,8 @@ zonkType zonk_tc_tyvar ty
     go (TyConApp tc tys) = do tys' <- mapM go tys
                               return (TyConApp tc tys')
 
+    go (LiteralTy n)     = return (LiteralTy n)
+
     go (FunTy arg res)   = do arg' <- go arg
                               res' <- go res
                               return (FunTy arg' res')
@@ -1079,6 +1081,8 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
     arity_msg   = arityErr "Type synonym" (tyConName tc) tc_arity n_args
     ubx_tup_msg = ubxArgTyErr ty
 
+check_type _ _ (LiteralTy _) = return ()
+
 check_type _ _ ty = pprPanic "check_type" (ppr ty)
 
 ----------------------------------------
@@ -1744,6 +1748,7 @@ fvType :: Type -> [TyVar]
 fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
 fvType (TyVarTy tv)        = [tv]
 fvType (TyConApp _ tys)    = fvTypes tys
+fvType (LiteralTy _)       = []
 fvType (FunTy arg res)     = fvType arg ++ fvType res
 fvType (AppTy fun arg)     = fvType fun ++ fvType arg
 fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
@@ -1756,6 +1761,7 @@ sizeType :: Type -> Int
 sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
 sizeType (TyVarTy _)       = 1
 sizeType (TyConApp _ tys)  = sizeTypes tys + 1
+sizeType (LiteralTy _)     = 1
 sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
 sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
 sizeType (ForAllTy _ ty)   = sizeType ty
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 2c38b2ffde..87b2da1cbb 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1524,6 +1524,7 @@ ty_cts_subst subst inscope fl ty
         go' (TyVarTy tv)      = tyvar_cts_subst tv `orElse` mkTcReflCo (TyVarTy tv)
         go' (AppTy ty1 ty2)   = mkTcAppCo (go ty1) (go ty2) 
         go' (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)  
+        go' ty@(LiteralTy _)  = mkTcReflCo ty
 
         go' (ForAllTy v ty)   = mkTcForAllCo v' $! co
                              where 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index a36be651b4..511e47eb5c 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -896,6 +896,7 @@ floatEqualities skols can_given wantders
           | FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty
           | otherwise                        = unitVarSet tv
         tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys)
+        tvs_under_fsks (LiteralTy _)    = emptyVarSet
         tvs_under_fsks (FunTy arg res)  = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res
         tvs_under_fsks (AppTy fun arg)  = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg
         tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder 
@@ -1378,4 +1379,4 @@ newFlatWanteds orig theta
                  CNonCanonical { cc_id = v
                                , cc_flavor = Wanted loc
                                , cc_depth = 0 } }
-\end{code}
\ No newline at end of file
+\end{code}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index ed8b1c4702..46bc7e1145 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1306,6 +1306,7 @@ reifyType (AppTy t1 t2)     = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `T
 reifyType ty@(FunTy t1 t2)
   | isPredTy t1 = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
   | otherwise   = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
+reifyType (LiteralTy _)    = failWith $ ptext $ sLit "Type-level literal canont be reifyed yet."
 
 reify_for_all :: TypeRep.Type -> TcM TH.Type
 reify_for_all ty
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index f5d880d8fa..8ac4ab8230 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -238,6 +238,7 @@ calcClassCycles cls
       = flip (foldr (expandType seen path)) tys
 
     expandType _    _    (TyVarTy _)      = id
+    expandType _    _    (LiteralTy _)    = id
     expandType seen path (AppTy t1 t2)    = expandType seen path t1 . expandType seen path t2
     expandType seen path (FunTy t1 t2)    = expandType seen path t1 . expandType seen path t2
     expandType seen path (ForAllTy _tv t) = expandType seen path t
@@ -473,6 +474,7 @@ tcTyConsOfType ty
      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
      go ty | Just ty' <- tcView ty = go ty'
      go (TyVarTy _)                = emptyNameEnv
+     go (LiteralTy _)              = emptyNameEnv
      go (TyConApp tc tys)          = go_tc tc tys
      go (AppTy a b)                = go a `plusNameEnv` go b
      go (FunTy a b)                = go a `plusNameEnv` go b
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index d4d2642315..0ac5f14be8 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -172,7 +172,9 @@ import TyCon
 
 -- others:
 import DynFlags
-import Name hiding (varName)
+import Name -- hiding (varName)
+            -- We use this to make dictionaries for type literals.
+            -- Perhaps there's a better way to do this?
 import NameSet
 import VarEnv
 import PrelNames
@@ -183,7 +185,6 @@ import Maybes
 import ListSetOps
 import Outputable
 import FastString
-
 import Data.List( mapAccumL )
 import Data.IORef
 \end{code}
@@ -499,6 +500,7 @@ tidyType env@(_, subst) ty
 				Just tv' -> expand tv'
     go (TyConApp tycon tys) = let args = map go tys
 			      in args `seqList` TyConApp tycon args
+    go (LiteralTy n)        = LiteralTy n
     go (AppTy fun arg)	    = (AppTy $! (go fun)) $! (go arg)
     go (FunTy fun arg)	    = (FunTy $! (go fun)) $! (go arg)
     go (ForAllTy tv ty)	    = ForAllTy tvp $! (tidyType envp ty)
@@ -592,6 +594,7 @@ tcTyFamInsts (TyVarTy _)          = []
 tcTyFamInsts (TyConApp tc tys) 
   | isSynFamilyTyCon tc           = [(tc, tys)]
   | otherwise                   = concat (map tcTyFamInsts tys)
+tcTyFamInsts (LiteralTy _)        = []
 tcTyFamInsts (FunTy ty1 ty2)      = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
 tcTyFamInsts (AppTy ty1 ty2)      = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
 tcTyFamInsts (ForAllTy _ ty)      = tcTyFamInsts ty
@@ -641,6 +644,7 @@ exactTyVarsOfType ty
     go ty | Just ty' <- tcView ty = go ty'  -- This is the key line
     go (TyVarTy tv)         = unitVarSet tv
     go (TyConApp _ tys)     = exactTyVarsOfTypes tys
+    go (LiteralTy _)        = emptyVarSet
     go (FunTy arg res)      = go arg `unionVarSet` go res
     go (AppTy fun arg)      = go fun `unionVarSet` go arg
     go (ForAllTy tyvar ty)  = delVarSet (go ty) tyvar
@@ -776,9 +780,13 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
 getDFunTyKey (TyVarTy tv)    = getOccName tv
 getDFunTyKey (TyConApp tc _) = getOccName tc
+getDFunTyKey (LiteralTy x)   = getDFunTyLitKey x
 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 getDFunTyKey (FunTy _ _)     = getOccName funTyCon
 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
+
+getDFunTyLitKey :: TyLit -> OccName
+getDFunTyLitKey (NumberTyLit n) = mkOccName Name.varName (show n)
 \end{code}
 
 
@@ -1168,6 +1176,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet
 tcTyVarsOfType (TyVarTy tv)	    = if isTcTyVar tv then unitVarSet tv
 						      else emptyVarSet
 tcTyVarsOfType (TyConApp _ tys)     = tcTyVarsOfTypes tys
+tcTyVarsOfType (LiteralTy _)        = emptyVarSet
 tcTyVarsOfType (FunTy arg res)	    = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
 tcTyVarsOfType (AppTy fun arg)	    = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
 tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
@@ -1192,6 +1201,7 @@ orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
 orphNamesOfType (TyVarTy _)		   = emptyNameSet
 orphNamesOfType (TyConApp tycon tys)       = orphNamesOfTyCon tycon
                                              `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (LiteralTy _)       = emptyNameSet
 orphNamesOfType (FunTy arg res)	    = orphNamesOfType arg `unionNameSets` orphNamesOfType res
 orphNamesOfType (AppTy fun arg)	    = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
 orphNamesOfType (ForAllTy _ ty)	    = orphNamesOfType ty
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 23de50af56..ffe9958c6d 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -615,7 +615,11 @@ uType_np origin orig_ty1 orig_ty2
       | tc1 == tc2	   -- See Note [TyCon app]
       = do { cos <- uList origin uType tys1 tys2
            ; return $ mkTcTyConAppCo tc1 cos }
-     
+
+    go (LiteralTy m) ty@(LiteralTy n)
+      | m == n
+      = return $ mkTcReflCo ty
+
 	-- See Note [Care with type applications]
     go (AppTy s1 t1) ty2
       | Just (s2,t2) <- tcSplitAppTy_maybe ty2
@@ -912,6 +916,7 @@ checkTauTvUpdate tv ty
       = Just (TyConApp tc tys') 
       | isSynTyCon tc, Just ty_expanded <- tcView this_ty
       = ok ty_expanded -- See Note [Type synonyms and the occur check] 
+    ok ty@(LiteralTy _) = Just ty
     ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res
                        = Just (FunTy arg' res') 
     ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg 
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 840365ef78..6789bab913 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -919,6 +919,7 @@ ty_co_subst subst ty
     go (ForAllTy v ty)   = mkForAllCo v' $! (ty_co_subst subst' ty)
                          where
                            (subst', v') = liftCoSubstTyVarBndr subst v
+    go ty@(LiteralTy _)  = mkReflCo ty
 
 liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion
 liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv 
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 236185168b..1f49842fab 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -578,6 +578,7 @@ normaliseType env ty
   | Just ty' <- coreView ty = normaliseType env ty' 
 normaliseType env (TyConApp tc tys)
   = normaliseTcApp env tc tys
+normaliseType _env ty@(LiteralTy _) = (Refl ty, ty)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs
index fa467a7f27..f2155803f4 100644
--- a/compiler/types/Kind.lhs
+++ b/compiler/types/Kind.lhs
@@ -18,6 +18,7 @@ module Kind (
 	anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
         argTypeKind, ubxTupleKind, constraintKind,
         mkArrowKind, mkArrowKinds,
+        typeNatKind,
 
         -- Kind constructors...
         anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon,
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index a344fd151b..a4f4252d74 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -41,6 +41,8 @@ module Type (
         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
         mkPiKinds, mkPiType, mkPiTypes,
 	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
+
+        mkLiteralTy, mkNumberTyLit, mkNumberTy, isNumberTy,
 	
 	-- (Newtypes)
 	newTyConInstRhs, carefullySplitNewType_maybe,
@@ -277,6 +279,7 @@ expandTypeSynonyms ty
       = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
       | otherwise
       = TyConApp tc (map go tys)
+    go (LiteralTy l)   = LiteralTy l
     go (TyVarTy tv)    = TyVarTy tv
     go (AppTy t1 t2)   = AppTy (go t1) (go t2)
     go (FunTy t1 t2)   = FunTy (go t1) (go t2)
@@ -403,6 +406,25 @@ splitAppTys ty = split ty ty []
 \end{code}
 
 
+                      LiteralTy
+                      ~~~~~~~~~
+
+\begin{code}
+mkLiteralTy :: TyLit -> Type
+mkLiteralTy = LiteralTy
+
+mkNumberTyLit :: Integer -> TyLit
+mkNumberTyLit = NumberTyLit
+
+mkNumberTy :: Integer -> Type
+mkNumberTy n = mkLiteralTy (mkNumberTyLit n)
+
+isNumberTy :: Type -> Maybe Integer
+isNumberTy (LiteralTy (NumberTyLit n)) = Just n
+isNumberTy _                           = Nothing
+\end{code}
+
+
 ---------------------------------------------------------------------
 				FunTy
 				~~~~~
@@ -972,6 +994,7 @@ typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (ForAllTy _ t)  = 1 + typeSize t
 typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
+typeSize (LiteralTy _)   = 1
 
 varSetElemsKvsFirst :: VarSet -> [TyVar]
 -- {k1,a,k2,b} --> [k1,k2,a,b]
@@ -1129,6 +1152,7 @@ seqType (AppTy t1 t2) 	  = seqType t1 `seq` seqType t2
 seqType (FunTy t1 t2) 	  = seqType t1 `seq` seqType t2
 seqType (TyConApp tc tys) = tc `seq` seqTypes tys
 seqType (ForAllTy tv ty)  = tv `seq` seqType ty
+seqType (LiteralTy n)     = n `seq` ()
 
 seqTypes :: [Type] -> ()
 seqTypes []       = ()
@@ -1462,6 +1486,7 @@ subst_ty subst ty
     go (ForAllTy tv ty)  = case substTyVarBndr subst tv of
                               (subst', tv') ->
                                  ForAllTy tv' $! (subst_ty subst' ty)
+    go (LiteralTy n)     = n `seq` LiteralTy n
 
 substTyVar :: TvSubst -> TyVar  -> Type
 substTyVar (TvSubst _ tenv) tv
@@ -1549,6 +1574,7 @@ typeKind (TyConApp tc tys)
   = kindAppResult (tyConKind tc) tys
 
 typeKind (AppTy fun arg)      = kindAppResult (typeKind fun) [arg]
+typeKind (LiteralTy l)        = typeLiteralKind l
 typeKind (ForAllTy _ ty)      = typeKind ty
 typeKind (TyVarTy tyvar)      = tyVarKind tyvar
 typeKind (FunTy _arg res)
@@ -1562,6 +1588,12 @@ typeKind (FunTy _arg res)
     where
       k = typeKind res
 
+
+typeLiteralKind :: TyLit -> Kind
+typeLiteralKind l =
+  case l of
+    NumberTyLit _ -> typeNatKind
+
 \end{code}
 
 Kind inference
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 6d1050fde2..9f5b6b1d75 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -18,6 +18,7 @@
 module TypeRep (
 	TyThing(..),
 	Type(..),
+        TyLit(..),
         KindOrType, Kind, SuperKind,
         PredType, ThetaType,      -- Synonyms
 
@@ -29,7 +30,7 @@ module TypeRep (
 	pprType, pprParendType, pprTypeApp,
 	pprTyThing, pprTyThingCategory, 
 	pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
-        pprKind, pprParendKind,
+        pprKind, pprParendKind, pprTyLit,
 	Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
         pprPrefixApp, pprArrowChain, ppr_type,
 
@@ -112,8 +113,17 @@ data Type
 	Var         -- Type or kind variable
 	Type	        -- ^ A polymorphic type
 
+ | LiteralTy TyLit     -- ^ Type literals are simillar to type constructors.
+
   deriving (Data.Data, Data.Typeable)
 
+
+-- NOTE:  Other parts of the code assume that type literals do not contain
+-- types or type variables.
+data TyLit
+  = NumberTyLit Integer
+  deriving (Eq, Ord, Data.Data, Data.Typeable)
+
 type KindOrType = Type -- See Note [Arguments to type constructors]
 
 -- | The key type representing kinds in the compiler.
@@ -279,6 +289,7 @@ tyVarsOfType :: Type -> VarSet
 -- kind variable {k}
 tyVarsOfType (TyVarTy v)         = unitVarSet v
 tyVarsOfType (TyConApp _ tys)    = tyVarsOfTypes tys
+tyVarsOfType (LiteralTy _)       = emptyVarSet
 tyVarsOfType (FunTy arg res)     = tyVarsOfType arg `unionVarSet` tyVarsOfType res
 tyVarsOfType (AppTy fun arg)     = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
 tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
@@ -450,6 +461,9 @@ pprType, pprParendType :: Type -> SDoc
 pprType       ty = ppr_type TopPrec ty
 pprParendType ty = ppr_type TyConPrec ty
 
+pprTyLit :: TyLit -> SDoc
+pprTyLit = ppr_tylit TopPrec
+
 pprKind, pprParendKind :: Kind -> SDoc
 pprKind       = pprType
 pprParendKind = pprParendType
@@ -510,6 +524,9 @@ pprThetaArrowTy preds   = parens (fsep (punctuate comma (map (ppr_type TopPrec)
 instance Outputable Type where
     ppr ty = pprType ty
 
+instance Outputable TyLit where
+   ppr = pprTyLit
+
 instance Outputable name => OutputableBndr (IPName name) where
     pprBndr _ n = ppr n	-- Simple for now
 
@@ -519,6 +536,7 @@ instance Outputable name => OutputableBndr (IPName name) where
 ppr_type :: Prec -> Type -> SDoc
 ppr_type _ (TyVarTy tv)	      = ppr_tvar tv
 ppr_type p (TyConApp tc tys)  = pprTcApp p ppr_type tc tys
+ppr_type p (LiteralTy l)      = ppr_tylit p l
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
 			   pprType t1 <+> ppr_type TyConPrec t2
@@ -553,6 +571,9 @@ ppr_tvar :: TyVar -> SDoc
 ppr_tvar tv  -- Note [Infix type variables]
   = parenSymOcc (getOccName tv) (ppr tv)
 
+ppr_tylit :: Prec -> TyLit -> SDoc
+ppr_tylit _ (NumberTyLit n) = integer n
+
 -------------------
 pprForAll :: [TyVar] -> SDoc
 pprForAll []  = empty
diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs
index cebee633ee..751fdace50 100644
--- a/compiler/vectorise/Vectorise/Convert.hs
+++ b/compiler/vectorise/Vectorise/Convert.hs
@@ -78,6 +78,7 @@ identityConv (TyConApp tycon tys)
   = do { mapM_ identityConv tys
        ; identityConvTyCon tycon
        }
+identityConv (LiteralTy _)  = noV $ text "identityConv: not sure about literal types under vectorisation"
 identityConv (TyVarTy _)    = noV $ text "identityConv: type variable changes under vectorisation"
 identityConv (AppTy   _ _)  = noV $ text "identityConv: type appl. changes under vectorisation"
 identityConv (FunTy    _ _) = noV $ text "identityConv: function type changes under vectorisation"
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 7122cb7664..ff3803730e 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -106,4 +106,5 @@ tyConsOfType (TyConApp tc tys) = extend (tyConsOfTypes tys)
 tyConsOfType (AppTy a b)       = tyConsOfType a `unionUniqSets` tyConsOfType b
 tyConsOfType (FunTy a b)       = (tyConsOfType a `unionUniqSets` tyConsOfType b)
                                  `addOneToUniqSet` funTyCon
+tyConsOfType (LiteralTy _)     = emptyUniqSet
 tyConsOfType (ForAllTy _ ty)   = tyConsOfType ty
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
index db724ad4bf..336b12618d 100644
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ b/compiler/vectorise/Vectorise/Type/Type.hs
@@ -59,6 +59,7 @@ vectType ty
   | Just ty'  <- coreView ty
   = vectType ty'
 vectType (TyVarTy tv)      = return $ TyVarTy tv
+vectType (LiteralTy l)     = return $ LiteralTy l
 vectType (AppTy ty1 ty2)   = AppTy <$> vectType ty1 <*> vectType ty2
 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys
 vectType (FunTy ty1 ty2)