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
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
|
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Database.CDBI.Criteria (
Criteria(..), Constraint(..), ColVal(..), GroupBy,
Option, Value(..), CValue, CColumn, Condition(..), Specifier(..),
emptyCriteria, int, float, char, string, bool, date,
col, idVal, colNum, colVal, colValAlt, isNull, isNotNull, equal,
(.=.), notEqual, (./=.), greaterThan, (.>.), lessThan, (.<.),
greaterThanEqual, (.<=.), lessThanEqual, (.>=.),
like, (.~.), between, isIn, (.<->.), toCValue, toCColumn,
ascOrder, descOrder, groupBy, having, groupByCol, trCriteria,
trConstraint, trCondition, trValue, trColumn,trSpecifier,
trOption, sumIntCol, sumFloatCol, countCol, avgIntCol,
avgFloatCol, minCol, maxCol, condition, noHave) where
import Data.List (intercalate)
import Data.Time (ClockTime)
import Database.CDBI.Connection (SQLValue (..), SQLType(..), valueToString)
import Database.CDBI.Description (Column (..), Table)
data Criteria = Criteria Constraint (Maybe GroupBy)
data Specifier = Distinct | All
data Option = AscOrder CValue
| DescOrder CValue
data GroupBy = GroupBy CValue GroupByTail
data GroupByTail = Having Condition | GBT CValue GroupByTail | NoHave
data Condition = Con Constraint
| Fun String Specifier Constraint
| HAnd [Condition]
| HOr [Condition]
| Neg Condition
data Value a = Val SQLValue | Col (Column a) Int
data ColVal = ColVal CColumn CValue
type CColumn = Column ()
type CValue = Value ()
data Constraint
= IsNull CValue
| IsNotNull CValue
| BinaryRel RelOp CValue CValue
| Between CValue CValue CValue
| IsIn CValue [CValue]
| Not Constraint
| And [Constraint]
| Or [Constraint]
| Exists Table Int Constraint
| None
data RelOp = Eq | Neq | Lt | Lte | Gt | Gte | Like
emptyCriteria :: Criteria
emptyCriteria = Criteria None Nothing
int :: Int -> Value Int
int = Val . SQLInt
float :: Float -> Value Float
float = Val . SQLFloat
char :: Char -> Value Char
char = Val . SQLChar
string :: String -> Value String
string = Val . SQLString
bool :: Bool -> Value Bool
bool = Val . SQLBool
date :: ClockTime -> Value ClockTime
date = Val . SQLDate
idVal :: Int -> Value _
idVal i = Val (SQLInt i)
val :: SQLValue -> Value _
val v = (Val v)
col :: Column a -> Value a
col c = Col c 0
colNum :: Column a -> Int -> Value a
colNum c n = Col c n
colVal :: Column a -> Value a -> ColVal
colVal c v = ColVal (toCColumn c) (toCValue v)
colValAlt :: String -> String -> SQLValue -> ColVal
colValAlt table cl s =
ColVal (toCColumn
(Column ("\"" ++ cl ++ "\"")
("\"" ++ table ++ "\".\"" ++ "\"" ++ cl ++ "\"")))
(Val s)
isNull :: Value a -> Constraint
isNull v1 = IsNull (toCValue v1)
isNotNull :: Value a -> Constraint
isNotNull v1 = IsNotNull (toCValue v1)
equal :: Value a -> Value a -> Constraint
equal v1 v2 = BinaryRel Eq (toCValue v1) (toCValue v2)
(.=.) :: Value a -> Value a -> Constraint
(.=.) = equal
notEqual :: Value a -> Value a -> Constraint
notEqual v1 v2 = BinaryRel Neq (toCValue v1) (toCValue v2)
(./=.) :: Value a -> Value a -> Constraint
(./=.) = notEqual
greaterThan :: Value a -> Value a -> Constraint
greaterThan v1 v2 = BinaryRel Gt (toCValue v1) (toCValue v2)
(.>.) :: Value a -> Value a -> Constraint
(.>.) = greaterThan
lessThan :: Value a -> Value a -> Constraint
lessThan v1 v2 = BinaryRel Lt (toCValue v1) (toCValue v2)
(.<.) :: Value a -> Value a -> Constraint
(.<.) = lessThan
greaterThanEqual :: Value a -> Value a -> Constraint
greaterThanEqual v1 v2 = BinaryRel Gte (toCValue v1) (toCValue v2)
(.>=.) :: Value a -> Value a -> Constraint
(.>=.) = greaterThanEqual
lessThanEqual :: Value a -> Value a -> Constraint
lessThanEqual v1 v2 = BinaryRel Lte (toCValue v1) (toCValue v2)
(.<=.) :: Value a -> Value a -> Constraint
(.<=.) = lessThanEqual
like :: Value a -> Value a -> Constraint
like v1 v2 = BinaryRel Like (toCValue v1) (toCValue v2)
(.~.) :: Value a -> Value a -> Constraint
(.~.) = like
between :: Value a -> Value a -> Value a -> Constraint
between v1 v2 v3 = Between (toCValue v1) (toCValue v2) (toCValue v3)
isIn :: Value a -> [Value a] -> Constraint
isIn v1 xs = IsIn (toCValue v1) (map toCValue xs)
(.<->.) :: Value a -> [Value a] -> Constraint
(.<->.) = isIn
ascOrder :: Value a -> Option
ascOrder v = AscOrder (toCValue v)
descOrder :: Value a -> Option
descOrder v = DescOrder (toCValue v)
groupBy :: Value a -> GroupByTail -> GroupBy
groupBy c gbTail = GroupBy (toCValue c) gbTail
groupByCol :: Value a -> GroupByTail -> GroupByTail
groupByCol c gbTail = GBT (toCValue c) gbTail
having :: Condition -> GroupByTail
having con = Having con
noHave :: GroupByTail
noHave = NoHave
condition :: Constraint -> Condition
condition con = Con con
sumIntCol :: Specifier -> Value Int -> Value Int
-> (Value () -> Value () -> Constraint) -> Condition
sumIntCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v)))
sumFloatCol :: Specifier -> Value Float -> Value Float
-> (Value () -> Value () -> Constraint) -> Condition
sumFloatCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v)))
avgIntCol :: Specifier -> Value Int -> Value Float
-> (Value () -> Value () -> Constraint) -> Condition
avgIntCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v)))
avgFloatCol :: Specifier -> Value Float -> Value Float
-> (Value () -> Value () -> Constraint) -> Condition
avgFloatCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v)))
countCol :: Specifier -> Value _ -> Value Int
-> (Value () -> Value () -> Constraint) -> Condition
countCol spec c v op = (Fun "Count " spec (op (toCValue c) (toCValue v)))
minCol :: Specifier -> Value a -> Value a
-> (Value () -> Value () -> Constraint) -> Condition
minCol spec c v op = (Fun "Min " spec (op (toCValue c) (toCValue v)))
maxCol :: Specifier -> Value a -> Value a
-> (Value () -> Value () -> Constraint) -> Condition
maxCol spec c v op = (Fun "Max " spec (op (toCValue c) (toCValue v)))
toCColumn :: Column a -> Column ()
toCColumn (Column s1 s2) = (Column s1 s2)
toCValue :: Value a -> CValue
toCValue (Col (Column s1 s2) n) = Col (Column s1 s2) n
toCValue (Val v1) = Val v1
trCriteria :: Criteria -> String
trCriteria crit = case crit of
(Criteria None group) -> trGroup group
(Criteria c group) -> " where " ++ trConstraint c ++ " "
++ trGroup group
trOption :: [Option] -> String
trOption [] = ""
trOption (ls@((AscOrder _):_)) = " order by " ++
intercalate ", " (map trOption' ls)
trOption (ls@((DescOrder _):_)) = " order by " ++
intercalate ", " (map trOption' ls)
trOption' :: Option -> String
trOption' (AscOrder v) = trValue v ++ " asc"
trOption' (DescOrder v) = trValue v ++ " desc"
trGroup :: (Maybe GroupBy) -> String
trGroup Nothing = ""
trGroup (Just (GroupBy cs gbTail)) = " group by " ++ trValue cs ++
trTail gbTail
trTail :: GroupByTail -> String
trTail (GBT cs gbTail) = ", "++ trValue cs ++ trTail gbTail
trTail NoHave = ""
trTail (Having cond) = " Having " ++ trCondition cond
trCondition :: Condition -> String
trCondition (HAnd conds) = intercalate " and " (map trCondition conds)
trCondition (HOr conds) = intercalate " or " (map trCondition conds)
trCondition (Con cons) = trConstraint cons
trCondition (Neg cond) = "(not "++ (trCondition cond)++")"
trCondition (Fun fun spec cons) = "("++fun ++ "("++trSpecifier spec ++constr
where ('(':'(':constr) = trConstraint cons
trConstraint :: Constraint -> String
trConstraint (IsNull v) = paren $ (paren $ trValue v) ++ " is NULL"
trConstraint (IsNotNull v) = paren $ (paren $ trValue v) ++ " is not NULL"
trConstraint (BinaryRel rel v1 v2)
= paren $ (paren $ trValue v1) ++ trRelOp rel ++ trValue v2
trConstraint (Between v1 v2 v3)
= paren $ (paren $ trValue v1) ++ " between " ++ trValue v2 ++ " and " ++ trValue v3
trConstraint (IsIn v vs)
= paren $ trValue v ++ " in " ++ paren (intercalate ", " $ map trValue vs)
trConstraint (Not c) = paren $ "not " ++ trConstraint c
trConstraint (And [] ) = ""
trConstraint (And cs@(_:_)) = paren $ intercalate " and " (map trConstraint cs)
trConstraint (Or [] ) = ""
trConstraint (Or cs@(_:_)) = paren $ intercalate " or " (map trConstraint cs)
trConstraint (Exists table n cs) =
"(exists (select * from '" ++ table ++ "' " ++
(asTable table n) ++ " " ++ (trCriteria (Criteria cs Nothing)) ++ "))"
trRelOp :: RelOp -> String
trRelOp Eq = " == "
trRelOp Neq = " <> "
trRelOp Lt = " < "
trRelOp Lte = " <= "
trRelOp Gt = " > "
trRelOp Gte = " >= "
trRelOp Like = " like "
trValue :: Value a -> String
trValue (Val v) = valueToString v
trValue (Col (Column _ c) n) = trColumn c n
trColumn :: String -> Int -> String
trColumn ('"':table_column) n =
if n==0 then '"' : table_column
else '"' : show n ++ table_column
paren :: String -> String
paren s = '(' : s ++ ")"
asTable :: Table -> Int -> Table
asTable table n = case n of
0 -> ""
m -> " as '" ++ (show m) ++ table ++ "'"
trSpecifier :: Specifier -> String
trSpecifier All = ""
trSpecifier Distinct = "Distinct "
|