Data/HList/Prelude.hs

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