beginning of my own HList with type families...

[hs-rrdtool.git] / Data / HList.hs

diff --git a/Data/HList.hs b/Data/HList.hs
new file mode 100644 (file)
index 0000000..77ad6cc
--- /dev/null
+++ b/Data/HList.hs
@@ -0,0 +1,75 @@
+module Data.HList
+    ( HList
+    , HNil(..)
+    , hNil
+    , HCons(..)
+    , hCons
+
+    , HExtendable(..)
+    , HAppendable(..)
+
+    , (:*:)
+    , (.*.)
+    )
+    where
+
+import Data.Typeable
+
+-- HList
+class HList l
+
+-- HNil
+data HNil
+    = HNil
+      deriving (Show, Eq, Ord, Read, Typeable)
+
+instance HList HNil
+
+hNil :: HNil
+hNil = HNil
+
+-- HCons
+data HCons e l
+    = HCons e l
+      deriving (Show, Eq, Ord, Read, Typeable)
+
+instance HList l => HList (HCons e l)
+
+hCons :: HList l => e -> l -> HCons e l
+hCons = HCons
+
+-- HExtendable
+class HExtendable e l where
+    type HExtend e l
+    hExtend :: e -> l -> HExtend e l
+
+instance HExtendable e HNil where
+    type HExtend e HNil = HCons e HNil
+    hExtend e nil = hCons e nil
+
+instance HList l => HExtendable e (HCons e' l) where
+    type HExtend e (HCons e' l) = HCons e (HCons e' l)
+    hExtend e (HCons e' l) = hCons e (hCons e' l)
+
+-- HAppendable
+class HAppendable l l' where
+    type HAppend l l'
+    hAppend :: l -> l' -> HAppend l l'
+
+instance HList l => HAppendable HNil l where
+    type HAppend HNil l = l
+    hAppend _ l = l
+
+instance (HAppendable l l',
+          HList (HAppend l l')) => HAppendable (HCons e l) l' where
+    type HAppend (HCons e l) l' = HCons e (HAppend l l')
+    hAppend (HCons e l) l' = hCons e (hAppend l l')
+
+-- :*:
+infixr 2 :*:
+infixr 2 .*.
+
+type e :*: l = HCons e l
+
+(.*.) :: HExtendable e l => e -> l -> HExtend e l
+e .*. l = hExtend e l