X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FHList%2FPrelude.hs;h=bbcc50c60194078a17e10f6af8c150f6315825d3;hb=d07e35733d4f0994a12202164c9065aef1fe98f4;hp=b3e6b95bd4da779bced5e300c757b9a534b72866;hpb=b7e8a37aa24e9bda11995613c45187e6e19e0c01;p=hs-rrdtool.git

diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs
index b3e6b95..bbcc50c 100644
--- a/Data/HList/Prelude.hs
+++ b/Data/HList/Prelude.hs
@@ -1,26 +1,41 @@
+{-# LANGUAGE DeriveDataTypeable,
+             FlexibleContexts,
+             FlexibleInstances,
+             MultiParamTypeClasses,
+             TypeFamilies,
+             TypeOperators,
+             UndecidableInstances
+  #-}
 module Data.HList.Prelude
     ( HList
+
     , HNil(..)
     , hNil
-    , (:*:)(..)
-    , (.*.)
 
-    , HExtendable(..)
-    , HAppendable(..)
+    , HCons(..)
+    , hCons
+
+    , HExtendT(..)
+    , HAppendT(..)
 
-    , Applyable(..)
-    , Applyable2(..)
+    , ApplyT(..)
+    , Apply2T(..)
 
     , Id(..)
-    , ApplyHAppend(..)
+    , HAppendA(..)
+
+    , HFoldrT(..)
+    , HConcatT(..)
+    , HMapT(..)
 
-    , HFoldrable(..)
-    , HConcatable(..)
-    , HMappable(..)
+    , HAll
+    , HLength
     )
     where
 
 import Data.Typeable
+import Types.Data.Bool
+import Types.Data.Num hiding ((:*:))
 
 
 -- HList
@@ -36,110 +51,122 @@ instance HList HNil
 hNil :: HNil
 hNil = HNil
 
--- :*:
-infixr 2 :*:
-infixr 2 .*.
-
-data e :*: l
-    = e :*: l
+-- HCons
+data HCons e l
+    = HCons e l
       deriving (Show, Eq, Ord, Read, Typeable)
 
-instance HList l => HList (e :*: l)
+instance HList l => HList (HCons e l)
+
+hCons :: HList l => e -> l -> HCons e l
+hCons = HCons
 
-(.*.) :: HList l => e -> l -> e :*: l
-(.*.) = (:*:)
+-- HExtendT
+infixr 2 :*:
+infixr 2 .*.
 
--- HExtendable
-class HExtendable e l where
-    type HExtend e l
-    hExtend :: e -> l -> HExtend e l
+class HExtendT e l where
+    type e :*: l
+    (.*.) :: e -> l -> e :*: l
 
-instance HExtendable e HNil where
-    type HExtend e HNil = e :*: HNil
-    hExtend e nil = e .*. nil
+instance HExtendT e HNil where
+    type e :*: HNil = HCons e HNil
+    e .*. nil = hCons e nil
 
-instance HList l => HExtendable e (e' :*: l) where
-    type HExtend e (e' :*: l) = e :*: e' :*: l
-    hExtend e (e' :*: l) = e .*. e' .*. l
+instance HList l => HExtendT e (HCons e' l) where
+    type e :*: HCons e' l = HCons e (HCons e' l)
+    e .*. HCons e' l = hCons e (hCons e' l)
 
--- HAppendable
+-- HAppendT
 infixr 1 :++:
 infixr 1 .++.
 
-class HAppendable l l' where
+class HAppendT l l' where
     type l :++: l'
     (.++.) :: l -> l' -> l :++: l'
 
-instance HList l => HAppendable HNil l where
+instance HList l => HAppendT HNil l where
     type HNil :++: l = l
     _ .++. l = l
 
-instance ( HAppendable l l'
-         , HList (l :++: l')
-         ) => HAppendable (e :*: l) l' where
-    type (e :*: l) :++: l' = e :*: (l :++: l')
-    (e :*: l) .++. l' = e .*. (l .++. l')
+instance ( HList (l :++: l')
+         , HAppendT l l'
+         ) => HAppendT (HCons e l) l' where
+    type HCons e l :++: l' = HCons e (l :++: l')
+    (HCons e l) .++. l' = hCons e (l .++. l')
 
--- Applyable
-class Applyable f a where
+-- ApplyT
+class ApplyT f a where
     type Apply f a
     apply :: f -> a -> Apply f a
+    apply _ _ = undefined
 
--- Applyable2
-class Applyable2 f a b where
+-- Apply2T
+class Apply2T f a b where
     type Apply2 f a b
     apply2 :: f -> a -> b -> Apply2 f a b
+    apply2 _ _ _ = undefined
 
 -- Id
 data Id = Id
 
-instance Applyable Id a where
+instance ApplyT Id a where
     type Apply Id a = a
     apply _ a = a
 
--- ApplyHAppend
-data ApplyHAppend = ApplyHAppend
+-- HAppendA
+data HAppendA = HAppendA
 
-instance HAppendable a b => Applyable2 ApplyHAppend a b where
-    type Apply2 ApplyHAppend a b = a :++: b
+instance HAppendT a b => Apply2T HAppendA a b where
+    type Apply2 HAppendA a b = a :++: b
     apply2 _ a b = a .++. b
 
--- HFoldrable
-class HFoldrable f v l where
+-- HFoldrT
+class HFoldrT f v l where
     type HFoldr f v l
     hFoldr :: f -> v -> l -> HFoldr f v l
 
-instance HFoldrable f v HNil where
+instance HFoldrT f v HNil where
     type HFoldr f v HNil = v
     hFoldr _ v _ = v
 
-instance ( HFoldrable f v l
-         , Applyable2 f e (HFoldr f v l)
-         ) => HFoldrable f v (e :*: l) where
-    type HFoldr f v (e :*: l) = Apply2 f e (HFoldr f v l)
-    hFoldr f v (e :*: l) = apply2 f e (hFoldr f v l)
+instance ( HFoldrT f v l
+         , Apply2T f e (HFoldr f v l)
+         ) => HFoldrT f v (HCons e l) where
+    type HFoldr f v (HCons e l) = Apply2 f e (HFoldr f v l)
+    hFoldr f v (HCons e l) = apply2 f e (hFoldr f v l)
 
--- HConcatable
-class HConcatable ls where
+-- HConcatT
+class HConcatT ls where
     type HConcat ls
     hConcat :: ls -> HConcat ls
 
-instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where
-    type HConcat ls = HFoldr ApplyHAppend HNil ls
-    hConcat ls = hFoldr ApplyHAppend hNil ls
+instance HFoldrT HAppendA HNil ls => HConcatT ls where
+    type HConcat ls = HFoldr HAppendA HNil ls
+    hConcat ls = hFoldr HAppendA hNil ls
 
--- HMappable
-class HMappable f l where
+-- HMapT
+class HMapT f l where
     type HMap f l
     hMap :: f -> l -> HMap f l
 
-instance HMappable f HNil where
+instance HMapT f HNil where
     type HMap f HNil = HNil
-    hMap _ _ = HNil
-
-instance ( HList (HMap f xs)
-         , Applyable f x
-         , HMappable f xs
-         ) => HMappable f (x :*: xs) where
-    type HMap f (x :*: xs) = Apply f x :*: HMap f xs
-    hMap f (x :*: xs) = apply f x .*. hMap f xs
+    hMap _ _ = hNil
+
+instance ( ApplyT f x
+         , HMapT f xs
+         , HList (HMap f xs)
+         ) => HMapT f (HCons x xs) where
+    type HMap f (HCons x xs) = HCons (Apply f x) (HMap f xs)
+    hMap f (HCons x xs) = hCons (apply f x) (hMap f xs)
+
+-- HAll
+type family HAll f l
+type instance HAll f HNil         = True
+type instance HAll f (HCons x xs) = If (Apply f x) (HAll f xs) False
+
+-- HLength
+type family HLength l
+type instance HLength HNil        = D0
+type instance HLength (HCons e l) = Succ (HLength l)