|
sourcecode:
|
{-# 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 "
|