----------------------------------------------------------------------------- -- | -- Module : Database.TxtSushi.SQLFunctionDefinitions -- Copyright : (c) Keith Sheppard 2009-2010 -- License : BSD3 -- Maintainer : keithshep@gmail.com -- Stability : experimental -- Portability : portable -- -- SQL Function definitions. This is where you can extend TxtSushi by adding -- new function definitions. -- ----------------------------------------------------------------------------- module Database.TxtSushi.SQLFunctionDefinitions ( SQLFunction(..), normalSyntaxFunctions, infixFunctions, specialFunctions, -- TODO remove these negateFunction, countFunction, substringFromToFunction, substringFromFunction, notFunction) where import Data.Char import Data.List import Data.Maybe import Text.Regex.Posix import Database.TxtSushi.EvaluatedExpression import Database.TxtSushi.SQLExpression -- Functions with "normal" syntax -- normalSyntaxFunctions :: [SQLFunction] normalSyntaxFunctions = [absFunction, upperFunction, lowerFunction, trimFunction, lengthFunction, ifThenElseFunction, asIntFunction, asRealFunction, isNumericFunction, -- all aggregates except count which accepts a (*) avgFunction, firstFunction, lastFunction, maxFunction, minFunction, sumFunction] -- non aggregates isNumericFunction :: SQLFunction isNumericFunction = SQLFunction { functionName = "IS_NUMERIC", minArgCount = 1, argCountIsFixed = True, applyFunction = BoolExpression. isJust . maybeCoerceReal . head . checkArgCount isNumericFunction, functionGrammar = normalGrammar isNumericFunction, functionDescription = "determines if the argument can be coerced to a numeric " ++ "type without error (Eg: using AS_REAL, AS_INT, +, etc...)"} asIntFunction :: SQLFunction asIntFunction = SQLFunction { functionName = "AS_INT", minArgCount = 1, argCountIsFixed = True, applyFunction = IntExpression . coerceInt . head . checkArgCount asIntFunction, functionGrammar = normalGrammar asIntFunction, functionDescription = "converts the argument to an integer " ++ "(failure to convert will cause the program " ++ "to halt with an error message)"} asRealFunction :: SQLFunction asRealFunction = SQLFunction { functionName = "AS_REAL", minArgCount = 1, argCountIsFixed = True, applyFunction = RealExpression . coerceReal . head . checkArgCount asRealFunction, functionGrammar = normalGrammar asRealFunction, functionDescription = "converts the argument to an real number " ++ "(failure to convert will cause the program " ++ "to halt with an error message)"} absFunction :: SQLFunction absFunction = SQLFunction { functionName = "ABS", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryNumeric absFunction abs abs, functionGrammar = normalGrammar absFunction, functionDescription = "absolute value function"} upperFunction :: SQLFunction upperFunction = SQLFunction { functionName = "UPPER", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryString upperFunction (map toUpper), functionGrammar = normalGrammar upperFunction, functionDescription = "converts the given text to upper case"} lowerFunction :: SQLFunction lowerFunction = SQLFunction { functionName = "LOWER", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryString lowerFunction (map toLower), functionGrammar = normalGrammar lowerFunction, functionDescription = "converts the given text to lower case"} trimFunction :: SQLFunction trimFunction = SQLFunction { functionName = "TRIM", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryString trimFunction trimSpace, functionGrammar = normalGrammar trimFunction, functionDescription = "trims whitespace from the beginning and end of the given text"} lengthFunction :: SQLFunction lengthFunction = SQLFunction { functionName = "LEN", minArgCount = 1, argCountIsFixed = True, applyFunction = IntExpression . length . coerceString . head . checkArgCount lengthFunction, functionGrammar = normalGrammar lengthFunction, functionDescription = "the number of characters in the given text"} ifThenElseFunction :: SQLFunction ifThenElseFunction = SQLFunction { functionName = "IF_THEN_ELSE", minArgCount = 3, argCountIsFixed = True, applyFunction = ifThenElse . checkArgCount ifThenElseFunction, functionGrammar = normalGrammar ifThenElseFunction, functionDescription = "if arg1 evaluates as true return arg2, else return arg3"} where ifThenElse [ifExpr, thenExpr, elseExpr] = if coerceBool ifExpr then thenExpr else elseExpr ifThenElse _ = internalError -- aggregates avgFunction :: SQLFunction avgFunction = SQLFunction { functionName = "AVG", minArgCount = 1, argCountIsFixed = False, applyFunction = avgFun . checkArgCount avgFunction, functionGrammar = normalGrammar avgFunction, functionDescription = "aggregate average function"} -- TODO this AVG(...) holds the whole arg list in memory. reimplement! where avgFun args = RealExpression $ foldl1' (+) (map coerceReal args) / (fromIntegral $ length args) countFunction :: SQLFunction countFunction = SQLFunction { functionName = "COUNT", minArgCount = 0, argCountIsFixed = False, applyFunction = IntExpression . length, functionGrammar = normalGrammar countFunction, functionDescription = "aggregate function for calculating group size"} firstFunction :: SQLFunction firstFunction = SQLFunction { functionName = "FIRST", minArgCount = 1, argCountIsFixed = False, applyFunction = head . checkArgCount firstFunction, functionGrammar = normalGrammar firstFunction, functionDescription = "aggregate function returning only the first element of every group"} lastFunction :: SQLFunction lastFunction = SQLFunction { functionName = "LAST", minArgCount = 1, argCountIsFixed = False, applyFunction = last . checkArgCount lastFunction, functionGrammar = normalGrammar lastFunction, functionDescription = "aggregate function returning only the last element of every group"} maxFunction :: SQLFunction maxFunction = SQLFunction { functionName = "MAX", minArgCount = 1, argCountIsFixed = False, applyFunction = maximum . checkArgCount maxFunction, functionGrammar = normalGrammar maxFunction, functionDescription = "aggregate function returning the maximum element of every group"} minFunction :: SQLFunction minFunction = SQLFunction { functionName = "MIN", minArgCount = 1, argCountIsFixed = False, applyFunction = minimum . checkArgCount minFunction, functionGrammar = normalGrammar minFunction, functionDescription = "aggregate function returning the minimum element of every group"} sumFunction :: SQLFunction sumFunction = SQLFunction { functionName = "SUM", minArgCount = 0, argCountIsFixed = False, applyFunction = foldl stepSum (IntExpression 0), functionGrammar = normalGrammar sumFunction, functionDescription = "aggregate function which summs all elements in each group"} where stepSum prevSum currArg = if useRealAlgebra prevSum || useRealAlgebra currArg then RealExpression $ coerceReal prevSum + coerceReal currArg else IntExpression $ coerceInt prevSum + coerceInt currArg -- Infix functions -- infixFunctions :: [[SQLFunction]] infixFunctions = [[multiplyFunction, divideFunction], [plusFunction, minusFunction], [concatenateFunction], [isFunction, isNotFunction, lessThanFunction, lessThanOrEqualToFunction, greaterThanFunction, greaterThanOrEqualToFunction, regexMatchFunction], [andFunction], [orFunction]] -- Algebraic multiplyFunction :: SQLFunction multiplyFunction = SQLFunction { functionName = "*", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryNumeric multiplyFunction (*) (*), functionGrammar = binaryInfixGrammar multiplyFunction, functionDescription = "multiplies the left and right expressions"} divideFunction :: SQLFunction divideFunction = SQLFunction { functionName = "/", minArgCount = 2, argCountIsFixed = True, applyFunction = divFun . checkArgCount divideFunction, functionGrammar = binaryInfixGrammar divideFunction, functionDescription = "divides the left expression by the right expression"} where divFun [numExpr, denomExpr] = RealExpression $ (coerceReal numExpr) / (coerceReal denomExpr) divFun _ = internalError plusFunction :: SQLFunction plusFunction = SQLFunction { functionName = "+", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryNumeric plusFunction (+) (+), functionGrammar = binaryInfixGrammar plusFunction, functionDescription = "adds the left and right expressions"} minusFunction :: SQLFunction minusFunction = SQLFunction { functionName = "-", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryNumeric minusFunction (-) (-), functionGrammar = binaryInfixGrammar minusFunction, functionDescription = "subtracts the right expression from the left expression"} -- Boolean isFunction :: SQLFunction isFunction = SQLFunction { functionName = "=", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison isFunction (==), functionGrammar = binaryInfixGrammar isFunction, functionDescription = "tests the left and right expressions for equality"} isNotFunction :: SQLFunction isNotFunction = SQLFunction { functionName = "<>", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison isNotFunction (/=), functionGrammar = binaryInfixGrammar isNotFunction, functionDescription = "evaluates as true if the left and right expressions are not equal"} lessThanFunction :: SQLFunction lessThanFunction = SQLFunction { functionName = "<", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison lessThanFunction (<), functionGrammar = binaryInfixGrammar lessThanFunction, functionDescription = "evaluates as true if the left expression is \"less than\" the right expression"} lessThanOrEqualToFunction :: SQLFunction lessThanOrEqualToFunction = SQLFunction { functionName = "<=", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison lessThanOrEqualToFunction (<=), functionGrammar = binaryInfixGrammar lessThanOrEqualToFunction, functionDescription = "evaluates as true if the left expression is \"less than or equal to\" the right expression"} greaterThanFunction :: SQLFunction greaterThanFunction = SQLFunction { functionName = ">", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison greaterThanFunction (>), functionGrammar = binaryInfixGrammar greaterThanFunction, functionDescription = "evaluates as true if the left expression is \"greater than\" the right expression"} greaterThanOrEqualToFunction :: SQLFunction greaterThanOrEqualToFunction = SQLFunction { functionName = ">=", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryComparison greaterThanOrEqualToFunction (>=), functionGrammar = binaryInfixGrammar greaterThanOrEqualToFunction, functionDescription = "evaluates as true if the left expression is \"greater than or equal to\" the right expression"} andFunction :: SQLFunction andFunction = SQLFunction { functionName = "AND", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryBooleanTest andFunction (&&), functionGrammar = binaryInfixGrammar andFunction, functionDescription = "evaluates as true if and only if both the left and right expressions are true"} orFunction :: SQLFunction orFunction = SQLFunction { functionName = "OR", minArgCount = 2, argCountIsFixed = True, applyFunction = applyBinaryBooleanTest orFunction (||), functionGrammar = binaryInfixGrammar orFunction, functionDescription = "evaluates as true if and only if either the left or right expressions are true"} concatenateFunction :: SQLFunction concatenateFunction = SQLFunction { functionName = "||", minArgCount = 2, argCountIsFixed = True, applyFunction = catExprs . checkArgCount concatenateFunction, functionGrammar = binaryInfixGrammar concatenateFunction, functionDescription = "performs string concatenation of the left and right strings"} where catExprs [arg1, arg2] = StringExpression $ (coerceString arg1) ++ (coerceString arg2) catExprs _ = internalError regexMatchFunction :: SQLFunction regexMatchFunction = SQLFunction { functionName = "=~", minArgCount = 2, argCountIsFixed = True, applyFunction = regexMatch . checkArgCount regexMatchFunction, functionGrammar = binaryInfixGrammar regexMatchFunction, functionDescription = "evaluates as true if and only if the text on the left matches the regular expression on the right"} where regexMatch [arg1, arg2] = BoolExpression $ (coerceString arg1) =~ (coerceString arg2) regexMatch _ = internalError -- Functions with special syntax -- specialFunctions :: [SQLFunction] specialFunctions = [substringFromFunction, substringFromToFunction, negateFunction, notFunction] negateFunction :: SQLFunction negateFunction = SQLFunction { functionName = "-", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryNumeric negateFunction negate negate, functionGrammar = "-numeric_expression", functionDescription = "unary negation"} -- | SUBSTRING(extraction_string FROM starting_position [FOR length] -- [COLLATE collation_name]) -- TODO implement COLLATE part substringFromFunction :: SQLFunction substringFromFunction = SQLFunction { functionName = "SUBSTRING", minArgCount = 2, argCountIsFixed = True, applyFunction = substringFrom . checkArgCount substringFromFunction, functionGrammar = "SUBSTRING(string_expression FROM start_index [FOR length_expression])", functionDescription = "returns substring of string_expression going from " ++ "start_index using 1-based indexing for a length of length_expression " ++ " or to the end of string_expression if the FOR part is omitted"} where substringFrom [strExpr, fromExpr] = StringExpression $ drop (coerceInt fromExpr - 1) (coerceString strExpr) substringFrom _ = internalError substringFromToFunction :: SQLFunction substringFromToFunction = SQLFunction { functionName = "SUBSTRING", minArgCount = 3, argCountIsFixed = True, applyFunction = substringFromTo . checkArgCount substringFromToFunction, functionGrammar = "SUBSTRING(string_expression FROM start_index [FOR length_expression])", functionDescription = "returns substring of string_expression going from " ++ "start_index using 1-based indexing for a length of length_expression " ++ " or to the end of string_expression if the FOR part is omitted"} where substringFromTo [strExpr, fromExpr, toExpr] = StringExpression $ take (coerceInt toExpr) (drop (coerceInt fromExpr - 1) (coerceString strExpr)) substringFromTo _ = internalError notFunction :: SQLFunction notFunction = SQLFunction { functionName = "NOT", minArgCount = 1, argCountIsFixed = True, applyFunction = applyUnaryBool notFunction not, functionGrammar = "NOT bool_expression", functionDescription = "evaluates as true if and only if bool_expression is false"} -- some evaluation helper functions applyUnaryString :: SQLFunction -> (String -> String) -> [EvaluatedExpression] -> EvaluatedExpression applyUnaryString sqlFun f = StringExpression . f . coerceString . head . checkArgCount sqlFun applyBinaryBooleanTest :: SQLFunction -> (Bool -> Bool -> Bool) -> [EvaluatedExpression] -> EvaluatedExpression applyBinaryBooleanTest _ f [arg1, arg2] = BoolExpression $ f (coerceBool arg1) (coerceBool arg2) applyBinaryBooleanTest sqlFun _ args = badArgCountError sqlFun args applyBinaryComparison :: SQLFunction -> (t -> t -> Bool) -> [t] -> EvaluatedExpression applyBinaryComparison _ cmp [arg1, arg2] = BoolExpression $ cmp arg1 arg2 applyBinaryComparison sqlFun _ args = badArgCountError sqlFun args applyUnaryNumeric :: SQLFunction -> (Int -> Int) -> (Double -> Double) -> [EvaluatedExpression] -> EvaluatedExpression applyUnaryNumeric _ intFunc realFunc [arg] = if useRealAlgebra arg then RealExpression $ realFunc (coerceReal arg) else IntExpression $ intFunc (coerceInt arg) applyUnaryNumeric sqlFun _ _ args = badArgCountError sqlFun args applyBinaryNumeric :: SQLFunction -> (Int -> Int -> Int) -> (Double -> Double -> Double) -> [EvaluatedExpression] -> EvaluatedExpression applyBinaryNumeric _ intFunc realFunc [arg1, arg2] = if useRealAlgebra arg1 || useRealAlgebra arg2 then RealExpression $ realFunc (coerceReal arg1) (coerceReal arg2) else IntExpression $ intFunc (coerceInt arg1) (coerceInt arg2) applyBinaryNumeric sqlFun _ _ args = badArgCountError sqlFun args applyUnaryBool :: SQLFunction -> (Bool -> Bool) -> [EvaluatedExpression] -> EvaluatedExpression applyUnaryBool _ f [arg] = BoolExpression $ f (coerceBool arg) applyUnaryBool sqlFun _ args = badArgCountError sqlFun args checkArgCount :: SQLFunction -> [a] -> [a] checkArgCount sqlFun args = if argCountOK then args else badArgCountError sqlFun args where minArgs = minArgCount sqlFun argCountOK = if argCountIsFixed sqlFun then lengthEquals args minArgs else lengthAtLeast args minArgs where lengthEquals xs len = go xs 0 where go [] cumLen = cumLen == len go (_:yt) cumLen = if cumLen >= len then False else go yt (cumLen + 1) lengthAtLeast xs len = go xs 0 where go [] cumLen = cumLen >= len go (_:yt) cumLen = if cumLen >= len then True else go yt (cumLen + 1) badArgCountError :: SQLFunction -> [a] -> b badArgCountError sqlFun args = if argCountIsFixed sqlFun then error $ "Error: bad argument count in " ++ functionName sqlFun ++ " expected " ++ show (minArgCount sqlFun) ++ " argument(s) but was given " ++ show received else error $ "Error: bad argument count in " ++ functionName sqlFun ++ " expected at least " ++ show (minArgCount sqlFun) ++ " argument(s) but was given " ++ show received where received = length args internalError :: a internalError = error "Internal Error: this should never occur" useRealAlgebra :: EvaluatedExpression -> Bool useRealAlgebra (RealExpression _) = True useRealAlgebra expr = case maybeCoerceInt expr of Nothing -> True Just _ -> False -- | trims leading and trailing spaces trimSpace :: String -> String trimSpace = f . f where f = reverse . dropWhile isSpace -- | some grammar helper functions normalGrammar :: SQLFunction -> String normalGrammar sqlFun = functionName sqlFun ++ "(" ++ argStr ++ ")" where argStrPrefix = intercalate ", " minArgs where minArgs = zipWith (++) (repeat "arg") (map show [1 .. minArgCount sqlFun]) argStr = if argCountIsFixed sqlFun then argStrPrefix else if minArgCount sqlFun >= 1 then argStrPrefix ++ ", ..." else "..." binaryInfixGrammar :: SQLFunction -> String binaryInfixGrammar sqlFun = "leftExpr " ++ functionName sqlFun ++ " rightExpr"