Data/HList/Prelude.hs

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