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
--- ----------------------------------------------------------------------------
--- This module provides datatypes, constructor functions and translation
--- functions to specify SQL criteria including options
--- (group-by, having, order-by)
---
--- @author Mike Tallarek, Julia Krone
--- ----------------------------------------------------------------------------
{-# 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)

-- -----------------------------------------------------------------------------
-- Datatypes for constructing SQL criteria
-- -----------------------------------------------------------------------------

--- Criterias for queries that can have a constraint and a group-by clause
data Criteria = Criteria Constraint (Maybe GroupBy)

--- specifier for queries
data Specifier = Distinct | All

--- datatype to represent order-by statement
data Option = AscOrder CValue
            | DescOrder CValue

--- datatype to represent group-by statement
data GroupBy = GroupBy CValue GroupByTail

--- subtype for additional columns or having-Clause in group-by statement
data GroupByTail = Having Condition | GBT CValue GroupByTail |  NoHave

--- datatype for conditions inside a having-clause
data Condition = Con Constraint
               | Fun String Specifier Constraint
               | HAnd [Condition]
               | HOr [Condition]
               | Neg Condition

--- A datatype to compare values.
--- Can be either a SQLValue or a Column with an additional
--- Integer (rename-number). The Integer is for dealing with renamed
--- tables in queries (i.e. Students as 1Students). If the Integer n is 0
--- the column will be named as usual ("Table"."Column"), otherwise it will
--- be named "nTable"."Column" in the query This is for being able to do
--- complex "where exists" constraints
data Value a = Val SQLValue | Col (Column a) Int

--- A datatype thats a combination between a Column and a Value
--- (Needed for update queries)
data ColVal = ColVal CColumn CValue

--- Type for columns used inside a constraint.
type CColumn = Column ()

--- Type for values used inside a constraint.
type CValue = Value ()

--- Constraints for queries
--- Every constructor with at least one value has a function as a constructor
--- and only that function will be exported to assure type-safety
--- Most of these are just like the Sql-where-commands Exists needs the
--- table-name, an integer and maybe a constraint
--- (where exists (select * from table where constraint))
--- The integer n will rename the table if it has a different value than 0
--- (where exists (select * from table as ntable where...))
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

-- -----------------------------------------------------------------------------
-- Constructor functions
-- -----------------------------------------------------------------------------

--- An empty criteria
emptyCriteria :: Criteria
emptyCriteria = Criteria None Nothing

--- Constructor for a Value Val of type Int
--- @param i - The value
int :: Int -> Value Int
int = Val . SQLInt

--- Constructor for a Value Val of type Float
--- @param i - The value
float :: Float -> Value Float
float = Val . SQLFloat

--- Constructor for a Value Val of type Char
--- @param i - The value
char :: Char -> Value Char
char = Val . SQLChar

--- Constructor for a Value Val of type String
--- @param i - The value
string :: String -> Value String
string = Val . SQLString

--- Constructor for a Value Val of type Bool
--- @param i - The value
bool :: Bool -> Value Bool
bool = Val . SQLBool

--- Constructor for a Value Val of type ClockTime
--- @param i - The value
date :: ClockTime -> Value ClockTime
date = Val . SQLDate

--- Constructor for Values of ID-types
--- Should just be used internally!
idVal :: Int -> Value _
idVal i = Val (SQLInt i)

val :: SQLValue -> Value _
val v = (Val v)

--- Constructor for a Value Col without a rename-number
--- @param c - The column
col :: Column a -> Value a
col c = Col c 0

--- Constructor for a Value Col with a rename-number
--- @param c - The column
--- @param n - The rename-number
colNum :: Column a -> Int -> Value a
colNum c n = Col c n

--- A constructor for ColVal needed for typesafety
--- @param c - The Column
--- @param v - The Value
colVal :: Column a -> Value a -> ColVal
colVal c v = ColVal (toCColumn c) (toCValue v)

--- Alternative ColVal constructor without typesafety
--- @param table - The Tablename of the column
--- @param cl - The column name
--- @param s - The SQLValue
colValAlt :: String -> String -> SQLValue -> ColVal
colValAlt table cl s =
     ColVal (toCColumn
            (Column ("\"" ++ cl ++ "\"")
                    ("\"" ++ table ++ "\".\"" ++ "\"" ++ cl ++ "\"")))
            (Val s)

--- IsNull construnctor
--- @param v1 - First Value
isNull :: Value a -> Constraint
isNull v1 = IsNull (toCValue v1)

--- IsNotNull construnctor
--- @param v1 - First Value
isNotNull :: Value a -> Constraint
isNotNull v1 = IsNotNull (toCValue v1)

--- Equal construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
equal :: Value a -> Value a -> Constraint
equal v1 v2 = BinaryRel Eq (toCValue v1) (toCValue v2)

--- Infix Equal
(.=.) :: Value a -> Value a -> Constraint
(.=.) = equal

--- NotEqual construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
notEqual :: Value a -> Value a -> Constraint
notEqual v1 v2 = BinaryRel Neq (toCValue v1) (toCValue v2)

--- Infix NotEqual
(./=.) :: Value a -> Value a -> Constraint
(./=.) = notEqual

--- GreatherThan construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
greaterThan :: Value a -> Value a -> Constraint
greaterThan v1 v2 = BinaryRel Gt (toCValue v1) (toCValue v2)

--- Infix GreaterThan
(.>.) :: Value a -> Value a -> Constraint
(.>.) = greaterThan

--- LessThan construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
lessThan :: Value a -> Value a -> Constraint
lessThan v1 v2 = BinaryRel Lt (toCValue v1) (toCValue v2)

--- Infix LessThan
(.<.) :: Value a -> Value a -> Constraint
(.<.) = lessThan

--- GreaterThanEqual construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
greaterThanEqual :: Value a -> Value a -> Constraint
greaterThanEqual v1 v2 = BinaryRel Gte (toCValue v1) (toCValue v2)

--- Infix GreaterThanEqual
(.>=.) :: Value a -> Value a -> Constraint
(.>=.) = greaterThanEqual

--- LessThanEqual construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
lessThanEqual :: Value a -> Value a -> Constraint
lessThanEqual v1 v2 = BinaryRel Lte (toCValue v1) (toCValue v2)

--- Infix LessThanEqual
(.<=.) :: Value a -> Value a -> Constraint
(.<=.) = lessThanEqual

--- Like construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
like :: Value a -> Value a -> Constraint
like v1 v2 = BinaryRel Like (toCValue v1) (toCValue v2)

--- Infix Like
(.~.) :: Value a -> Value a -> Constraint
(.~.) = like

--- Between construnctor
--- @param v1 - First Value
--- @param v2 - Second Value
--- @param v3 - Third Value
between :: Value a -> Value a -> Value a -> Constraint
between v1 v2 v3 = Between (toCValue v1) (toCValue v2) (toCValue v3)

--- IsIn construnctor
--- @param v1 - First Value
--- @param xs - List of Values
isIn :: Value a -> [Value a] -> Constraint
isIn v1 xs = IsIn (toCValue v1) (map toCValue xs)

--- Infix IsIn
(.<->.) :: Value a -> [Value a] -> Constraint
(.<->.) = isIn

--- Constructor for the option: Ascending Order by Column
--- @param c - The Column that should be ordered by
ascOrder :: Value a -> Option
ascOrder v = AscOrder (toCValue v)

--- Constructor for the option: Descending Order by Column
--- @param c - The Column that should be ordered by
descOrder :: Value a -> Option
descOrder v = DescOrder (toCValue v)

---Constructor for group-by-clause
---@param c - The Column that should be grouped by
---@param gbTail - GroupByTail, i.e. more columns or a having-clause
groupBy :: Value a -> GroupByTail -> GroupBy
groupBy c gbTail = GroupBy (toCValue c) gbTail

--- Constructor to specifiy more than one column for group-by
--- @param c - the additional column
--- @param gbTail - subsequent part of group-by statement
groupByCol :: Value a -> GroupByTail -> GroupByTail
groupByCol c gbTail = GBT (toCValue c) gbTail

---Constructor for having condition
---@param con - The condition
having :: Condition -> GroupByTail
having con = Having con

--- Constructor for empty having-Clause
noHave :: GroupByTail
noHave = NoHave

---Constructor for Condition with just a simple Constraint
condition :: Constraint -> Condition
condition con = Con con

---Constructor for aggregation function sum for columns of type Int
--- having-clauses.
---@param spec - specifier Distinct or All
---@param c - Column that is to be summed up
---@param v - value the result is compared to (has to be of type Int)
---@param op - relating operator
sumIntCol :: Specifier -> Value Int -> Value Int
                       -> (Value () -> Value () -> Constraint) -> Condition
sumIntCol spec c v op =  (Fun "Sum " spec (op (toCValue c) (toCValue v)))

--- Constructor for aggregation function sum for columns of type float
--- in having-clauses.
---@param spec - specifier Distinct or All
---@param c - Column that is to be summed up
---@param v - value the result is compared to (has to be of type float)
---@param op - relating operator
sumFloatCol :: Specifier -> Value Float -> Value Float
                       -> (Value () -> Value () -> Constraint) -> Condition
sumFloatCol spec c v op =  (Fun "Sum " spec (op (toCValue c) (toCValue v)))

--- Constructor for aggregation function avg for columns of type Int
--- in having-clauses.
---@param spec - specifier Distinct or All
---@param c - Column that is to be averaged
---@param v - value the result is compared to (has to be of type float)
---@param op - relating operator
avgIntCol :: Specifier -> Value Int -> Value Float
                       -> (Value () -> Value () -> Constraint) -> Condition
avgIntCol spec c v op =  (Fun "Avg " spec (op (toCValue c) (toCValue v)))

--- Constructor for aggregation function avg for columns of type float
--- in having-clauses.
---@param spec - specifier Distinct or All
---@param c - Column that is to be avaraged
---@param v - value the result is compared to (has to be of type float)
---@param op - relating operator
avgFloatCol :: Specifier -> Value Float -> Value Float
                       -> (Value () -> Value () -> Constraint) -> Condition
avgFloatCol spec c v op =  (Fun "Avg " spec (op (toCValue c) (toCValue v)))

---Constructor for aggregation function count in having-clauses.
---@param spec - specifier Distinct or All
---@param c - Column which elements are to be counted
---@param v - value the result is compared to (has to be of type Int).
---@param op - relating operator
countCol :: Specifier -> Value _ -> Value Int
                       -> (Value () -> Value () -> Constraint) -> Condition
countCol spec c v op = (Fun "Count " spec (op (toCValue c) (toCValue v)))

--- Constructor for aggregation function min in having-clauses.
--- @param spec - specifier Distinct or All
---@param c - column the minimal element has to be extracted from
---@param v - value to compare to the minimal value, same type as column
---@param op - operator
minCol :: Specifier -> Value a -> Value a
                       -> (Value () -> Value () -> Constraint) -> Condition
minCol spec c v op = (Fun "Min " spec (op (toCValue c) (toCValue v)))

--- Constructor for aggregation function max in having-clauses.
--- @param spec - specifier Distinct or All
---@param c - column the maximal element has to be extracted from
---@param v - value to compare to the maximal value, same type as column
---@param op - operator
maxCol :: Specifier -> Value a -> Value a
                       -> (Value () -> Value () -> Constraint) -> Condition
maxCol spec c v op = (Fun "Max " spec (op (toCValue c) (toCValue v)))

--Convert to UnitType
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


-- -----------------------------------------------------------------------------
-- Translation of a constraint into a SQL string.
-- -----------------------------------------------------------------------------

-- Translate Criteria to a string in a sql-query
trCriteria :: Criteria -> String
trCriteria crit = case crit of
  (Criteria None group)  -> trGroup group
  (Criteria c group)     -> " where " ++ trConstraint c ++ " "
                            ++ trGroup group

-- Translate an Order-by to a string in a sql-query
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"

-- translate a group-by to a string in a sql-query
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


-- Translate a Constraint to a string in a sql-query
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 "

-- Translate a Value to a String
trValue :: Value a -> String
trValue (Val              v) = valueToString v
trValue (Col (Column _ c) n) = trColumn c n

-- Translate "Table.Column" to "nTable.Colum" where n is the Integer-Parameter
trColumn :: String -> Int -> String
trColumn ('"':table_column) n =
  if n==0 then '"' : table_column
          else '"' : show n ++ table_column
{-
trColumn ("\"" ++ table ++ "\"." ++ column) n =
    case n of
        0 -> "\"" ++ table ++ "\"." ++ column
        m -> "\"" ++ (show m) ++ table ++ "\"." ++ column
-}






paren :: String -> String
paren s = '(' : s ++ ")"

-- Create the "as tablename" string
asTable :: Table -> Int -> Table
asTable table n = case n of
                      0 -> ""
                      m -> " as '" ++ (show m) ++ table ++ "'"

--Translate specifier
trSpecifier :: Specifier -> String
trSpecifier All = ""
trSpecifier Distinct = "Distinct "