From 4611522487b382b839a53e75e3feb2aac8764074 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 23 Apr 2010 13:37:37 +0900
Subject: [PATCH] implementing type-level strings...

---
 Data/HList/Number.hs  | 58 +++++++++++++++++++++++++++++++++++++++++++
 Data/HList/Prelude.hs |  8 ++++++
 Data/HList/String.hs  | 31 +++++++++++++++++++++--
 rrdtool.cabal         |  8 +++---
 4 files changed, 100 insertions(+), 5 deletions(-)
 create mode 100644 Data/HList/Number.hs

diff --git a/Data/HList/Number.hs b/Data/HList/Number.hs
new file mode 100644
index 0000000..ed9b513
--- /dev/null
+++ b/Data/HList/Number.hs
@@ -0,0 +1,58 @@
+module Data.HList.Number
+    ( HNat
+
+    , HZero
+    , hZero
+
+    , HSucc
+    , hSucc
+    , hPred
+
+    , hNatLiteralT
+    , hNatLiteralE
+    , hNatLiteralP
+    )
+    where
+
+import Language.Haskell.TH
+
+
+-- HNat
+class HNat n
+
+-- HZero
+data HZero = HZero deriving Show
+
+instance HNat HZero
+
+hZero :: HZero
+hZero = HZero
+
+-- HSucc
+data HSucc n = HSucc n deriving Show
+
+instance HNat n => HNat (HSucc n)
+
+hSucc :: HNat n => n -> HSucc n
+hSucc = HSucc
+
+hPred :: HNat n => HSucc n -> n
+hPred (HSucc n) = n
+
+-- TH
+hNatLiteralT :: Integral n => n -> Q Type
+hNatLiteralT n
+    | n == 0    = conT (mkName "HZero")
+    | otherwise = appT (conT (mkName "HSucc"))
+                       (hNatLiteralT (n - 1))
+
+hNatLiteralE :: Integral n => n -> Q Exp
+hNatLiteralE n
+    | n == 0    = varE (mkName "hZero")
+    | otherwise = appE (varE (mkName "hSucc"))
+                       (hNatLiteralE (n - 1))
+
+hNatLiteralP :: Integral n => n -> Q Pat
+hNatLiteralP n
+    | n == 0    = varP (mkName "HZero")
+    | otherwise = conP (mkName "HSucc") [hNatLiteralP n]
diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs
index b3a88fd..3eb7e81 100644
--- a/Data/HList/Prelude.hs
+++ b/Data/HList/Prelude.hs
@@ -1,3 +1,11 @@
+{-# LANGUAGE DeriveDataTypeable,
+             FlexibleContexts,
+             FlexibleInstances,
+             MultiParamTypeClasses,
+             TypeFamilies,
+             TypeOperators,
+             UndecidableInstances
+  #-}
 module Data.HList.Prelude
     ( HList
 
diff --git a/Data/HList/String.hs b/Data/HList/String.hs
index a51457e..bcec59c 100644
--- a/Data/HList/String.hs
+++ b/Data/HList/String.hs
@@ -1,6 +1,33 @@
 module Data.HList.String
-    (
+    ( HString
+    , hString
     )
     where
 
---import Data.HList.Prelude
+import Data.HList.Number
+import Data.HList.Prelude
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+
+class HString s
+
+instance HString HNil
+
+instance HNat c => HString (HCons c s)
+
+hString :: QuasiQuoter
+hString = QuasiQuoter quoteStrExp quoteStrPat
+
+quoteStrExp :: String -> ExpQ
+quoteStrExp []     = varE (mkName "hNil")
+quoteStrExp (c:cs) = appsE [ varE (mkName "hCons")
+                           , hNatLiteralE (fromEnum c)
+                           , quoteStrExp cs
+                           ]
+
+quoteStrPat :: String -> PatQ
+quoteStrPat []     = varP (mkName "HNil")
+quoteStrPat (c:cs) = conP (mkName "HCons") [ hNatLiteralP (fromEnum c)
+                                           , quoteStrPat cs
+                                           ]
diff --git a/rrdtool.cabal b/rrdtool.cabal
index 83d74d5..2a3a029 100644
--- a/rrdtool.cabal
+++ b/rrdtool.cabal
@@ -23,9 +23,10 @@ Source-Repository head
 
 Library
     Build-Depends:
-        base            == 4.2.*,
-        bindings-librrd == 0.1.*,
-        time            == 1.1.*
+        base             == 4.2.*,
+        bindings-librrd  == 0.1.*,
+        template-haskell == 2.4.*,
+        time             == 1.1.*
 
     Exposed-Modules:
         Database.RRDtool
@@ -33,6 +34,7 @@ Library
         Database.RRDtool.Expression
         Data.HList
         Data.HList.Prelude
+        Data.HList.Number
         Data.HList.String
 
     Extensions:
-- 
2.40.0