]> gitweb @ CieloNegro.org - hs-rrdtool.git/blob - Data/HList/Prelude.hs
e8d84adf88a3af162aa32576d7c1a6d7b949ebc2
[hs-rrdtool.git] / 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)