Data/HList.hs

   1 module Data.HList
   2     ( HList
   3     , HNil(..)
   4     , hNil
   5     , (:*:)(..)
   6     , (.*.)
   7
   8     , HExtendable(..)
   9     , HAppendable(..)
  10
  11     , Applyable(..)
  12     , Applyable2(..)
  13
  14     , Id(..)
  15     , ApplyHAppend(..)
  16
  17     , HFoldrable(..)
  18     , HConcatable(..)
  19     , HMappable(..)
  20     )
  21     where
  22
  23 import Data.Typeable
  24
  25 -- HList
  26 class HList l
  27
  28 -- HNil
  29 data HNil
  30     = HNil
  31       deriving (Show, Eq, Ord, Read, Typeable)
  32
  33 instance HList HNil
  34
  35 hNil :: HNil
  36 hNil = HNil
  37
  38 -- :*:
  39 infixr 2 :*:
  40 infixr 2 .*.
  41
  42 data e :*: l
  43     = e :*: l
  44       deriving (Show, Eq, Ord, Read, Typeable)
  45
  46 instance HList l => HList (e :*: l)
  47
  48 (.*.) :: HList l => e -> l -> e :*: l
  49 (.*.) = (:*:)
  50
  51 -- HExtendable
  52 class HExtendable e l where
  53     type HExtend e l
  54     hExtend :: e -> l -> HExtend e l
  55
  56 instance HExtendable e HNil where
  57     type HExtend e HNil = e :*: HNil
  58     hExtend e nil = e .*. nil
  59
  60 instance HList l => HExtendable e (e' :*: l) where
  61     type HExtend e (e' :*: l) = e :*: e' :*: l
  62     hExtend e (e' :*: l) = e .*. e' .*. l
  63
  64 -- HAppendable
  65 infixr 1 :++:
  66 infixr 1 .++.
  67
  68 class HAppendable l l' where
  69     type l :++: l'
  70     (.++.) :: l -> l' -> l :++: l'
  71
  72 instance HList l => HAppendable HNil l where
  73     type HNil :++: l = l
  74     _ .++. l = l
  75
  76 instance ( HAppendable l l'
  77          , HList (l :++: l')
  78          ) => HAppendable (e :*: l) l' where
  79     type (e :*: l) :++: l' = e :*: (l :++: l')
  80     (e :*: l) .++. l' = e .*. (l .++. l')
  81
  82 -- Applyable
  83 class Applyable f a where
  84     type Apply f a
  85     apply :: f -> a -> Apply f a
  86
  87 -- Applyable2
  88 class Applyable2 f a b where
  89     type Apply2 f a b
  90     apply2 :: f -> a -> b -> Apply2 f a b
  91
  92 -- Id
  93 data Id = Id
  94
  95 instance Applyable Id a where
  96     type Apply Id a = a
  97     apply _ a = a
  98
  99 -- ApplyHAppend
 100 data ApplyHAppend = ApplyHAppend
 101
 102 instance HAppendable a b => Applyable2 ApplyHAppend a b where
 103     type Apply2 ApplyHAppend a b = a :++: b
 104     apply2 _ a b = a .++. b
 105
 106 -- HFoldrable
 107 class HFoldrable f v l where
 108     type HFoldr f v l
 109     hFoldr :: f -> v -> l -> HFoldr f v l
 110
 111 instance HFoldrable f v HNil where
 112     type HFoldr f v HNil = v
 113     hFoldr _ v _ = v
 114
 115 instance ( HFoldrable f v l
 116          , Applyable2 f e (HFoldr f v l)
 117          ) => HFoldrable f v (e :*: l) where
 118     type HFoldr f v (e :*: l) = Apply2 f e (HFoldr f v l)
 119     hFoldr f v (e :*: l) = apply2 f e (hFoldr f v l)
 120
 121 -- HConcatable
 122 class HConcatable ls where
 123     type HConcat ls
 124     hConcat :: ls -> HConcat ls
 125
 126 instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where
 127     type HConcat ls = HFoldr ApplyHAppend HNil ls
 128     hConcat ls = hFoldr ApplyHAppend hNil ls
 129
 130 -- HMappable
 131 class HMappable f l where
 132     type HMap f l
 133     hMap :: f -> l -> HMap f l
 134
 135 instance HMappable f HNil where
 136     type HMap f HNil = HNil
 137     hMap _ _ = HNil
 138
 139 instance ( HList (HMap f xs)
 140          , Applyable f x
 141          , HMappable f xs
 142          ) => HMappable f (x :*: xs) where
 143     type HMap f (x :*: xs) = Apply f x :*: HMap f xs
 144     hMap f (x :*: xs) = apply f x .*. hMap f xs