Data/HList/Prelude.hs

   1 {-# LANGUAGE DeriveDataTypeable,
   2              FlexibleContexts,
   3              FlexibleInstances,
   4              MultiParamTypeClasses,
   5              TypeFamilies,
   6              TypeOperators,
   7              UndecidableInstances
   8   #-}
   9 module Data.HList.Prelude
  10     ( HList
  11
  12     , HNil(..)
  13     , hNil
  14
  15     , HCons(..)
  16     , hCons
  17
  18     , HExtendable(..)
  19     , HAppendable(..)
  20
  21     , Applyable(..)
  22     , Applyable2(..)
  23
  24     , Id(..)
  25     , ApplyHAppend(..)
  26
  27     , HFoldrable(..)
  28     , HConcatable(..)
  29     , HMappable(..)
  30     , HAllable(..)
  31
  32     , HLength
  33     )
  34     where
  35
  36 import Data.Typeable
  37 import Types.Data.Bool
  38 import Types.Data.Num hiding ((:*:))
  39
  40
  41 -- HList
  42 class HList l
  43
  44 -- HNil
  45 data HNil
  46     = HNil
  47       deriving (Show, Eq, Ord, Read, Typeable)
  48
  49 instance HList HNil
  50
  51 hNil :: HNil
  52 hNil = HNil
  53
  54 -- HCons
  55 data HCons e l
  56     = HCons e l
  57       deriving (Show, Eq, Ord, Read, Typeable)
  58
  59 instance HList l => HList (HCons e l)
  60
  61 hCons :: HList l => e -> l -> HCons e l
  62 hCons = HCons
  63
  64 -- HExtendable
  65 infixr 2 :*:
  66 infixr 2 .*.
  67
  68 class HExtendable e l where
  69     type e :*: l
  70     (.*.) :: e -> l -> e :*: l
  71
  72 instance HExtendable e HNil where
  73     type e :*: HNil = HCons e HNil
  74     e .*. nil = hCons e nil
  75
  76 instance HList l => HExtendable e (HCons e' l) where
  77     type e :*: HCons e' l = HCons e (HCons e' l)
  78     e .*. HCons e' l = hCons e (hCons e' l)
  79
  80 -- HAppendable
  81 infixr 1 :++:
  82 infixr 1 .++.
  83
  84 class HAppendable l l' where
  85     type l :++: l'
  86     (.++.) :: l -> l' -> l :++: l'
  87
  88 instance HList l => HAppendable HNil l where
  89     type HNil :++: l = l
  90     _ .++. l = l
  91
  92 instance ( HList (l :++: l')
  93          , HAppendable l l'
  94          ) => HAppendable (HCons e l) l' where
  95     type HCons e l :++: l' = HCons e (l :++: l')
  96     (HCons e l) .++. l' = hCons e (l .++. l')
  97
  98 -- Applyable
  99 class Applyable f a where
 100     type Apply f a
 101     apply :: f -> a -> Apply f a
 102
 103 -- Applyable2
 104 class Applyable2 f a b where
 105     type Apply2 f a b
 106     apply2 :: f -> a -> b -> Apply2 f a b
 107
 108 -- Id
 109 data Id = Id
 110
 111 instance Applyable Id a where
 112     type Apply Id a = a
 113     apply _ a = a
 114
 115 -- ApplyHAppend
 116 data ApplyHAppend = ApplyHAppend
 117
 118 instance HAppendable a b => Applyable2 ApplyHAppend a b where
 119     type Apply2 ApplyHAppend a b = a :++: b
 120     apply2 _ a b = a .++. b
 121
 122 -- HFoldrable
 123 class HFoldrable f v l where
 124     type HFoldr f v l
 125     hFoldr :: f -> v -> l -> HFoldr f v l
 126
 127 instance HFoldrable f v HNil where
 128     type HFoldr f v HNil = v
 129     hFoldr _ v _ = v
 130
 131 instance ( HFoldrable f v l
 132          , Applyable2 f e (HFoldr f v l)
 133          ) => HFoldrable f v (HCons e l) where
 134     type HFoldr f v (HCons e l) = Apply2 f e (HFoldr f v l)
 135     hFoldr f v (HCons e l) = apply2 f e (hFoldr f v l)
 136
 137 -- HConcatable
 138 class HConcatable ls where
 139     type HConcat ls
 140     hConcat :: ls -> HConcat ls
 141
 142 instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where
 143     type HConcat ls = HFoldr ApplyHAppend HNil ls
 144     hConcat ls = hFoldr ApplyHAppend hNil ls
 145
 146 -- HMappable
 147 class HMappable f l where
 148     type HMap f l
 149     hMap :: f -> l -> HMap f l
 150
 151 instance HMappable f HNil where
 152     type HMap f HNil = HNil
 153     hMap _ _ = hNil
 154
 155 instance ( Applyable f x
 156          , HMappable f xs
 157          , HList (HMap f xs)
 158          ) => HMappable f (HCons x xs) where
 159     type HMap f (HCons x xs) = HCons (Apply f x) (HMap f xs)
 160     hMap f (HCons x xs) = hCons (apply f x) (hMap f xs)
 161
 162 -- HAllable
 163 class HAllable f l where
 164     type HAll f l
 165     hAll :: f -> l -> HAll f l
 166
 167 instance HAllable f HNil where
 168     type HAll f HNil = True
 169     hAll _ _ = undefined :: True
 170
 171 instance ( IfT (Apply f x) (HAll f xs) False
 172          , Applyable f x
 173          , HAllable f xs
 174          ) => HAllable f (HCons x xs) where
 175     type HAll f (HCons x xs) = If (Apply f x)
 176                                  (HAll f xs)
 177                                  False
 178     hAll f (HCons x xs) = ifT (apply f x)
 179                                  (hAll f xs)
 180                                  (undefined :: False)
 181
 182 -- HLength
 183 type family HLength l
 184 type instance HLength HNil        = D0
 185 type instance HLength (HCons e l) = Succ (HLength l)