module Database.TxtSushi.SQLExecution (
select,
databaseTableToTextTable,
textTableToDatabaseTable,
SortConfiguration(..)) where
import Data.Binary
import Data.Char
import Data.List
import qualified Data.Map as Map
import Text.Regex.Posix
import Database.TxtSushi.ExternalSort
import Database.TxtSushi.SQLParser
import Database.TxtSushi.Transform
import Database.TxtSushi.Util.ListUtil
data SortConfiguration =
UseInMemorySort |
UseExternalSort deriving Show
sortByCfg :: (Binary b) => SortConfiguration -> (b -> b -> Ordering) -> [b] -> [b]
sortByCfg UseInMemorySort = sortBy
sortByCfg UseExternalSort = externalSortBy
data DatabaseTable = DatabaseTable {
columnIdentifiers :: [ColumnIdentifier],
tableRows :: [[EvaluatedExpression]]}
data GroupedTable = GroupedTable {
groupColumnIdentifiers :: [ColumnIdentifier],
tableGroups :: [[[EvaluatedExpression]]]}
data EvaluatedExpression =
StringExpression String |
RealExpression Double |
IntExpression Int |
BoolExpression Bool deriving Show
instance Ord EvaluatedExpression where
compare expr1@(RealExpression _) expr2 = expr1 `realCompare` expr2
compare expr1 expr2@(RealExpression _) = expr1 `realCompare` expr2
compare expr1@(IntExpression _) expr2 = expr1 `intCompare` expr2
compare expr1 expr2@(IntExpression _) = expr1 `intCompare` expr2
compare expr1@(BoolExpression _) expr2 = expr1 `boolCompare` expr2
compare expr1 expr2@(BoolExpression _) = expr1 `boolCompare` expr2
compare expr1 expr2 = expr1 `stringCompare` expr2
realCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering
realCompare expr1 expr2 =
maybeCoerceReal expr1 `myCompare` maybeCoerceReal expr2
where
myCompare (Just r1) (Just r2) = r1 `compare` r2
myCompare _ _ = expr1 `stringCompare` expr2
intCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering
intCompare expr1 expr2 =
maybeCoerceInt expr1 `myCompare` maybeCoerceInt expr2
where
myCompare (Just i1) (Just i2) = i1 `compare` i2
myCompare _ _ = expr1 `realCompare` expr2
boolCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering
boolCompare expr1 expr2 =
maybeCoerceBool expr1 `myCompare` maybeCoerceBool expr2
where
myCompare (Just b1) (Just b2) = b1 `compare` b2
myCompare _ _ = expr1 `stringCompare` expr2
stringCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering
stringCompare expr1 expr2 = coerceString expr1 `compare` coerceString expr2
instance Eq EvaluatedExpression where
expr1 == expr2 = expr1 `compare` expr2 == EQ
instance Binary EvaluatedExpression where
put (StringExpression s) = put (0 :: Word8) >> put s
put (RealExpression r) = put (1 :: Word8) >> put r
put (IntExpression i) = put (2 :: Word8) >> put i
put (BoolExpression b) = put (3 :: Word8) >> put b
get = do
typeWord <- get :: Get Word8
case typeWord of
0 -> get >>= return . StringExpression
1 -> get >>= return . RealExpression
2 -> get >>= return . IntExpression
3 -> get >>= return . BoolExpression
_ -> error $ "unexpected type word value: " ++ show typeWord
coerceString :: EvaluatedExpression -> String
coerceString (StringExpression string) = string
coerceString (RealExpression real) = show real
coerceString (IntExpression int) = show int
coerceString (BoolExpression bool) = if bool then "true" else "false"
maybeCoerceInt :: EvaluatedExpression -> Maybe Int
maybeCoerceInt (StringExpression string) = maybeReadInt string
maybeCoerceInt (RealExpression real) = Just $ floor real
maybeCoerceInt (IntExpression int) = Just int
maybeCoerceInt (BoolExpression _) = Nothing
coerceInt :: EvaluatedExpression -> Int
coerceInt evalExpr = case maybeCoerceInt evalExpr of
Just int -> int
Nothing ->
error $ "could not convert \"" ++ (coerceString evalExpr) ++
"\" to an integer value"
maybeCoerceReal :: EvaluatedExpression -> Maybe Double
maybeCoerceReal (StringExpression string) = maybeReadReal string
maybeCoerceReal (RealExpression real) = Just real
maybeCoerceReal (IntExpression int) = Just $ fromIntegral int
maybeCoerceReal (BoolExpression _) = Nothing
coerceReal :: EvaluatedExpression -> Double
coerceReal evalExpr = case maybeCoerceReal evalExpr of
Just real -> real
Nothing ->
error $ "could not convert \"" ++ (coerceString evalExpr) ++
"\" to a numeric value"
maybeReadBool :: String -> Maybe Bool
maybeReadBool boolStr = case map toLower $ trimSpace boolStr of
"true" -> Just True
"false" -> Just False
_ -> Nothing
maybeCoerceBool :: EvaluatedExpression -> Maybe Bool
maybeCoerceBool (StringExpression string) = maybeReadBool string
maybeCoerceBool (RealExpression _) = Nothing
maybeCoerceBool (IntExpression _) = Nothing
maybeCoerceBool (BoolExpression bool) = Just bool
coerceBool :: EvaluatedExpression -> Bool
coerceBool evalExpr = case maybeCoerceBool evalExpr of
Just bool -> bool
Nothing ->
error $ "could not convert \"" ++ (coerceString evalExpr) ++
"\" to a boolean value"
textTableToDatabaseTable :: String -> [[String]] -> DatabaseTable
textTableToDatabaseTable tblName (headerNames:tblRows) =
DatabaseTable (map makeColId headerNames) (map (map StringExpression) tblRows)
where
makeColId colName = ColumnIdentifier (Just tblName) colName
textTableToDatabaseTable tblName [] =
error $ "invalid table \"" ++ tblName ++ "\". There is no header row"
databaseTableToTextTable :: DatabaseTable -> [[String]]
databaseTableToTextTable dbTable =
let
headerRow = map columnId (columnIdentifiers dbTable)
tailRows = map (map coerceString) (tableRows dbTable)
in
headerRow:tailRows
select :: SortConfiguration -> SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable
select sortCfg selectStmt tableMap =
let
fromTbl = case maybeFromTable selectStmt of
Nothing -> DatabaseTable [] []
Just fromTblExpr -> evalTableExpression sortCfg fromTblExpr tableMap
fromTblWithAliases =
appendAliasColumns (columnSelections selectStmt) fromTbl
filteredTbl = case maybeWhereFilter selectStmt of
Nothing -> fromTblWithAliases
Just expr -> filterRowsBy expr fromTblWithAliases
in
case maybeGroupByHaving selectStmt of
Nothing ->
if selectStatementContainsAggregates selectStmt then
finishWithAggregateSelect
sortCfg
selectStmt
(GroupedTable (columnIdentifiers filteredTbl) [tableRows filteredTbl])
else
finishWithNormalSelect sortCfg selectStmt filteredTbl
Just groupByPart ->
let
tblGroups = performGroupBy sortCfg groupByPart filteredTbl
in
finishWithAggregateSelect sortCfg selectStmt tblGroups
appendAliasColumns :: [ColumnSelection] -> DatabaseTable -> DatabaseTable
appendAliasColumns [] dbTable = dbTable
appendAliasColumns cols dbTable@(DatabaseTable colIds tblRows) =
let colAliasExprs = extractColumnAliases cols
evaluatedColExprsTbl = foldl1' tableConcat (evalAliasCols colAliasExprs)
in
if null colAliasExprs
then dbTable
else dbTable `tableConcat` evaluatedColExprsTbl
where
evalAliasCols :: [(ColumnIdentifier, Expression)] -> [DatabaseTable]
evalAliasCols [] = []
evalAliasCols ((aliasColId, aliasExpr) : tailAliasExprs) =
DatabaseTable [aliasColId] [[evalExpression aliasExpr colIds row] | row <- tblRows] :
evalAliasCols tailAliasExprs
extractColumnAliases :: [ColumnSelection] -> [(ColumnIdentifier, Expression)]
extractColumnAliases [] = []
extractColumnAliases ((ExpressionColumn expr (Just alias)) : colsTail) =
(ColumnIdentifier Nothing alias, expr) : extractColumnAliases colsTail
extractColumnAliases xs = extractColumnAliases $ tail xs
finishWithNormalSelect :: SortConfiguration -> SelectStatement -> DatabaseTable -> DatabaseTable
finishWithNormalSelect sortCfg selectStmt filteredDbTable =
let
orderedTbl =
orderRowsBy sortCfg (orderByItems selectStmt) filteredDbTable
selectedTbl =
evaluateColumnSelections (columnSelections selectStmt) orderedTbl
in
selectedTbl
finishWithAggregateSelect :: SortConfiguration -> SelectStatement -> GroupedTable -> DatabaseTable
finishWithAggregateSelect sortCfg selectStmt aggregateTbls =
let
orderedTbls =
orderGroupsBy sortCfg (orderByItems selectStmt) aggregateTbls
selectedTbl =
evaluateAggregateColumnSelections (columnSelections selectStmt) orderedTbls
in
selectedTbl
performGroupBy :: SortConfiguration -> ([Expression], Maybe Expression) -> DatabaseTable -> GroupedTable
performGroupBy sortCfg (groupByExprs, maybeExpr) dbTable =
let
tblGroups = groupRowsBy sortCfg groupByExprs dbTable
in
case maybeExpr of
Nothing -> tblGroups
Just expr -> filterGroupsBy expr tblGroups
orderRowsBy :: SortConfiguration -> [OrderByItem] -> DatabaseTable -> DatabaseTable
orderRowsBy _ [] dbTable = dbTable
orderRowsBy sortCfg orderBys dbTable =
let
compareRows = compareRowsOnOrderItems orderBys (columnIdentifiers dbTable)
sortedRows = sortByCfg sortCfg compareRows (tableRows dbTable)
in
dbTable {tableRows = sortedRows}
orderGroupsBy :: SortConfiguration -> [OrderByItem] -> GroupedTable -> GroupedTable
orderGroupsBy _ [] groupedTable = groupedTable
orderGroupsBy sortCfg orderBys groupedTable =
let
compareGroups = compareGroupsOnOrderItems orderBys (groupColumnIdentifiers groupedTable)
sortedGroups = sortByCfg sortCfg compareGroups (tableGroups groupedTable)
in
groupedTable {tableGroups = sortedGroups}
compareRowsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering
compareRowsOnOrderItems orderBys colIds row1 row2 =
cascadingOrder $ toOrderList orderBys
where
toOrderList [] = []
toOrderList (orderBy:orderByTail) =
(compareRowsOnOrderItem orderBy colIds row1 row2):(toOrderList orderByTail)
compareRowsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering
compareRowsOnOrderItem orderBy colIds row1 row2 =
let
orderExpr = orderExpression orderBy
rowComp = compareRowsOnExpression orderExpr colIds row1 row2
in
if orderAscending orderBy then
rowComp
else
reverseOrdering rowComp
compareGroupsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering
compareGroupsOnOrderItems orderBys colIds group1 group2 =
cascadingOrder $ toOrderList orderBys
where
toOrderList [] = []
toOrderList (orderBy:orderByTail) =
(compareGroupsOnOrderItem orderBy colIds group1 group2):(toOrderList orderByTail)
compareGroupsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering
compareGroupsOnOrderItem orderBy colIds group1 group2 =
let
orderExpr = orderExpression orderBy
grpComp = compareGroupsOnExpression orderExpr colIds group1 group2
in
if orderAscending orderBy then
grpComp
else
reverseOrdering grpComp
reverseOrdering :: Ordering -> Ordering
reverseOrdering EQ = EQ
reverseOrdering LT = GT
reverseOrdering GT = LT
compareRowsOnExpressions :: [Expression] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering
compareRowsOnExpressions exprs colIds row1 row2 =
cascadingOrder $ toOrderList exprs
where
toOrderList [] = []
toOrderList (expr:exprTail) =
(compareRowsOnExpression expr colIds row1 row2):(toOrderList exprTail)
compareRowsOnExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering
compareRowsOnExpression expr colIds row1 row2 =
let
row1Eval = evalExpression expr colIds row1
row2Eval = evalExpression expr colIds row2
in
row1Eval `compare` row2Eval
compareGroupsOnExpression :: Expression -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering
compareGroupsOnExpression expr colIds grp1 grp2 =
evalExprOn grp1 `compare` evalExprOn grp2
where
evalExprOn grp = evalAggregateExpression expr (DatabaseTable colIds grp)
groupRowsBy :: SortConfiguration -> [Expression] -> DatabaseTable -> GroupedTable
groupRowsBy sortCfg groupByExprs dbTable =
GroupedTable (columnIdentifiers dbTable) rowGroups
where
tblRows = tableRows dbTable
compareRows = compareRowsOnExpressions groupByExprs (columnIdentifiers dbTable)
row1 `rowsEq` row2 = (row1 `compareRows` row2) == EQ
sortedRows = sortByCfg sortCfg compareRows tblRows
rowGroups = groupBy rowsEq sortedRows
evalTableExpression :: SortConfiguration -> TableExpression -> (Map.Map String DatabaseTable) -> DatabaseTable
evalTableExpression sortCfg tblExpr tableMap =
case tblExpr of
TableIdentifier tblName maybeTblAlias ->
let
noTblError = error $ "failed to find table named " ++ tblName
table = Map.findWithDefault noTblError tblName tableMap
in
maybeRename maybeTblAlias table
InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias ->
let
leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap
rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap
joinCols = extractJoinCols onConditionExpr
joinIndices = joinColumnIndices leftJoinTbl rightJoinTbl joinCols
joinedTbl = innerJoin joinIndices leftJoinTbl rightJoinTbl
in
maybeRename maybeTblAlias joinedTbl
SelectExpression selectStmt maybeTblAlias ->
maybeRename maybeTblAlias (select sortCfg selectStmt tableMap)
CrossJoin leftJoinTblExpr rightJoinTblExpr maybeTblAlias ->
let
leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap
rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap
joinedTbl = crossJoin leftJoinTbl rightJoinTbl
in
maybeRename maybeTblAlias joinedTbl
where
maybeRename :: (Maybe String) -> DatabaseTable -> DatabaseTable
maybeRename Nothing table = table
maybeRename (Just newName) table = table {
columnIdentifiers = map (\colId -> colId {maybeTableName = Just newName}) (columnIdentifiers table)}
extractJoinCols :: Expression -> [(ColumnIdentifier, ColumnIdentifier)]
extractJoinCols (FunctionExpression sqlFunc [arg1, arg2]) =
case sqlFunc of
SQLFunction "AND" _ _ -> extractJoinCols arg1 ++ extractJoinCols arg2
SQLFunction "=" _ _ -> extractJoinColPair arg1 arg2
_ -> onPartFormattingError
where
extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)]
extractJoinColPair _ _ = onPartFormattingError
extractJoinCols _ = onPartFormattingError
onPartFormattingError :: a
onPartFormattingError =
error $ "The \"ON\" part of a join must only contain column equalities " ++
"joined together by \"AND\" like: " ++
"\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\""
innerJoin :: [(Int, Int)] -> DatabaseTable -> DatabaseTable -> DatabaseTable
innerJoin joinIndices leftJoinTbl rightJoinTbl = DatabaseTable {
columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),
tableRows = joinTables joinIndices (tableRows leftJoinTbl) (tableRows rightJoinTbl)}
crossJoin :: DatabaseTable -> DatabaseTable -> DatabaseTable
crossJoin leftJoinTbl rightJoinTbl = DatabaseTable {
columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),
tableRows = crossJoinTables (tableRows leftJoinTbl) (tableRows rightJoinTbl)}
joinColumnIndices :: DatabaseTable -> DatabaseTable -> [(ColumnIdentifier, ColumnIdentifier)] -> [(Int, Int)]
joinColumnIndices leftJoinTbl rightJoinTbl joinCols =
let
leftHeader = columnIdentifiers leftJoinTbl
rightHeader = columnIdentifiers rightJoinTbl
in
map (idPairToIndexPair leftHeader rightHeader) joinCols
idPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> (Int, Int)
idPairToIndexPair leftColIds rightColIds joinColPair@(leftColId, rightColId) =
let
maybePairInOrder = maybeIdPairToIndexPair leftColIds rightColIds joinColPair
maybePairSwapped = maybeIdPairToIndexPair leftColIds rightColIds (rightColId, leftColId)
in
case maybePairInOrder of
Just thePairInOrder -> thePairInOrder
Nothing ->
case maybePairSwapped of
Just thePairSwapped -> thePairSwapped
Nothing -> error "failed to find given columns"
maybeIdPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> Maybe (Int, Int)
maybeIdPairToIndexPair leftColIds rightColIds (leftColId, rightColId) = do
leftIndex <- findIndex (== leftColId) leftColIds
rightIndex <- findIndex (== rightColId) rightColIds
return (leftIndex, rightIndex)
evaluateColumnSelections :: [ColumnSelection] -> DatabaseTable -> DatabaseTable
evaluateColumnSelections colSelections dbTable =
let
selectionTbls = map ($ dbTable) (map evaluateColumnSelection colSelections)
in
foldl1' tableConcat selectionTbls
tableConcat :: DatabaseTable -> DatabaseTable -> DatabaseTable
tableConcat dbTable1 dbTable2 =
let
concatIds = (columnIdentifiers dbTable1) ++ (columnIdentifiers dbTable2)
concatRows = zipWith (++) (tableRows dbTable1) (tableRows dbTable2)
in
DatabaseTable concatIds concatRows
evaluateAggregateColumnSelections :: [ColumnSelection] -> GroupedTable -> DatabaseTable
evaluateAggregateColumnSelections colSelections tblGroups =
let
selectionTbls = map ($ tblGroups) (map evaluateAggregateColumnSelection colSelections)
in
foldl1' tableConcat selectionTbls
evaluateAggregateColumnSelection :: ColumnSelection -> GroupedTable -> DatabaseTable
evaluateAggregateColumnSelection AllColumns _ =
error "* is not allowed for aggregate column selections"
evaluateAggregateColumnSelection (AllColumnsFrom srcTblName) _ =
error $ srcTblName ++ ".* is not allowed for aggregate column selections"
evaluateAggregateColumnSelection (ExpressionColumn expr maybeAlias) groupedTbl =
let
tbls = map makeTbl (tableGroups groupedTbl)
evaluatedExprs = map (evalAggregateExpression expr) tbls
exprColId = case maybeAlias of
Nothing -> expressionIdentifier expr
Just alias -> (expressionIdentifier expr) {columnId = alias}
in
DatabaseTable [exprColId] (transpose [evaluatedExprs])
where
makeTbl grp = DatabaseTable (groupColumnIdentifiers groupedTbl) grp
evaluateColumnSelection :: ColumnSelection -> DatabaseTable -> DatabaseTable
evaluateColumnSelection AllColumns dbTable = dbTable
evaluateColumnSelection (AllColumnsFrom srcTblName) dbTable =
let
colIds = columnIdentifiers dbTable
indices = findIndices matchesSrcTblName (map maybeTableName colIds)
selectedColIds = selectIndices indices colIds
selectedColRows = map (selectIndices indices) (tableRows dbTable)
in
DatabaseTable selectedColIds selectedColRows
where
matchesSrcTblName Nothing = False
matchesSrcTblName (Just tblName) = tblName == srcTblName
selectIndices indices xs = [xs !! i | i <- indices]
evaluateColumnSelection (ExpressionColumn expr maybeAlias) dbTable =
let
tblColIds = columnIdentifiers dbTable
exprColId = case maybeAlias of
Nothing -> expressionIdentifier expr
Just alias -> (expressionIdentifier expr) {columnId = alias}
evaluatedExprs = map (evalExpression expr tblColIds) (tableRows dbTable)
in
DatabaseTable [exprColId] (transpose [evaluatedExprs])
columnMatches :: ColumnIdentifier -> ColumnIdentifier -> Bool
columnMatches (ColumnIdentifier Nothing queryColIdStr) referenceColumn =
queryColIdStr == columnId referenceColumn
columnMatches queryColumn referenceColumn =
queryColumn == referenceColumn
filterRowsBy :: Expression -> DatabaseTable -> DatabaseTable
filterRowsBy filterExpr table =
table {tableRows = filter myBoolEvalExpr (tableRows table)}
where myBoolEvalExpr row =
coerceBool $ evalExpression filterExpr (columnIdentifiers table) row
filterGroupsBy :: Expression -> GroupedTable -> GroupedTable
filterGroupsBy expr groupedTbl =
groupedTbl {tableGroups = map tableRows filteredTbls}
where
makeTbl grp = DatabaseTable (groupColumnIdentifiers groupedTbl) grp
filterFunc = coerceBool . evalAggregateExpression expr
filteredTbls = filter filterFunc (map makeTbl (tableGroups groupedTbl))
evalAggregateExpression :: Expression -> DatabaseTable -> EvaluatedExpression
evalAggregateExpression (StringConstantExpression string) _ = StringExpression string
evalAggregateExpression (IntegerConstantExpression int) _ = IntExpression int
evalAggregateExpression (RealConstantExpression real) _ = RealExpression real
evalAggregateExpression (ColumnExpression col) dbTable =
case findIndex (columnMatches col) (columnIdentifiers dbTable) of
Just colIndex -> (head $ tableRows dbTable) !! colIndex
Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col)
evalAggregateExpression (FunctionExpression sqlFun funArgs) dbTable =
evalSQLFunction sqlFun $ if isAggregate sqlFun then manyArgs else aggregatedArgs
where
aggregatedArgs = map (\e -> evalAggregateExpression e dbTable) funArgs
manyArgs =
let
tblColIds = columnIdentifiers dbTable
tblRows = tableRows dbTable
evaluateExprs expr = map (evalExpression expr tblColIds) tblRows
allArgs = concatMap evaluateExprs funArgs
in
allArgs
evalExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> EvaluatedExpression
evalExpression (StringConstantExpression string) _ _ = StringExpression string
evalExpression (IntegerConstantExpression int) _ _ = IntExpression int
evalExpression (RealConstantExpression real) _ _ = RealExpression real
evalExpression (ColumnExpression col) columnIds tblRow =
case findIndex (columnMatches col) columnIds of
Just colIndex -> tblRow !! colIndex
Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col)
evalExpression (FunctionExpression sqlFun funArgs) columnIds tblRow =
evalSQLFunction sqlFun (map evalArgExpr funArgs)
where
evalArgExpr expr = evalExpression expr columnIds tblRow
evalSQLFunction :: SQLFunction -> [EvaluatedExpression] -> EvaluatedExpression
evalSQLFunction sqlFun evaluatedArgs
| argCountIsInvalid =
error $ "cannot apply " ++ show (length evaluatedArgs) ++
" arguments to " ++ functionName sqlFun
| sqlFun == upperFunction = StringExpression $ map toUpper (coerceString arg1)
| sqlFun == lowerFunction = StringExpression $ map toLower (coerceString arg1)
| sqlFun == trimFunction = StringExpression $ trimSpace (coerceString arg1)
| sqlFun == concatenateFunction = StringExpression $ concat (map coerceString evaluatedArgs)
| sqlFun == substringFromToFunction =
StringExpression $ take (coerceInt arg3) (drop (coerceInt arg2 1) (coerceString arg1))
| sqlFun == substringFromFunction =
StringExpression $ drop (coerceInt arg2 1) (coerceString arg1)
| sqlFun == regexMatchFunction = BoolExpression $ (coerceString arg1) =~ (coerceString arg2)
| sqlFun == absFunction = evalUnaryAlgebra abs abs
| sqlFun == negateFunction = evalUnaryAlgebra negate negate
| sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs
| sqlFun == divideFunction = RealExpression $ (coerceReal arg1) / (coerceReal arg2)
| sqlFun == plusFunction = algebraWithCoercion (+) (+) evaluatedArgs
| sqlFun == minusFunction = algebraWithCoercion () () evaluatedArgs
| sqlFun == isFunction = BoolExpression (arg1 == arg2)
| sqlFun == isNotFunction = BoolExpression (arg1 /= arg2)
| sqlFun == lessThanFunction = BoolExpression (arg1 < arg2)
| sqlFun == lessThanOrEqualToFunction = BoolExpression (arg1 <= arg2)
| sqlFun == greaterThanFunction = BoolExpression (arg1 > arg2)
| sqlFun == greaterThanOrEqualToFunction = BoolExpression (arg1 >= arg2)
| sqlFun == andFunction = BoolExpression $ (coerceBool arg1) && (coerceBool arg2)
| sqlFun == orFunction = BoolExpression $ (coerceBool arg1) || (coerceBool arg2)
| sqlFun == notFunction = BoolExpression $ not (coerceBool arg1)
| sqlFun == avgFunction =
RealExpression $
foldl1' (+) (map coerceReal evaluatedArgs) /
(fromIntegral $ length evaluatedArgs)
| sqlFun == countFunction = IntExpression $ length evaluatedArgs
| sqlFun == firstFunction = head evaluatedArgs
| sqlFun == lastFunction = last evaluatedArgs
| sqlFun == maxFunction = maximum evaluatedArgs
| sqlFun == minFunction = minimum evaluatedArgs
| sqlFun == sumFunction = algebraWithCoercion (+) (+) evaluatedArgs
| otherwise = error $
"internal error: missing evaluation code for function: " ++
functionName sqlFun ++ ". please report this error"
where
arg1 = head evaluatedArgs
arg2 = evaluatedArgs !! 1
arg3 = evaluatedArgs !! 2
algebraWithCoercion intFunc realFunc args =
if any useRealAlgebra args then
RealExpression $ foldl1' realFunc (map coerceReal args)
else
IntExpression $ foldl1' intFunc (map coerceInt args)
useRealAlgebra (RealExpression _) = True
useRealAlgebra expr = case maybeCoerceInt expr of
Nothing -> True
Just _ -> False
argCountIsInvalid =
let
argCount = length evaluatedArgs
minArgs = minArgCount sqlFun
argsFixed = argCountIsFixed sqlFun
in
argCount < minArgs || (argCount > minArgs && argsFixed)
evalUnaryAlgebra intFunc realFunc =
if length evaluatedArgs /= 1 then
error $
"internal error: found a " ++ show sqlFun ++
" function with multiple args. please report this error"
else
if useRealAlgebra arg1 then
RealExpression $ realFunc (coerceReal arg1)
else
IntExpression $ intFunc (coerceInt arg1)
trimSpace :: String -> String
trimSpace = f . f
where f = reverse . dropWhile isSpace