txt-sushi-0.4.0: Database/TxtSushi/SQLExecution.hs
-----------------------------------------------------------------------------
-- |
-- Module : Database.TxtSushi.SQLExecution
-- Copyright : (c) Keith Sheppard 2009
-- License : GPL3 or greater
-- Maintainer : keithshep@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Module for executing a SQL statement
--
-----------------------------------------------------------------------------
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
-- | We will use the sort configuration to determine whether tables should
-- be sorted external or in memory
data SortConfiguration =
UseInMemorySort |
UseExternalSort deriving Show
sortByCfg :: (Binary b) => SortConfiguration -> (b -> b -> Ordering) -> [b] -> [b]
sortByCfg UseInMemorySort = sortBy
sortByCfg UseExternalSort = externalSortBy
-- | an SQL table data structure
-- TODO: need allColumnsColumnIdentifiers and allColumnsTableRows so that
-- we can filter and order on columns that are selected out. we also
-- should track any column ordering that is in place
data DatabaseTable = DatabaseTable {
-- | the columns in this table
columnIdentifiers :: [ColumnIdentifier],
-- | the actual table data
tableRows :: [[EvaluatedExpression]]}
data GroupedTable = GroupedTable {
groupColumnIdentifiers :: [ColumnIdentifier],
tableGroups :: [[[EvaluatedExpression]]]}
data EvaluatedExpression =
StringExpression String |
RealExpression Double |
IntExpression Int |
BoolExpression Bool deriving Show
-- order evaluated expressions using our type coercion rules where possible
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
-- base equality off of the Ord definition. pretty simple huh?
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 -- TOOD: floor OK for negatives too?
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"
-- convert a text table to a database table by using the 1st row as column IDs
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
{-
optimizeClassicJoins :: SelectStatement -> SelectStatement
optimizeClassicJoins selectStmt@(SelectStatement _ (Just fromTbl) (Just whereFilter) _ _) =
let (optFromTbl, optMaybeWhereFilter) = optimizeFromWhere Nothing fromTbl whereFilter
in selectStmt {
maybeFromTable = Just optFromTbl,
maybeWhereFilter = optMaybeWhereFilter}
optimizeClassicJoins selectStmt = selectStmt
optimizeFromWhere :: Maybe String -> TableExpression -> Maybe Expression -> (TableExpression, Maybe Expression)
optimizeFromWhere maybeParentAlias _ Nothing =
(fromTbl, Just expr)
optimizeFromWhere maybeParentAlias fromTbl@(InnerJoin leftJoinTbl rightJoinTbl _ maybeChildAlias) (Just expr) =
let
maybeAlias = case maybeParentAlias of
Nothing -> maybeChildAlias
Just - -> maybeParentAlias
(optLeftTbl, expr2) = optimizeFromWhere maybeAlias leftJoinTbl expr
(optRightTbl, expr3) = optimizeFromWhere maybeAlias rightJoinTbl expr2
optFromTbl = fromTbl {
leftJoinTable,
rightJoinTable}
in
(optFromTbl, Just expr3)
-}
-- | perform a SQL select with the given select statement on the
-- given table map
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
-- for the case where we find aggregate functions but
-- no "GROUP BY" part, that means we should apply the
-- aggregate to the table as a single group
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
-- TODO this approach wont let you refer to an alias in the column selection
appendAliasColumns :: [ColumnSelection] -> DatabaseTable -> DatabaseTable
appendAliasColumns [] dbTable = dbTable
appendAliasColumns cols dbTable@(DatabaseTable colIds tblRows) =
let colAliasExprs = extractColumnAliases cols
-- TODO which is the right fold here?
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
-- | sorts table rows by the given order by items
orderRowsBy :: SortConfiguration -> [OrderByItem] -> DatabaseTable -> DatabaseTable
orderRowsBy _ [] dbTable = dbTable
orderRowsBy sortCfg orderBys dbTable =
let
-- curry in the order and col ID params to make a row comparison function
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
-- curry in the order and col ID params to make a group comparison function
compareGroups = compareGroupsOnOrderItems orderBys (groupColumnIdentifiers groupedTable)
sortedGroups = sortByCfg sortCfg compareGroups (tableGroups groupedTable)
in
groupedTable {tableGroups = sortedGroups}
-- | Compares two rows using the given OrderByItems and column ID's
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)
-- | Compares two rows using the given OrderByItem and column ID's
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
-- | reverses the given ordering. pretty CRAZY huh???
reverseOrdering :: Ordering -> Ordering
reverseOrdering EQ = EQ
reverseOrdering LT = GT
reverseOrdering GT = LT
-- | Compares two rows using the given expressions
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)
-- | Compares two rows using the given expression
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
-- curry in the exprs and col ID params to make a row comparison function
compareRows = compareRowsOnExpressions groupByExprs (columnIdentifiers dbTable)
row1 `rowsEq` row2 = (row1 `compareRows` row2) == EQ
sortedRows = sortByCfg sortCfg compareRows tblRows
rowGroups = groupBy rowsEq sortedRows
-- | Evaluate the FROM table part, and returns the FROM table. Also returns
-- a mapping of new table names from aliases etc.
evalTableExpression :: SortConfiguration -> TableExpression -> (Map.Map String DatabaseTable) -> DatabaseTable
evalTableExpression sortCfg tblExpr tableMap =
case tblExpr of
TableIdentifier tblName maybeTblAlias ->
let
-- find the from table map (error if missing)
noTblError = error $ "failed to find table named " ++ tblName
table = Map.findWithDefault noTblError tblName tableMap
in
maybeRename maybeTblAlias table
-- TODO inner join should allow joining on expressions too!!
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)
-- TODO implement me
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
-- Only expecting "AND" or "="
_ -> onPartFormattingError
where
extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)]
-- Only expecting "AND" or "="
extractJoinColPair _ _ = onPartFormattingError
-- Only expecting "AND" or "="
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\""
-- | perform an inner join using the given join indices on the given
-- tables
innerJoin :: [(Int, Int)] -> DatabaseTable -> DatabaseTable -> DatabaseTable
innerJoin joinIndices leftJoinTbl rightJoinTbl = DatabaseTable {
columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),
tableRows = joinTables joinIndices (tableRows leftJoinTbl) (tableRows rightJoinTbl)}
-- | perform a cross join using the given join indices on the given
-- tables
crossJoin :: DatabaseTable -> DatabaseTable -> DatabaseTable
crossJoin leftJoinTbl rightJoinTbl = DatabaseTable {
columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),
tableRows = crossJoinTables (tableRows leftJoinTbl) (tableRows rightJoinTbl)}
-- | convert the column ID pairs into index pairs
joinColumnIndices :: DatabaseTable -> DatabaseTable -> [(ColumnIdentifier, ColumnIdentifier)] -> [(Int, Int)]
joinColumnIndices leftJoinTbl rightJoinTbl joinCols =
let
leftHeader = columnIdentifiers leftJoinTbl
rightHeader = columnIdentifiers rightJoinTbl
in
map (idPairToIndexPair leftHeader rightHeader) joinCols
-- | convert the column ID pair into an index pair
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])
-- | This is a little different that a strict equals compare in that it returns
-- true if the query column has a Nothing table and the column name part
-- matches the reference column's name. Also not that this makes it
-- an asymetric comparison
columnMatches :: ColumnIdentifier -> ColumnIdentifier -> Bool
columnMatches (ColumnIdentifier Nothing queryColIdStr) referenceColumn =
-- In this case we don't care about the table name so
-- just check to make sure that the column names match up
queryColIdStr == columnId referenceColumn
columnMatches queryColumn referenceColumn =
-- table name is important here so match on the whole object
queryColumn == referenceColumn
-- | filters the database's table rows on the given expression
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))
-- | evaluate the given expression against a table
-- TODO need better error detection and reporting for non-aggregate
-- expressions
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
-- | evaluate the given expression against a table row
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
-- TODO this ugly function needs to be modularized
evalSQLFunction :: SQLFunction -> [EvaluatedExpression] -> EvaluatedExpression
evalSQLFunction sqlFun evaluatedArgs
-- Global validation
-- TODO this error should be more helpful than it is
| argCountIsInvalid =
error $ "cannot apply " ++ show (length evaluatedArgs) ++
" arguments to " ++ functionName sqlFun
-- String functions
| 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)
-- unary functions
| sqlFun == absFunction = evalUnaryAlgebra abs abs
| sqlFun == negateFunction = evalUnaryAlgebra negate negate
-- algebraic
| sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs
| sqlFun == divideFunction = RealExpression $ (coerceReal arg1) / (coerceReal arg2)
| sqlFun == plusFunction = algebraWithCoercion (+) (+) evaluatedArgs
| sqlFun == minusFunction = algebraWithCoercion (-) (-) evaluatedArgs
-- boolean
| 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)
-- aggregate
-- TODO AVG(...) holds the whole arg list in memory. reimplement!
| 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
-- error!!
| 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
-- TODO the use of length is bad (unnecessarily traversing
-- the entire arg list and keeping it in memory). Redo this
-- so that we only check length w.r.t. minArgs
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)
-- | trims leading and trailing spaces
trimSpace :: String -> String
trimSpace = f . f
where f = reverse . dropWhile isSpace