1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Database.CDBI.Description where
import Time
import Database.CDBI.Connection (SQLType, SQLValue(..))
data EntityDescription a = ED String
[SQLType]
(a -> [SQLValue])
(a -> [SQLValue])
([SQLValue] -> a)
data CombinedDescription a = CD [(Table, Int, [SQLType])]
([SQLValue] -> a)
(a -> [[SQLValue]])
(a -> [[SQLValue]])
type Table = String
data Column _ = Column String String
data ColumnDescription a = ColDesc String
SQLType
(a -> SQLValue)
(SQLValue -> a)
combineDescriptions :: EntityDescription a ->
Int ->
EntityDescription b ->
Int ->
(a -> b -> c) ->
(c -> (a, b)) ->
CombinedDescription c
combineDescriptions ed1 rename1 ed2 rename2 f1 f2 =
CD [(getTable ed1, rename1, getTypes ed1),
(getTable ed2, rename2, getTypes ed2)]
createFunction1 createFunction2 createFunction3
where createFunction1 xs = f1 ((getToEntity ed1)
(take lengthEd1 xs))
((getToEntity ed2)
(drop lengthEd1 xs))
where lengthEd1 = length (getTypes ed1)
createFunction2 combEnt =
let (ent1, ent2) = f2 combEnt in
((getToValues ed1) ent1) : [(getToValues ed2) ent2]
createFunction3 combEnt =
let (ent1, ent2) = f2 combEnt in
((getToInsertValues ed1) ent1) : [(getToInsertValues ed2) ent2]
addDescription :: EntityDescription a ->
Int ->
(a -> b -> b) ->
(b -> a) ->
CombinedDescription b ->
CombinedDescription b
addDescription ed1 rename f1 f2 (CD xs f1' f2' f3') =
CD ((getTable ed1, rename, getTypes ed1) : xs)
createFunction1
createFunction2
createFunction3
where createFunction1 ys =
f1 ((getToEntity ed1)
(take lengthEd1 ys))
(f1' (drop lengthEd1 ys))
where lengthEd1 = length (getTypes ed1)
createFunction2 combEnt =
[(getToValues ed1) (f2 combEnt)] ++ (f2' combEnt)
createFunction3 combEnt =
[(getToInsertValues ed1) (f2 combEnt)] ++ (f3' combEnt)
getTable :: EntityDescription a -> String
getTable (ED s _ _ _ _) = s
getTypes :: EntityDescription a -> [SQLType]
getTypes (ED _ t _ _ _) = t
getToValues :: EntityDescription a -> (a -> [SQLValue])
getToValues (ED _ _ f _ _) = f
getToInsertValues :: EntityDescription a -> (a -> [SQLValue])
getToInsertValues (ED _ _ _ f _) = f
getToEntity :: EntityDescription a -> ([SQLValue] -> a)
getToEntity (ED _ _ _ _ f) = f
getColumnSimple :: Column a -> String
getColumnSimple (Column s _ ) = s
getColumnFull :: Column a -> String
getColumnFull (Column _ s ) = s
getColumnName :: ColumnDescription a -> String
getColumnName (ColDesc s _ _ _) = s
getColumnTableName :: ColumnDescription a -> String
getColumnTableName (ColDesc s _ _ _) = s
getColumnTyp :: ColumnDescription a -> SQLType
getColumnTyp (ColDesc _ t _ _) = t
getColumnValueBuilder :: ColumnDescription a -> (a -> SQLValue)
getColumnValueBuilder (ColDesc _ _ f _) = f
getColumnValueSelector :: ColumnDescription a -> (SQLValue -> a)
getColumnValueSelector (ColDesc _ _ _ f) = f
toValueOrNull :: (a -> SQLValue) -> Maybe a -> SQLValue
toValueOrNull _ Nothing = SQLNull
toValueOrNull f (Just v) = f v
sqlKeyOrNull :: (key -> Int) -> Maybe key -> SQLValue
sqlKeyOrNull _ Nothing = SQLNull
sqlKeyOrNull key2int (Just k) = SQLInt (key2int k)
sqlIntOrNull :: (Maybe Int) -> SQLValue
sqlIntOrNull Nothing = SQLNull
sqlIntOrNull (Just a) = SQLInt a
sqlFloatOrNull :: (Maybe Float) -> SQLValue
sqlFloatOrNull Nothing = SQLNull
sqlFloatOrNull (Just a) = SQLFloat a
sqlCharOrNull :: (Maybe Char) -> SQLValue
sqlCharOrNull Nothing = SQLNull
sqlCharOrNull (Just a) = SQLChar a
sqlStringOrNull :: (Maybe String) -> SQLValue
sqlStringOrNull Nothing = SQLNull
sqlStringOrNull (Just a) = SQLString a
sqlString :: String -> SQLValue
sqlString a = SQLString a
sqlBoolOrNull :: (Maybe Bool) -> SQLValue
sqlBoolOrNull Nothing = SQLNull
sqlBoolOrNull (Just a) = SQLBool a
sqlDateOrNull :: (Maybe ClockTime) -> SQLValue
sqlDateOrNull Nothing = SQLNull
sqlDateOrNull (Just a) = SQLDate a
keyOrNothing :: (Int -> key) -> SQLValue -> Maybe key
keyOrNothing _ SQLNull = Nothing
keyOrNothing keycon (SQLInt k) = Just (keycon k)
intOrNothing :: SQLValue -> (Maybe Int)
intOrNothing SQLNull = Nothing
intOrNothing (SQLInt a) = Just a
floatOrNothing :: SQLValue -> (Maybe Float)
floatOrNothing SQLNull = Nothing
floatOrNothing (SQLFloat a) = Just a
charOrNothing :: SQLValue -> (Maybe Char)
charOrNothing SQLNull = Nothing
charOrNothing (SQLChar a) = Just a
stringOrNothing :: SQLValue -> (Maybe String)
stringOrNothing SQLNull = Nothing
stringOrNothing (SQLString a) = Just a
fromStringOrNull :: SQLValue -> String
fromStringOrNull SQLNull = ""
fromStringOrNull (SQLString a) = a
boolOrNothing :: SQLValue -> (Maybe Bool)
boolOrNothing SQLNull = Nothing
boolOrNothing (SQLBool a) = Just a
dateOrNothing :: SQLValue -> (Maybe ClockTime)
dateOrNothing SQLNull = Nothing
dateOrNothing (SQLDate a) = Just a |