diff --git a/Database/TxtSushi/ExternalSort.hs b/Database/TxtSushi/ExternalSort.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/ExternalSort.hs @@ -0,0 +1,165 @@ +module Database.TxtSushi.ExternalSort ( + externalSort, + externalSortBy, + externalSortByConstrained, + defaultByteQuota, + defaultMaxOpenFiles) where + +import Control.Monad +import Data.Binary +import Data.Binary.Get +import Data.Int +import qualified Data.ByteString.Lazy as BS +import Data.List +import System.IO +import System.IO.Unsafe +import System.Directory + +-- | performs an external sort on the given list using the default resource +-- constraints +externalSort :: (Binary b, Ord b) => [b] -> [b] +externalSort = externalSortBy compare + +-- | performs an external sort on the given list using the given comparison +-- function and the default resource constraints +externalSortBy :: (Binary b) => (b -> b -> Ordering) -> [b] -> [b] +externalSortBy = externalSortByConstrained defaultByteQuota defaultMaxOpenFiles + +-- | Currently 16 MB. Don't rely on this value staying the same in future +-- releases! +defaultByteQuota :: Int +defaultByteQuota = 16 * 1024 * 1024 + +-- | Currently 17 files. Don't rely on this value staying the same in future +-- releases! +defaultMaxOpenFiles :: Int +defaultMaxOpenFiles = 17 + +-- | performs an external sort on the given list using the given resource +-- constraints +{-# NOINLINE externalSortByConstrained #-} +externalSortByConstrained :: (Binary b, Integral i) => i -> i -> (b -> b -> Ordering) -> [b] -> [b] +externalSortByConstrained byteQuota maxOpenFiles cmp xs = unsafePerformIO $ do + partialSortFiles <- bufferPartialSortsBy (fromIntegral byteQuota) cmp xs + + -- now we must merge together the partial sorts + externalMergeAllBy (fromIntegral maxOpenFiles) cmp partialSortFiles + +-- | merge a list of sorted lists into a single sorted list +mergeAllBy :: (a -> a -> Ordering) -> [[a]] -> [a] +mergeAllBy _ [] = [] +mergeAllBy _ [singletonList] = singletonList +mergeAllBy cmp (fstList:sndList:[]) = mergeBy cmp fstList sndList +mergeAllBy cmp listList = + -- recurse after breking the list down by about 1/2 the size + mergeAllBy cmp (partitionAndMerge 2 cmp listList) + +-- TODO add a smart adjustment so that the last partition will not ever +-- be more than 1 element different than the others + +-- | partitions the given sorted lists into groupings containing `partitionSize` +-- or fewer lists then merges each of those partitions. So the returned +-- list should normally be shorter than the given list +partitionAndMerge :: Int -> (a -> a -> Ordering) -> [[a]] -> [[a]] +partitionAndMerge _ _ [] = [] +partitionAndMerge partitionSize cmp listList = + map (mergeAllBy cmp) (regularPartitions partitionSize listList) + +-- | chops up the given list at regular intervals +regularPartitions :: Int -> [a] -> [[a]] +regularPartitions _ [] = [] +regularPartitions partitionSize xs = + let (currPartition, otherXs) = splitAt partitionSize xs + in currPartition : regularPartitions partitionSize otherXs + +-- | merge two sorted lists into a single sorted list +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy _ [] list2 = list2 +mergeBy _ list1 [] = list1 +mergeBy comparisonFunction list1@(head1:tail1) list2@(head2:tail2) = + case head1 `comparisonFunction` head2 of + GT -> head2 : mergeBy comparisonFunction list1 tail2 + _ -> head1 : mergeBy comparisonFunction tail1 list2 + +externalMergePass :: Binary b => Int -> (b -> b -> Ordering) -> [String] -> IO [String] +externalMergePass _ _ [] = return [] +externalMergePass maxOpenFiles cmp files = do + -- we use (maxOpenFiles - 1) because we need to account for the file + -- handle that we're reading from + let (mergeNowFiles, mergeLaterFiles) = splitAt (maxOpenFiles - 1) files + + mergeNowBinStrs <- readThenDelBinFiles mergeNowFiles + let mergeNowBinaries = map decodeAll mergeNowBinStrs + mergedNowFile <- bufferToTempFile $ mergeAllBy cmp mergeNowBinaries + + mergedLaterFiles <- externalMergePass maxOpenFiles cmp mergeLaterFiles + + return $ mergedNowFile : mergedLaterFiles + +externalMergeAllBy :: Binary b => Int -> (b -> b -> Ordering) -> [String] -> IO [b] +externalMergeAllBy _ _ [] = return [] +-- TODO do i need to write singleton lists to file in order to keep the max open file promise?? +externalMergeAllBy _ _ [singletonFile] = + readThenDelBinFile singletonFile >>= return . decodeAll +externalMergeAllBy maxOpenFiles cmp files = do + partiallyMergedFiles <- externalMergePass maxOpenFiles cmp files + externalMergeAllBy maxOpenFiles cmp partiallyMergedFiles + +-- | create a list of parial sorts +bufferPartialSortsBy :: (Binary b) => Int64 -> (b -> b -> Ordering) -> [b] -> IO [String] +bufferPartialSortsBy _ _ [] = return [] +bufferPartialSortsBy byteQuota cmp xs = do + let (sortNowList, sortLaterList) = splitAfterQuota byteQuota xs + sortedRows = sortBy cmp sortNowList + sortBuffer <- bufferToTempFile sortedRows + otherSortBuffers <- bufferPartialSortsBy byteQuota cmp sortLaterList + return (sortBuffer:otherSortBuffers) + +-- TODO not efficiet! we're converting to binary twice so that we don't have +-- the bytestrings buffered to memory during the sort (that would about double +-- our mem usage). I think the right answer is to add a class extending binary +-- that has a sizeOf function +splitAfterQuota :: (Binary b) => Int64 -> [b] -> ([b], [b]) +splitAfterQuota _ [] = ([], []) +splitAfterQuota quotaInBytes (binaryHead:binaryTail) = + let + quotaRemaining = quotaInBytes - BS.length (encode binaryHead) + (fstBinsTail, sndBins) = splitAfterQuota quotaRemaining binaryTail + in + if quotaRemaining <= 0 + then ([binaryHead], binaryTail) + else (binaryHead:fstBinsTail, sndBins) + +-- | lazily reads then deletes the given files +readThenDelBinFiles :: [String] -> IO [BS.ByteString] +readThenDelBinFiles = sequence . map readThenDelBinFile + +-- | lazily reads then deletes the given file after the last byte is read +readThenDelBinFile :: String -> IO BS.ByteString +readThenDelBinFile fileName = do + binStr <- BS.readFile fileName + emptyStr <- unsafeInterleaveIO $ removeFile fileName >> return BS.empty + + return $ binStr `BS.append` emptyStr + +-- | buffer the binaries to a temporary file and return a handle to that file +bufferToTempFile :: (Binary b) => [b] -> IO String +bufferToTempFile [] = return [] +bufferToTempFile xs = do + tempDir <- getTemporaryDirectory + (tempFilePath, tempFileHandle) <- openBinaryTempFile tempDir "sort.txt" + + BS.hPut tempFileHandle (encodeAll xs) + hClose tempFileHandle + + return tempFilePath + +encodeAll :: (Binary b) => [b] -> BS.ByteString +encodeAll = BS.concat . map encode + +decodeAll :: (Binary b) => BS.ByteString -> [b] +decodeAll bs + | BS.null bs = [] + | otherwise = + let (decodedBin, remainingBs, _) = runGetState get bs 0 + in decodedBin : decodeAll remainingBs diff --git a/Database/TxtSushi/IO.hs b/Database/TxtSushi/IO.hs --- a/Database/TxtSushi/IO.hs +++ b/Database/TxtSushi/IO.hs @@ -24,7 +24,10 @@ fieldDelimiter :: String, rowDelimiter :: String} deriving (Show) +csvFormat :: Format csvFormat = Format "\"" "," "\n" + +tabDelimitedFormat :: Format tabDelimitedFormat = Format "\"" "\t" "\n" {- | @@ -33,6 +36,7 @@ doubleQuote :: Format -> String doubleQuote format = (quote format) ++ (quote format) +formatTableWithWidths :: String -> [Int] -> [[String]] -> String formatTableWithWidths _ _ [] = [] formatTableWithWidths boundaryString widths (row:tableTail) = let @@ -65,10 +69,11 @@ -- this filthy little function is for making the list strict... otherwise -- we run out of memory +seqList :: [a] -> Bool seqList [] = False -seqList (head:tail) - | head `seq` False = undefined - | otherwise = seqList tail +seqList (x:xt) + | x `seq` False = undefined + | otherwise = seqList xt maxRowFieldWidths :: [String] -> [Int] -> [Int] maxRowFieldWidths row prevMaxValues = @@ -106,6 +111,7 @@ {- | encode the given text field if it contains any special formatting characters -} +encodeField :: Format -> String -> String encodeField format field = if (quote format) `isInfixOf` field then let escapedField = replaceAll field (quote format) (doubleQuote format) diff --git a/Database/TxtSushi/SQLExecution.hs b/Database/TxtSushi/SQLExecution.hs --- a/Database/TxtSushi/SQLExecution.hs +++ b/Database/TxtSushi/SQLExecution.hs @@ -14,17 +14,30 @@ module Database.TxtSushi.SQLExecution ( select, databaseTableToTextTable, - textTableToDatabaseTable) where + 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 @@ -36,188 +49,271 @@ -- | the actual table data tableRows :: [[EvaluatedExpression]]} -emptyTable = DatabaseTable [] [] +data GroupedTable = GroupedTable { + groupColumnIdentifiers :: [ColumnIdentifier], + tableGroups :: [[[EvaluatedExpression]]]} -stringExpression :: String -> EvaluatedExpression -stringExpression string = EvaluatedExpression { - preferredType = StringType, - maybeIntValue = maybeReadInt string, - maybeRealValue = maybeReadReal string, - stringValue = string, - maybeBoolValue = Just $ - (map toLower string /= "false") && (string /= "") && (string /= "0")} +data EvaluatedExpression = + StringExpression String | + RealExpression Double | + IntExpression Int | + BoolExpression Bool deriving Show -intExpression int = EvaluatedExpression { - preferredType = IntType, - maybeIntValue = Just int, - maybeRealValue = Just $ fromIntegral int, - stringValue = show int, - maybeBoolValue = Just $ int /= 0} +-- 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 -realExpression real = EvaluatedExpression { - preferredType = RealType, - maybeIntValue = Just $ floor real, - maybeRealValue = Just real, - stringValue = show real, - maybeBoolValue = Just $ real /= 0.0} +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 -boolExpression bool = EvaluatedExpression { - preferredType = BoolType, - maybeIntValue = Nothing, - maybeRealValue = Nothing, - stringValue = show bool, - maybeBoolValue = Just bool} +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 -intValue :: EvaluatedExpression -> Int -intValue evalExpr = case maybeIntValue evalExpr of +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 \"" ++ (stringValue evalExpr) ++ + error $ "could not convert \"" ++ (coerceString evalExpr) ++ "\" to an integer value" -realValue :: EvaluatedExpression -> Double -realValue evalExpr = case maybeRealValue evalExpr of +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 \"" ++ (stringValue evalExpr) ++ + error $ "could not convert \"" ++ (coerceString evalExpr) ++ "\" to a numeric value" -boolValue :: EvaluatedExpression -> Bool -boolValue evalExpr = case maybeBoolValue evalExpr of - Just bool -> bool - Nothing -> - error $ "could not convert \"" ++ (stringValue evalExpr) ++ - "\" to a boolean value" - -data ExpressionType = StringType | RealType | IntType | BoolType deriving Eq - -data EvaluatedExpression = EvaluatedExpression { - preferredType :: ExpressionType, - stringValue :: String, - maybeRealValue :: Maybe Double, - maybeIntValue :: Maybe Int, - maybeBoolValue :: Maybe Bool} - maybeReadBool :: String -> Maybe Bool -maybeReadBool boolStr = case map toLower boolStr of +maybeReadBool boolStr = case map toLower $ trimSpace boolStr of "true" -> Just True - "1" -> Just True - "1.0" -> Just True "false" -> Just False - "0" -> Just False - "0.0" -> Just False - otherwise -> Nothing - -instance Eq EvaluatedExpression where - -- base off of the Ord definition - expr1 == expr2 = compare expr1 expr2 == EQ - -instance Ord EvaluatedExpression where - compare expr1 expr2 - | type1 == RealType || type2 == RealType = realCompare expr1 expr2 - | type1 == IntType || type2 == IntType = intCompare expr1 expr2 - | type1 == BoolType || type2 == BoolType = boolCompare expr1 expr2 - | otherwise = stringCompare expr1 expr2 - - where - type1 = preferredType expr1 - type2 = preferredType expr2 - -realCompare (EvaluatedExpression _ _ (Just r1) _ _) (EvaluatedExpression _ _ (Just r2) _ _) = - compare r1 r2 -realCompare expr1 expr2 = stringCompare expr1 expr2 - -intCompare (EvaluatedExpression _ _ _ (Just i1) _) (EvaluatedExpression _ _ _ (Just i2) _) = - compare i1 i2 -intCompare expr1 expr2 = realCompare expr1 expr2 + _ -> Nothing -boolCompare (EvaluatedExpression _ _ _ _ (Just b1)) (EvaluatedExpression _ _ _ _ (Just b2)) = - compare b1 b2 -boolCompare expr1 expr2 = stringCompare expr1 expr2 +maybeCoerceBool :: EvaluatedExpression -> Maybe Bool +maybeCoerceBool (StringExpression string) = maybeReadBool string +maybeCoerceBool (RealExpression _) = Nothing +maybeCoerceBool (IntExpression _) = Nothing +maybeCoerceBool (BoolExpression bool) = Just bool -stringCompare expr1 expr2 = stringValue expr1 `compare` stringValue expr2 +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 tableName (headerNames:tblRows) = - DatabaseTable (map makeColId headerNames) (map (map stringExpression) tblRows) +textTableToDatabaseTable tblName (headerNames:tblRows) = + DatabaseTable (map makeColId headerNames) (map (map StringExpression) tblRows) where - makeColId colName = ColumnIdentifier (Just tableName) colName + 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 stringValue) (tableRows dbTable) + 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 :: SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable -select selectStatement tableMap = +select :: SortConfiguration -> SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable +select sortCfg selectStmt tableMap = let - -- TODO: do we need to care about the updated aliases for filtering - -- in the "where" part?? - fromTbl = case maybeFromTable selectStatement of - Nothing -> emptyTable - Just fromTblExpr -> evalTableExpression fromTblExpr tableMap - filteredTbl = case maybeWhereFilter selectStatement of - Nothing -> fromTbl - Just expr -> filterRowsBy expr fromTbl + 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 selectStatement of + case maybeGroupByHaving selectStmt of Nothing -> - if selectStatementContainsAggregates selectStatement then - finishWithAggregateSelect selectStatement [filteredTbl] + 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 selectStatement filteredTbl + finishWithNormalSelect sortCfg selectStmt filteredTbl Just groupByPart -> let - tblGroups = performGroupBy groupByPart filteredTbl + tblGroups = performGroupBy sortCfg groupByPart filteredTbl in - finishWithAggregateSelect selectStatement tblGroups + finishWithAggregateSelect sortCfg selectStmt tblGroups -finishWithNormalSelect selectStatement filteredDbTable = +-- 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 (orderByItems selectStatement) filteredDbTable + orderedTbl = + orderRowsBy sortCfg (orderByItems selectStmt) filteredDbTable selectedTbl = - evaluateColumnSelections (columnSelections selectStatement) orderedTbl + evaluateColumnSelections (columnSelections selectStmt) orderedTbl in selectedTbl -finishWithAggregateSelect selectStatement aggregateTbls = +finishWithAggregateSelect :: SortConfiguration -> SelectStatement -> GroupedTable -> DatabaseTable +finishWithAggregateSelect sortCfg selectStmt aggregateTbls = let - orderedTbls = orderTablesBy (orderByItems selectStatement) aggregateTbls + orderedTbls = + orderGroupsBy sortCfg (orderByItems selectStmt) aggregateTbls selectedTbl = - evaluateAggregateColumnSelections (columnSelections selectStatement) orderedTbls + evaluateAggregateColumnSelections (columnSelections selectStmt) orderedTbls in selectedTbl -performGroupBy :: ([Expression], Maybe Expression) -> DatabaseTable -> [DatabaseTable] -performGroupBy (groupByExprs, maybeExpr) dbTable = +performGroupBy :: SortConfiguration -> ([Expression], Maybe Expression) -> DatabaseTable -> GroupedTable +performGroupBy sortCfg (groupByExprs, maybeExpr) dbTable = let - tblGroups = groupRowsBy groupByExprs dbTable + tblGroups = groupRowsBy sortCfg groupByExprs dbTable in case maybeExpr of Nothing -> tblGroups - Just expr -> filterTablesBy expr tblGroups + Just expr -> filterGroupsBy expr tblGroups -- | sorts table rows by the given order by items -orderRowsBy :: [OrderByItem] -> DatabaseTable -> DatabaseTable -orderRowsBy [] dbTable = dbTable -orderRowsBy orderBys dbTable = +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 = sortBy compareRows (tableRows dbTable) + sortedRows = sortByCfg sortCfg compareRows (tableRows dbTable) in dbTable {tableRows = sortedRows} -orderTablesBy :: [OrderByItem] -> [DatabaseTable] -> [DatabaseTable] -orderTablesBy [] dbTables = dbTables -orderTablesBy orderBys dbTables = - sortBy (compareTablesOnOrderItems orderBys) dbTables +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 @@ -240,24 +336,24 @@ else reverseOrdering rowComp -compareTablesOnOrderItems :: [OrderByItem] -> DatabaseTable -> DatabaseTable -> Ordering -compareTablesOnOrderItems orderBys dbTable1 dbTable2 = +compareGroupsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering +compareGroupsOnOrderItems orderBys colIds group1 group2 = cascadingOrder $ toOrderList orderBys where toOrderList [] = [] toOrderList (orderBy:orderByTail) = - (compareTablesOnOrderItem orderBy dbTable1 dbTable2):(toOrderList orderByTail) + (compareGroupsOnOrderItem orderBy colIds group1 group2):(toOrderList orderByTail) -compareTablesOnOrderItem :: OrderByItem -> DatabaseTable -> DatabaseTable -> Ordering -compareTablesOnOrderItem orderBy dbTable1 dbTable2 = +compareGroupsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering +compareGroupsOnOrderItem orderBy colIds group1 group2 = let orderExpr = orderExpression orderBy - rowComp = compareTablesOnExpression orderExpr dbTable1 dbTable2 + grpComp = compareGroupsOnExpression orderExpr colIds group1 group2 in if orderAscending orderBy then - rowComp + grpComp else - reverseOrdering rowComp + reverseOrdering grpComp -- | reverses the given ordering. pretty CRAZY huh??? reverseOrdering :: Ordering -> Ordering @@ -283,18 +379,15 @@ in row1Eval `compare` row2Eval -compareTablesOnExpression :: Expression -> DatabaseTable -> DatabaseTable -> Ordering -compareTablesOnExpression expr tbl1 tbl2 = - let - tbl1Eval = evalAggregateExpression expr tbl1 - tbl2Eval = evalAggregateExpression expr tbl2 - in - tbl1Eval `compare` tbl2Eval +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 :: [Expression] -> DatabaseTable -> [DatabaseTable] -groupRowsBy groupByExprs dbTable = - -- create a new table for every row grouping - map replaceTableRows rowGroups +groupRowsBy :: SortConfiguration -> [Expression] -> DatabaseTable -> GroupedTable +groupRowsBy sortCfg groupByExprs dbTable = + GroupedTable (columnIdentifiers dbTable) rowGroups where tblRows = tableRows dbTable @@ -302,14 +395,13 @@ compareRows = compareRowsOnExpressions groupByExprs (columnIdentifiers dbTable) row1 `rowsEq` row2 = (row1 `compareRows` row2) == EQ - sortedRows = sortBy compareRows tblRows + sortedRows = sortByCfg sortCfg compareRows tblRows rowGroups = groupBy rowsEq sortedRows - replaceTableRows newRows = dbTable {tableRows = newRows} -- | Evaluate the FROM table part, and returns the FROM table. Also returns -- a mapping of new table names from aliases etc. -evalTableExpression :: TableExpression -> (Map.Map String DatabaseTable) -> DatabaseTable -evalTableExpression tblExpr tableMap = +evalTableExpression :: SortConfiguration -> TableExpression -> (Map.Map String DatabaseTable) -> DatabaseTable +evalTableExpression sortCfg tblExpr tableMap = case tblExpr of TableIdentifier tblName maybeTblAlias -> let @@ -322,30 +414,40 @@ -- TODO inner join should allow joining on expressions too!! InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias -> let - leftJoinTbl = evalTableExpression leftJoinTblExpr tableMap - rightJoinTbl = evalTableExpression rightJoinTblExpr tableMap + 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 leftJoinTbl maybeTblAlias rightJoinTbl -> - error "Sorry! CROSS JOIN is not yet implemented" + 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 "=" - otherwise -> onPartFormattingError + _ -> onPartFormattingError where extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)] @@ -355,6 +457,7 @@ -- 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: " ++ @@ -367,6 +470,13 @@ 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 = @@ -411,27 +521,29 @@ in DatabaseTable concatIds concatRows -evaluateAggregateColumnSelections :: [ColumnSelection] -> [DatabaseTable] -> DatabaseTable +evaluateAggregateColumnSelections :: [ColumnSelection] -> GroupedTable -> DatabaseTable evaluateAggregateColumnSelections colSelections tblGroups = let selectionTbls = map ($ tblGroups) (map evaluateAggregateColumnSelection colSelections) in foldl1' tableConcat selectionTbls -evaluateAggregateColumnSelection :: ColumnSelection -> [DatabaseTable] -> DatabaseTable -evaluateAggregateColumnSelection AllColumns tblGroups = +evaluateAggregateColumnSelection :: ColumnSelection -> GroupedTable -> DatabaseTable +evaluateAggregateColumnSelection AllColumns _ = error "* is not allowed for aggregate column selections" -evaluateAggregateColumnSelection (AllColumnsFrom srcTblName) tblGroups = +evaluateAggregateColumnSelection (AllColumnsFrom srcTblName) _ = error $ srcTblName ++ ".* is not allowed for aggregate column selections" -evaluateAggregateColumnSelection (ExpressionColumn expr) [] = - error $ "internal error: empty aggregate table group" -evaluateAggregateColumnSelection (ExpressionColumn expr) tblGroups@(headGrp:tailGrp) = +evaluateAggregateColumnSelection (ExpressionColumn expr maybeAlias) groupedTbl = let - tblColIds = columnIdentifiers headGrp - exprColId = expressionIdentifier expr - evaluatedExprs = map (evalAggregateExpression expr) tblGroups + 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 @@ -447,10 +559,12 @@ matchesSrcTblName Nothing = False matchesSrcTblName (Just tblName) = tblName == srcTblName selectIndices indices xs = [xs !! i | i <- indices] -evaluateColumnSelection (ExpressionColumn expr) dbTable = +evaluateColumnSelection (ExpressionColumn expr maybeAlias) dbTable = let tblColIds = columnIdentifiers dbTable - exprColId = expressionIdentifier expr + 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]) @@ -474,21 +588,23 @@ filterRowsBy filterExpr table = table {tableRows = filter myBoolEvalExpr (tableRows table)} where myBoolEvalExpr row = - boolValue $ evalExpression filterExpr (columnIdentifiers table) row + coerceBool $ evalExpression filterExpr (columnIdentifiers table) row -filterTablesBy :: Expression -> [DatabaseTable] -> [DatabaseTable] -filterTablesBy expr dbTables = - filter filterFunc dbTables +filterGroupsBy :: Expression -> GroupedTable -> GroupedTable +filterGroupsBy expr groupedTbl = + groupedTbl {tableGroups = map tableRows filteredTbls} where - filterFunc = boolValue . evalAggregateExpression expr + 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 (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 @@ -509,9 +625,9 @@ -- | 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 (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 @@ -521,59 +637,54 @@ 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 - | not $ argCountIsValid = + | argCountIsInvalid = error $ "cannot apply " ++ show (length evaluatedArgs) ++ " arguments to " ++ functionName sqlFun -- String functions - | sqlFun == upperFunction = stringExpression $ map toUpper (stringValue arg1) - | sqlFun == lowerFunction = stringExpression $ map toLower (stringValue arg1) - | sqlFun == trimFunction = stringExpression $ trimSpace (stringValue arg1) - | sqlFun == concatenateFunction = stringExpression $ concat (map stringValue evaluatedArgs) + | 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 (intValue arg3) (drop (intValue arg2 - 1) (stringValue arg1)) + StringExpression $ take (coerceInt arg3) (drop (coerceInt arg2 - 1) (coerceString arg1)) | sqlFun == substringFromFunction = - stringExpression $ drop (intValue arg2 - 1) (stringValue arg1) - | sqlFun == regexMatchFunction = boolExpression $ (stringValue arg1) =~ (stringValue arg2) + StringExpression $ drop (coerceInt arg2 - 1) (coerceString arg1) + | sqlFun == regexMatchFunction = BoolExpression $ (coerceString arg1) =~ (coerceString arg2) - -- negate - | sqlFun == negateFunction = - if length evaluatedArgs /= 1 then - error $ - "internal error: found a negate function with multiple args. " ++ - "please report this error" - else - let evaldArg = head evaluatedArgs - in - if useRealAlgebra evaldArg then - realExpression $ negate (realValue evaldArg) - else - intExpression $ negate (intValue evaldArg) + -- unary functions + | sqlFun == absFunction = evalUnaryAlgebra abs abs + | sqlFun == negateFunction = evalUnaryAlgebra negate negate -- algebraic | sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs - | sqlFun == divideFunction = realExpression $ (realValue arg1) / (realValue arg2) + | 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 $ (boolValue arg1) && (boolValue arg2) - | sqlFun == orFunction = boolExpression $ (boolValue arg1) || (boolValue arg2) - | sqlFun == notFunction = boolExpression $ not (boolValue arg1) + | 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 realValue evaluatedArgs) / (fromIntegral $ length evaluatedArgs) - | sqlFun == countFunction = intExpression $ length evaluatedArgs + 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 @@ -589,67 +700,40 @@ arg1 = head evaluatedArgs arg2 = evaluatedArgs !! 1 arg3 = evaluatedArgs !! 2 - subStringF start extent string = take extent (drop start string) algebraWithCoercion intFunc realFunc args = if any useRealAlgebra args then - realExpression $ foldl1' realFunc (map realValue args) + RealExpression $ foldl1' realFunc (map coerceReal args) else - intExpression $ foldl1' intFunc (map intValue args) + IntExpression $ foldl1' intFunc (map coerceInt args) - useRealAlgebra expr = - let - prefType = preferredType expr - maybeInt = maybeIntValue expr - in - prefType == RealType || maybeInt == Nothing + useRealAlgebra (RealExpression _) = True + useRealAlgebra expr = case maybeCoerceInt expr of + Nothing -> True + Just _ -> False - argCountIsValid = + 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 || (not argsFixed && argCount > minArgs) - -{- --- aggregates -avgFunction = SQLFunction { - functionName = "AVG", - minArgCount = 1, - argCountIsFixed = True} - -countFunction = SQLFunction { - functionName = "COUNT", - minArgCount = 1, - argCountIsFixed = True} - -firstFunction = SQLFunction { - functionName = "FIRST", - minArgCount = 1, - argCountIsFixed = True} - -lastFunction = SQLFunction { - functionName = "LAST", - minArgCount = 1, - argCountIsFixed = True} - -maxFunction = SQLFunction { - functionName = "MAX", - minArgCount = 1, - argCountIsFixed = True} - -minFunction = SQLFunction { - functionName = "MIN", - minArgCount = 1, - argCountIsFixed = True} - -sumFunction = SQLFunction { - functionName = "SUM", - minArgCount = 1, - argCountIsFixed = True} --} + 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 + where f = reverse . dropWhile isSpace diff --git a/Database/TxtSushi/SQLParser.hs b/Database/TxtSushi/SQLParser.hs --- a/Database/TxtSushi/SQLParser.hs +++ b/Database/TxtSushi/SQLParser.hs @@ -40,6 +40,7 @@ -- String SQL function concatenateFunction, + absFunction, upperFunction, lowerFunction, trimFunction, @@ -73,7 +74,6 @@ import Data.List import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr -import Database.TxtSushi.Util.ListUtil -------------------------------------------------------------------------------- -- The data definition for select statements @@ -101,6 +101,9 @@ CrossJoin { leftJoinTable :: TableExpression, rightJoinTable :: TableExpression, + maybeTableAlias :: Maybe String} | + SelectExpression { + selectStatement :: SelectStatement, maybeTableAlias :: Maybe String} deriving (Show, Ord, Eq) @@ -110,16 +113,21 @@ allMaybeTableNames Nothing = [] allMaybeTableNames (Just tblExp) = allTableNames tblExp +allTableNames :: TableExpression -> [String] allTableNames (TableIdentifier tblName _) = [tblName] allTableNames (InnerJoin lftTbl rtTbl _ _) = (allTableNames lftTbl) ++ (allTableNames rtTbl) allTableNames (CrossJoin lftTbl rtTbl _) = (allTableNames lftTbl) ++ (allTableNames rtTbl) +allTableNames (SelectExpression selectStmt _) = + allMaybeTableNames $ maybeFromTable selectStmt data ColumnSelection = AllColumns | AllColumnsFrom {sourceTableName :: String} | - ExpressionColumn {expression :: Expression} + ExpressionColumn { + expression :: Expression, + maybeColumnAlias :: Maybe String} --QualifiedColumn { -- qualifiedColumnId :: ColumnIdentifier} deriving (Show, Ord, Eq) @@ -161,7 +169,7 @@ containsAggregates _ = False selectionContainsAggregates :: ColumnSelection -> Bool -selectionContainsAggregates (ExpressionColumn expr) = +selectionContainsAggregates (ExpressionColumn expr _) = containsAggregates expr selectionContainsAggregates _ = False @@ -204,6 +212,9 @@ sqlFunc == substringFromFunction || sqlFunc == notFunction = prettyFormatNormalFunctionExpression sqlFunc funcArgs + | otherwise = + error $ "don't know how to format the given SQL function : " ++ + show sqlFunc prettyFormatInfixFunctionExpression :: SQLFunction -> [Expression] -> String prettyFormatInfixFunctionExpression sqlFunc funcArgs = @@ -293,6 +304,7 @@ parseAscending = parseToken "ASCENDING" <|> parseToken "ASC" parseDescending = parseToken "DESCENDING" <|> parseToken "DESC" +maybeParseGroupByPart :: GenParser Char st (Maybe ([Expression], Maybe Expression)) maybeParseGroupByPart = ifParseThen -- if we see a "GROUP BY" @@ -307,28 +319,38 @@ maybeHavingExpr <- ifParseThen (parseToken "HAVING") parseExpression return (groupExprs, maybeHavingExpr) +atLeastOneExpr :: GenParser Char st [Expression] atLeastOneExpr = sepByAtLeast 1 parseExpression commaSeparator -------------------------------------------------------------------------------- -- Functions for parsing the column names specified after "SELECT" -------------------------------------------------------------------------------- +parseColumnSelections :: GenParser Char st [ColumnSelection] parseColumnSelections = sepBy1 parseAnyColType (try commaSeparator) where parseAnyColType = parseAllCols <|> (try parseAllColsFromTbl) <|> (try parseColExpression) +parseAllCols :: GenParser Char st ColumnSelection parseAllCols = parseToken "*" >> return AllColumns +parseAllColsFromTbl :: GenParser Char st ColumnSelection parseAllColsFromTbl = do tableVal <- parseIdentifier string "." >> spaces >> parseToken "*" return $ AllColumnsFrom tableVal -parseColExpression = parseExpression >>= \expr -> return $ ExpressionColumn expr +parseColExpression :: GenParser Char st ColumnSelection +parseColExpression = do + expr <- parseExpression + maybeAlias <- maybeParseAlias + + return $ ExpressionColumn expr maybeAlias +parseColumnId :: GenParser Char st ColumnIdentifier parseColumnId = do firstId <- parseIdentifier @@ -344,37 +366,54 @@ -- Functions for parsing the table part (after "FROM") -------------------------------------------------------------------------------- -parseTableExpression = do - nextTblChunk <- parseNextTblExpChunk +parseTableExpression :: GenParser Char a TableExpression +parseTableExpression = + parenthesize parseTableExpression <|> + parseSelectExpression <|> + parseTableIdentifierOrJoin "Table Expression" + +parseSelectExpression :: GenParser Char a TableExpression +parseSelectExpression = do + selectStmt <- parseSelectStatement + maybeAlias <- maybeParseAlias - let ifInnerJoinParse = ifParseThenElse - -- if - ((maybeParse $ parseToken "INNER") >> parseToken "JOIN") - -- then - (parseInnerJoinRemainder nextTblChunk) - -- else - (return nextTblChunk) - + return $ SelectExpression selectStmt maybeAlias + +parseTableIdentifierOrJoin :: GenParser Char a TableExpression +parseTableIdentifierOrJoin = do + nextTblId <- parseTableIdentifier + + let ifCrossOrInnerJoinParse = ifParseThenElse -- if - (parseToken "CROSS" >> parseToken "JOIN") + crossJoinSep -- TODO commit to join -- then - (parseCrossJoinRemainder nextTblChunk) + (parseCrossJoinRemainder nextTblId) -- else ifInnerJoinParse + ifInnerJoinParse = ifParseThenElse + -- if + innerJoinSep -- TODO commit to join + -- then + (parseInnerJoinRemainder nextTblId) + -- else + (return nextTblId) + ifCrossOrInnerJoinParse - -parseNextTblExpChunk = - parenthesize parseTableExpression <|> parseTableIdentifier + + where + crossJoinSep = (commaSeparator >> return "") <|> (parseToken "CROSS" >> parseToken "JOIN") + innerJoinSep = ((maybeParse $ parseToken "INNER") >> parseToken "JOIN") +parseInnerJoinRemainder :: TableExpression -> GenParser Char a TableExpression parseInnerJoinRemainder leftTblExpr = do rightTblExpr <- parseTableExpression parseToken "ON" onPart <- parseExpression - maybeAlias <- maybeParse parseTableAlias + maybeAlias <- maybeParseAlias return InnerJoin { leftJoinTable=leftTblExpr, @@ -382,21 +421,24 @@ onCondition=onPart, maybeTableAlias=maybeAlias} +parseCrossJoinRemainder :: TableExpression -> GenParser Char a TableExpression parseCrossJoinRemainder leftTblExpr = do rightTblExpr <- parseTableExpression - maybeAlias <- maybeParse parseTableAlias + maybeAlias <- maybeParseAlias return CrossJoin { leftJoinTable=leftTblExpr, rightJoinTable=rightTblExpr, maybeTableAlias=maybeAlias} +parseTableIdentifier :: GenParser Char st TableExpression parseTableIdentifier = do theId <- parseIdentifier - maybeAlias <- maybeParse parseTableAlias + maybeAlias <- maybeParseAlias return $ TableIdentifier theId maybeAlias -parseTableAlias = parseToken "AS" >> parseIdentifier +maybeParseAlias :: GenParser Char st (Maybe [Char]) +maybeParseAlias = ifParseThen (parseToken "AS") parseIdentifier -------------------------------------------------------------------------------- -- Expression parsing: These can be after "SELECT", "WHERE" or "HAVING" @@ -418,16 +460,15 @@ parseSubstringFunction <|> parseNotFunction <|> parseCountStar <|> - (parseColumnId >>= (\colId -> return $ ColumnExpression colId)) + (parseColumnId >>= return . ColumnExpression) parseStringConstant :: GenParser Char st Expression parseStringConstant = (quotedText True '"' <|> quotedText True '\'') >>= - (\txt -> return $ StringConstantExpression txt) + (return . StringConstantExpression) parseIntConstant :: GenParser Char st Expression -parseIntConstant = - parseInt >>= (\int -> return $ IntegerConstantExpression int) +parseIntConstant = parseInt >>= return . IntegerConstantExpression parseInt :: GenParser Char st Int parseInt = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do @@ -439,7 +480,7 @@ signedParseTxt = do char '-' unsignedDigitTxt <- unsignedParseTxt - return ('-':unsignedDigitTxt) + return $ '-' : unsignedDigitTxt -- | returns an int if it can be read from the string maybeReadInt :: String -> Maybe Int @@ -461,18 +502,27 @@ parseReal :: GenParser Char st Double parseReal = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do - realTxt <- anyParseTxt + realTxt <- anyParseTxt "real" return $ read realTxt where - anyParseTxt = signedParseTxt <|> unsignedParseTxt "real" - unsignedParseTxt = do + anyParseTxt = do + txtWithoutExp <- txtWithoutExponent + expPart <- try exponentPart <|> return "" + return $ txtWithoutExp ++ expPart + exponentPart = do + e <- (char 'e' <|> char 'E') + negPart <- (char '-' >> return "-") <|> return "" + numPart <- many1 digit + return $ (e:negPart) ++ numPart + txtWithoutExponent = signedTxt <|> unsignedTxt "real" + unsignedTxt = do intTxt <- many1 digit char '.' fracTxt <- many1 digit return $ intTxt ++ "." ++ fracTxt - signedParseTxt = do + signedTxt = do char '-' - unsignedDigitTxt <- unsignedParseTxt + unsignedDigitTxt <- unsignedTxt return ('-':unsignedDigitTxt) parseAnyNormalFunction :: GenParser Char st Expression @@ -480,74 +530,94 @@ let allParsers = map parseNormalFunction normalSyntaxFunctions in choice allParsers +parseNormalFunction :: SQLFunction -> GenParser Char st Expression parseNormalFunction sqlFunc = try (parseToken $ functionName sqlFunc) >> parseNormalFunctionArgs sqlFunc +parseNormalFunctionArgs :: SQLFunction -> GenParser Char st Expression parseNormalFunctionArgs sqlFunc = do args <- parenthesize $ argSepBy (minArgCount sqlFunc) parseExpression commaSeparator return $ FunctionExpression sqlFunc args where argSepBy = if argCountIsFixed sqlFunc then sepByExactly else sepByAtLeast -- Functions with "normal" syntax -- +normalSyntaxFunctions :: [SQLFunction] normalSyntaxFunctions = - [upperFunction, lowerFunction, trimFunction, + [absFunction, upperFunction, lowerFunction, trimFunction, -- all aggregates except count which accepts a (*) avgFunction, firstFunction, lastFunction, maxFunction, minFunction, sumFunction] -- non aggregates +absFunction :: SQLFunction +absFunction = SQLFunction { + functionName = "ABS", + minArgCount = 1, + argCountIsFixed = True} + +upperFunction :: SQLFunction upperFunction = SQLFunction { functionName = "UPPER", minArgCount = 1, argCountIsFixed = True} +lowerFunction :: SQLFunction lowerFunction = SQLFunction { functionName = "LOWER", minArgCount = 1, argCountIsFixed = True} +trimFunction :: SQLFunction trimFunction = SQLFunction { functionName = "TRIM", minArgCount = 1, argCountIsFixed = True} -- aggregates +avgFunction :: SQLFunction avgFunction = SQLFunction { functionName = "AVG", minArgCount = 1, argCountIsFixed = False} +countFunction :: SQLFunction countFunction = SQLFunction { functionName = "COUNT", minArgCount = 1, argCountIsFixed = False} +firstFunction :: SQLFunction firstFunction = SQLFunction { functionName = "FIRST", minArgCount = 1, argCountIsFixed = False} +lastFunction :: SQLFunction lastFunction = SQLFunction { functionName = "LAST", minArgCount = 1, argCountIsFixed = False} +maxFunction :: SQLFunction maxFunction = SQLFunction { functionName = "MAX", minArgCount = 1, argCountIsFixed = False} +minFunction :: SQLFunction minFunction = SQLFunction { functionName = "MIN", minArgCount = 1, argCountIsFixed = False} +sumFunction :: SQLFunction sumFunction = SQLFunction { functionName = "SUM", minArgCount = 1, argCountIsFixed = False} -- Infix functions -- +infixFunctions :: [[SQLFunction]] infixFunctions = [[multiplyFunction, divideFunction], [plusFunction, minusFunction], @@ -560,6 +630,7 @@ -- | This function parses the operator part of the infix function and returns -- a function that excepts a left expression and right expression to form -- an Expression from the FunctionExpression constructor +parseInfixOp :: SQLFunction -> Operator Char st Expression parseInfixOp infixFunc = -- use the magic infix type, always assuming left associativity Infix opParser AssocLeft @@ -570,78 +641,93 @@ functionArguments = [leftSubExpr, rightSubExpr]} -- Algebraic +multiplyFunction :: SQLFunction multiplyFunction = SQLFunction { functionName = "*", minArgCount = 2, argCountIsFixed = True} +divideFunction :: SQLFunction divideFunction = SQLFunction { functionName = "/", minArgCount = 2, argCountIsFixed = True} +plusFunction :: SQLFunction plusFunction = SQLFunction { functionName = "+", minArgCount = 2, argCountIsFixed = True} +minusFunction :: SQLFunction minusFunction = SQLFunction { functionName = "-", minArgCount = 2, argCountIsFixed = True} -- Boolean +isFunction :: SQLFunction isFunction = SQLFunction { functionName = "=", minArgCount = 2, argCountIsFixed = True} +isNotFunction :: SQLFunction isNotFunction = SQLFunction { functionName = "<>", minArgCount = 2, argCountIsFixed = True} +lessThanFunction :: SQLFunction lessThanFunction = SQLFunction { functionName = "<", minArgCount = 2, argCountIsFixed = True} +lessThanOrEqualToFunction :: SQLFunction lessThanOrEqualToFunction = SQLFunction { functionName = "<=", minArgCount = 2, argCountIsFixed = True} +greaterThanFunction :: SQLFunction greaterThanFunction = SQLFunction { functionName = ">", minArgCount = 2, argCountIsFixed = True} +greaterThanOrEqualToFunction :: SQLFunction greaterThanOrEqualToFunction = SQLFunction { functionName = ">=", minArgCount = 2, argCountIsFixed = True} +andFunction :: SQLFunction andFunction = SQLFunction { functionName = "AND", minArgCount = 2, argCountIsFixed = True} +orFunction :: SQLFunction orFunction = SQLFunction { functionName = "OR", minArgCount = 2, argCountIsFixed = True} +concatenateFunction :: SQLFunction concatenateFunction = SQLFunction { functionName = "||", minArgCount = 2, argCountIsFixed = True} +regexMatchFunction :: SQLFunction regexMatchFunction = SQLFunction { functionName = "=~", minArgCount = 2, argCountIsFixed = True} -- Functions with special syntax -- +specialFunctions :: [SQLFunction] specialFunctions = [substringFromFunction, substringFromToFunction, negateFunction, @@ -650,10 +736,13 @@ -- | 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} + +substringFromToFunction :: SQLFunction substringFromToFunction = SQLFunction { functionName = "SUBSTRING", minArgCount = 3, @@ -673,6 +762,7 @@ Nothing -> FunctionExpression substringFromFunction [strExpr, startExpr] Just len -> FunctionExpression substringFromToFunction [strExpr, startExpr, len] +negateFunction :: SQLFunction negateFunction = SQLFunction { functionName = "-", minArgCount = 1, @@ -684,16 +774,19 @@ expr <- parseAnyNonInfixExpression return $ FunctionExpression negateFunction [expr] +notFunction :: SQLFunction notFunction = SQLFunction { functionName = "NOT", minArgCount = 1, argCountIsFixed = True} +parseNotFunction :: GenParser Char st Expression parseNotFunction = do parseToken $ functionName notFunction expr <- parseAnyNonInfixExpression return $ FunctionExpression notFunction [expr] +parseCountStar :: GenParser Char st Expression parseCountStar = do try (parseToken $ functionName countFunction) try parseStar <|> parseNormalFunctionArgs countFunction @@ -707,19 +800,25 @@ -- Parse utility functions -------------------------------------------------------------------------------- +parseOpChar :: CharParser st Char parseOpChar = oneOf opChars +opChars :: [Char] opChars = "~!@#$%^&*-+=|\\<>/?" +withoutTrailing :: (Show s) => GenParser tok st s -> GenParser tok st a -> GenParser tok st a withoutTrailing end p = p >>= (\x -> genNotFollowedBy end >> return x) +withTrailing :: (Monad m) => m a -> m b -> m b withTrailing end p = p >>= (\x -> end >> return x) -- | like the lexeme function, this function eats all spaces after the given -- parser, but this one works for me and lexeme doesn't +eatSpacesAfter :: GenParser Char st a -> GenParser Char st a eatSpacesAfter p = p >>= (\x -> spaces >> return x) -- | find out if the given string ends with an op char +endsWithOp :: String -> Bool endsWithOp strToTest = last strToTest `elem` opChars -- | A token parser that allows either upper or lower case. all trailing @@ -729,10 +828,12 @@ eatSpacesAfter (try $ if endsWithOp tokStr then parseOpTok else parseAlphaNumTok) where parseOpTok = withoutTrailing parseOpChar (string tokStr) - parseAlphaNumTok = withoutTrailing alphaNum (upperOrLower tokStr) + parseAlphaNumTok = + withoutTrailing (alphaNum <|> char '_') (upperOrLower tokStr) -- | parses an identifier. you can use a tick '`' as a quote for -- an identifier with white-space +parseIdentifier :: GenParser Char st String parseIdentifier = do let parseId = do let idChar = alphaNum <|> char '_' @@ -742,6 +843,7 @@ -- | quoted text which allows escaping by doubling the quote char -- like "escaped quote char here:""" +quotedText :: Bool -> Char -> GenParser Char st String quotedText allowEmpty quoteChar = do let quote = char quoteChar manyFunc = if allowEmpty then many else many1 @@ -754,10 +856,10 @@ return textValue -exceptChar parser theException = notFollowedBy theException >> parser - +escapedQuote :: Char -> GenParser Char st Char escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar +commaSeparator :: GenParser Char st Char commaSeparator = eatSpacesAfter $ char ',' -- | Wraps parentheses parsers around the given inner parser @@ -768,15 +870,13 @@ eatSpacesAfter $ char ')' return innerParseResults +{- -- | Either parses the left or right parser returning the result of the -- successful parser eitherParse :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Either a b) eitherParse leftParser rightParser = - do {parseResult <- try leftParser; return $ Left parseResult} <|> - do {parseResult <- rightParser; return $ Right parseResult} - --- parses 1 or more spaces -spaces1 = skipMany1 space "whitespace" + (try leftParser >>= return . Left) <|> (rightParser >>= return . Right) +-} -- | if the ifParse parser succeeds return the result of thenParse, else -- return Nothing without parsing any input @@ -784,7 +884,7 @@ ifParseThen ifParse thenPart = do ifResult <- maybeParse ifParse case ifResult of - Just _ -> thenPart >>= (\x -> return $ Just x) + Just _ -> thenPart >>= return . Just Nothing -> return Nothing -- | if ifParse succeeds then parse thenPart otherwise parse elsePart @@ -795,11 +895,13 @@ Just _ -> thenPart Nothing -> elsePart -parseReservedWord = do +parseReservedWord :: GenParser Char st String +parseReservedWord = let reservedWordParsers = map parseToken reservedWords - choice reservedWordParsers + in choice reservedWordParsers -- TODO are function names reserved... i don't think so +reservedWords :: [String] reservedWords = map functionName normalSyntaxFunctions ++ map functionName (concat infixFunctions) ++ @@ -831,13 +933,12 @@ -- | returns Just parseResult if the parse succeeds and Nothing if it fails maybeParse :: GenParser tok st a -> GenParser tok st (Maybe a) maybeParse parser = - (try parser >>= (\x -> return $ Just x)) <|> - return Nothing + (try parser >>= return . Just) <|> return Nothing -- | parse `itemParser`s seperated by exactly `minCount` `sepParser`s sepByExactly :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepByExactly count itemParser sepParser = - let itemParsers = replicate count itemParser +sepByExactly itemCount itemParser sepParser = + let itemParsers = replicate itemCount itemParser in parseEach itemParsers where -- for an empty parser list return an empty result @@ -858,7 +959,7 @@ sepByAtLeast :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] sepByAtLeast minCount itemParser sepParser = do minResults <- sepByExactly minCount itemParser sepParser - ifParseThenElse - sepParser - (sepBy1 itemParser sepParser >>= (\tailResults -> return $ minResults ++ tailResults)) - (return minResults) + tailResults <- + ifParseThenElse sepParser (sepBy itemParser sepParser) (return []) + + return $ minResults ++ tailResults diff --git a/Database/TxtSushi/Transform.hs b/Database/TxtSushi/Transform.hs --- a/Database/TxtSushi/Transform.hs +++ b/Database/TxtSushi/Transform.hs @@ -2,103 +2,28 @@ Simple table transformations -} module Database.TxtSushi.Transform ( - selectColumns, sortColumns, - fileBasedSortTable, - mergeAllBy, joinTables, + crossJoinTables, joinPresortedTables, rowComparison) where import Data.List -import System.Directory -import System.IO -import Database.TxtSushi.IO - -{- | -Create a new table by selecting the given 'columnIndices' --} -selectColumns _ [] = [] -selectColumns columnIndices (headRow:tableTail) = - ([headRow !! i | i <- columnIndices]):(selectColumns columnIndices tableTail) - -removeColumns _ [] = [] -removeColumns columnIndices (headRow:tableTail) = - let indexesToSelect = [0 .. ((length headRow) - 1)] \\ columnIndices - in ([headRow !! i | i <- indexesToSelect]):(removeColumns columnIndices tableTail) - -- | sort the given 'table' on the given columns +sortColumns :: (Ord a) => [Int] -> [[a]] -> [[a]] sortColumns columns table = sortBy (rowComparison columns) table -- | compare two rows based on given column balues +rowComparison :: (Ord a) => [Int] -> [a] -> [a] -> Ordering rowComparison [] _ _ = EQ rowComparison (columnHead:columnsTail) row1 row2 = let colComparison = (row1 !! columnHead) `compare` (row2 !! columnHead) in case colComparison of - EQ -> rowComparison columnsTail row1 row2 - otherwise -> colComparison - --- | merge two sorted lists into a single sorted list -mergeBy comparisonFunction [] list2 = list2 -mergeBy comparisonFunction list1 [] = list1 -mergeBy comparisonFunction list1@(head1:tail1) list2@(head2:tail2) = - case head1 `comparisonFunction` head2 of - GT -> (head2:(mergeBy comparisonFunction list1 tail2)) - otherwise -> (head1:(mergeBy comparisonFunction tail1 list2)) - --- | merge the sorted lists in the list to a list about 1/2 the size -mergePairsBy _ [] = [] -mergePairsBy comparisonFunction singletonListList@(headList:[]) = singletonListList -mergePairsBy comparisonFunction (list1:list2:listListTail) = - let mergedPair = mergeBy comparisonFunction list1 list2 - in mergedPair:(mergePairsBy comparisonFunction listListTail) - --- | merge a list of sorted lists into a single sorted list -mergeAllBy _ [] = [] -mergeAllBy comparisonFunction listList = - let mergedPairs = mergePairsBy comparisonFunction listList - in - case mergedPairs of - singletonListHead:[] -> singletonListHead - otherwise -> mergeAllBy comparisonFunction mergedPairs - -{- | -perform a table sort using files to keep from holding the whole list in memory --} -fileBasedSortTable columns table = do - partialSortFiles <- bufferPartialSorts columns table - partialSortFileHandles <- (unwrapIOList [openFile file ReadMode | file <- partialSortFiles]) - partialSortContents <- (unwrapIOList [hGetContents handle | handle <- partialSortFileHandles]) - let partialSortTables = map (parseTable csvFormat) partialSortContents - return (partialSortTables, partialSortFileHandles, partialSortFiles) - --- | unwrap a list of 'IO' boxed items -unwrapIOList [] = do return [] -unwrapIOList (ioHead:ioTail) = do - unwrappedHead <- ioHead - unwrappedTail <- unwrapIOList ioTail - return (unwrappedHead:unwrappedTail) - --- | create a list of parial sorts -bufferPartialSorts columns [] = return [] -bufferPartialSorts columns table = do - let rowLimit = 100000 - (rowsToSortNow, rowsToSortLater) = splitAt rowLimit table - sortedRows = sortColumns columns rowsToSortNow - sortBuffer <- bufferToTempFile sortedRows - otherSortBuffers <- bufferPartialSorts columns rowsToSortLater - return (sortBuffer:otherSortBuffers) - --- | buffer the table to a temporary file and return a handle to that file -bufferToTempFile table = do - tempDir <- getTemporaryDirectory - (tempFilePath, tempFileHandle) <- openTempFile tempDir "buffer.txt" - hPutStr tempFileHandle (formatTable csvFormat table) - hClose tempFileHandle - return tempFilePath + EQ -> rowComparison columnsTail row1 row2 + _ -> colComparison -- | join together two tables on the given column index pairs joinTables :: (Ord o) => [(Int, Int)] -> [[o]] -> [[o]] -> [[o]] @@ -122,15 +47,17 @@ in joinGroupedTables joinColumnZipList tableGroups1 tableGroups2 -permutePrependRows [] _ = [] -permutePrependRows _ [] = [] -permutePrependRows (table1HeadRow:table1Tail) table2 = +crossJoinTables :: [[a]] -> [[a]] -> [[a]] +crossJoinTables [] _ = [] +crossJoinTables _ [] = [] +crossJoinTables (table1HeadRow:table1Tail) table2 = let prependHead = (table1HeadRow ++) newTable2 = map prependHead table2 in - newTable2 ++ (permutePrependRows table1Tail table2) + newTable2 ++ (crossJoinTables table1Tail table2) +joinGroupedTables :: (Ord a) => [(Int, Int)] -> [[[a]]] -> [[[a]]] -> [[a]] joinGroupedTables _ [] _ = [] joinGroupedTables _ _ [] = [] joinGroupedTables joinColumnZipList tableGroups1@(headTableGroup1:tableGroupsTail1) tableGroups2@(headTableGroup2:tableGroupsTail2) = @@ -146,10 +73,11 @@ GT -> joinGroupedTables joinColumnZipList tableGroups1 tableGroupsTail2 -- the two groups are equal so permute - otherwise -> - (permutePrependRows headTableGroup1 headTableGroup2) ++ + _ -> + (crossJoinTables headTableGroup1 headTableGroup2) ++ (joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroupsTail2) +asymmetricRowComparison :: (Ord a) => [(Int, Int)] -> [a] -> [a] -> Ordering asymmetricRowComparison [] _ _ = EQ asymmetricRowComparison (columnsZipHead:columnsZipTail) row1 row2 = let @@ -157,6 +85,5 @@ colComparison = (row1 !! columnHead1) `compare` (row2 !! columnHead2) in case colComparison of - EQ -> asymmetricRowComparison columnsZipTail row1 row2 - otherwise -> colComparison - + EQ -> asymmetricRowComparison columnsZipTail row1 row2 + _ -> colComparison diff --git a/Database/TxtSushi/Util/CommandLineArgument.hs b/Database/TxtSushi/Util/CommandLineArgument.hs --- a/Database/TxtSushi/Util/CommandLineArgument.hs +++ b/Database/TxtSushi/Util/CommandLineArgument.hs @@ -16,7 +16,6 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map ---import Test.HUnit data CommandLineDescription = CommandLineDescription { options :: [OptionDescription], @@ -53,9 +52,15 @@ -} argumentCountIsFixed :: Bool} deriving (Show, Eq, Ord) -space = " "; -etc = "..."; +space :: String +space = " " +etc :: String +etc = "..." + +-- | converts a command line description into a string version that +-- you can show the user +formatCommandLine :: CommandLineDescription -> String formatCommandLine commandLine = let formattedOptions = formatOptions (options commandLine) formattedTailArgs = formatTailArguments commandLine @@ -65,6 +70,7 @@ else formattedOptions ++ space ++ formattedTailArgs +formatTailArguments :: CommandLineDescription -> String formatTailArguments commandLine = let tailArgs = tailArgumentNames commandLine minTailArgs = minTailArgumentCount commandLine @@ -89,6 +95,7 @@ else "[" ++ requiredOptionString ++ "]" ++ formattedOptionsTail +argumentSubstring :: OptionDescription -> String argumentSubstring option = let minArgs = minArgumentCount option in @@ -125,12 +132,12 @@ (Map.Map OptionDescription [[String]], [String]) extractOptions [] argValues = (Map.empty, argValues) extractOptions _ [] = (Map.empty, []) -extractOptions optDescs argValues@(argHead:argTail) = +extractOptions optDescs argValues@(argHead:_) = case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of Nothing -> (Map.empty, argValues) Just optDesc -> - let (optArgs, afterOptArgs) = extractOption optDesc optDescs argValues + let (optArgs, afterOptArgs) = extractOption optDesc optDescs (tail argValues) (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs) @@ -139,9 +146,9 @@ [OptionDescription] -> [String] -> ([String], [String]) -extractOption optDesc allOptDescs (argHead:argTail) = - let optArgExtent = argumentExtent optDesc allOptDescs argTail - in splitAt optArgExtent argTail +extractOption optDesc allOptDescs optArgsEtc = + let optArgExtent = argumentExtent optDesc allOptDescs optArgsEtc + in splitAt optArgExtent optArgsEtc argumentExtent :: OptionDescription -> [OptionDescription] -> [String] -> Int argumentExtent optionDescription allOptDescs afterOptArgs = @@ -174,40 +181,3 @@ case (Map.lookup opt optArgMap) of Nothing -> Map.insert opt [args] optArgMap Just currArgs -> Map.insert opt (currArgs ++ [args]) optArgMap - --- Test code -{- -byNameOption = OptionDescription - False -- isRequired - "-by-name" -- optionFlag - [] -- argumentNames - 0 -- minArgumentCount - True -- argumentCountIsFixed - -helpOption = OptionDescription - False -- isRequired - "-help" -- optionFlag - [] -- argumentNames - 0 -- minArgumentCount - True -- argumentCountIsFixed - -fancyPantsOption = OptionDescription - False -- isRequired - "-fancy" -- optionFlag - ["f1", "f2"] -- argumentNames - 2 -- minArgumentCount - False -- argumentCountIsFixed - -cmdLineOps1 = [byNameOption, helpOption, fancyPantsOption] - -cmdLineDesc1 = CommandLineDescription - cmdLineOps1 -- options - 1 -- minTailArgumentCount - "file/-" -- tailArgumentNames - True -- tailArgumentCountIsFixed -cmdLine1 = ["-by-name", "-fancy", "f1arg", "f2arg", "-help", "-"] -parsedCmd1 = extractOptions (options cmdLineDesc1) cmdLine1 - -test1 = TestCase $ assertEqual - "options test" cmdLineOps1 (options cmdLineDesc1) --} diff --git a/Database/TxtSushi/Util/IOUtil.hs b/Database/TxtSushi/Util/IOUtil.hs --- a/Database/TxtSushi/Util/IOUtil.hs +++ b/Database/TxtSushi/Util/IOUtil.hs @@ -1,11 +1,18 @@ module Database.TxtSushi.Util.IOUtil ( bufferStdioToTempFile, getContentsFromFileOrStdin, - getAll) where + printSingleFileUsage) where +import Data.List +import Data.Version (Version(..)) import System.Directory +import System.Environment import System.IO +import Paths_txt_sushi + +-- | buffers standard input to a temp file and returns a path to that file +bufferStdioToTempFile :: IO FilePath bufferStdioToTempFile = do stdioText <- getContents tempDir <- getTemporaryDirectory @@ -14,22 +21,21 @@ hClose tempFileHandle return tempFilePath -getContentsFromFileOrStdin filePath = do +-- | if given "-" this file reads from stdin otherwise it reads from the named +-- file +getContentsFromFileOrStdin :: String -> IO String +getContentsFromFileOrStdin filePath = if filePath == "-" - then do - getContents - else do - handle <- openFile filePath ReadMode - hGetContents handle - -getAll [] = [] -getAll (x:xt) = do - y <- x - yt <- getAll xt - return (y:yt) + then getContents + else readFile filePath --- | returns an infinite list of gets from a monad -keepGetting getAction = do - headVal <- getAction - tailVal <- keepGetting getAction - return (headVal:tailVal) +-- | print a cookie-cutter usage message for the command line utilities +-- that take a single file name or "-" as input +printSingleFileUsage :: IO () +printSingleFileUsage = do + progName <- getProgName + putStrLn $ progName ++ " (" ++ versionStr ++ ")" + putStrLn $ "Usage: " ++ progName ++ " file_name_or_dash" + + where + versionStr = intercalate "." (map show . versionBranch $ version) diff --git a/csvtopretty.hs b/csvtopretty.hs --- a/csvtopretty.hs +++ b/csvtopretty.hs @@ -1,24 +1,17 @@ -import Data.List import System.Directory import System.Environment -import System.Exit import System.IO import Database.TxtSushi.IO import Database.TxtSushi.Util.IOUtil +main :: IO () main = do args <- getArgs - if (length args) /= 1 - then do - hPutStrLn stderr $ - "ERROR: program requires a single command line argument " ++ - "(filename or '-')" - exitFailure - else do - let fileArg = head args - useStdio = (fileArg == "-") + case args of + [fileArg] -> do + let useStdio = (fileArg == "-") file <- if useStdio then bufferStdioToTempFile else return fileArg @@ -36,3 +29,6 @@ hClose handle1 hClose handle2 if useStdio then removeFile file else return () + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/csvtotab.hs b/csvtotab.hs --- a/csvtotab.hs +++ b/csvtotab.hs @@ -1,23 +1,20 @@ -import Data.List import System.Environment -import System.Exit import System.IO import Database.TxtSushi.IO import Database.TxtSushi.Util.IOUtil +main :: IO () main = do args <- getArgs - if (length args) /= 1 - then do - hPutStrLn stderr $ - "ERROR: program requires a single command line argument " ++ - "(filename or '-')" - exitFailure - else do - contents <- getContentsFromFileOrStdin (last args) + case args of + [fileArg] -> do + contents <- getContentsFromFileOrStdin fileArg let table = parseTable csvFormat contents tabDelimitedText = formatTable tabDelimitedFormat table putStr tabDelimitedText + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/namecolumns.hs b/namecolumns.hs --- a/namecolumns.hs +++ b/namecolumns.hs @@ -1,25 +1,30 @@ -import Data.List import System.Environment -import System.Exit import System.IO import Database.TxtSushi.IO import Database.TxtSushi.Util.IOUtil +main :: IO () main = do args <- getArgs - if (length args) /= 1 - then do - hPutStrLn stderr $ - "ERROR: program requires a single command line argument " ++ - "(filename or '-')" - exitFailure - else do - contents <- getContentsFromFileOrStdin (last args) - - let table@(headRow:tableTail) = parseTable csvFormat contents - colNames = map ("col" ++) (map show [1 .. length headRow]) - namedTable = colNames:table + case args of + [fileArg] -> do + contents <- getContentsFromFileOrStdin fileArg - putStr $ if null table then "" else formatTable csvFormat namedTable + let table = parseTable csvFormat contents + case table of + + -- we only need the 1st row's column count to name the columns + (headRow : _) -> + let colNames = map ("col" ++) (map show [1 .. length headRow]) + namedTable = formatTable csvFormat [colNames] ++ contents + in + putStr namedTable + + -- the given table was empty (is it better for this to be an + -- error ?) + _ -> return () + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/tabtocsv.hs b/tabtocsv.hs --- a/tabtocsv.hs +++ b/tabtocsv.hs @@ -1,23 +1,20 @@ -import Data.List import System.Environment -import System.Exit import System.IO import Database.TxtSushi.IO import Database.TxtSushi.Util.IOUtil +main :: IO () main = do args <- getArgs - if (length args) /= 1 - then do - hPutStrLn stderr $ - "ERROR: program requires a single command line argument " ++ - "(filename or '-')" - exitFailure - else do - contents <- getContentsFromFileOrStdin (last args) + case args of + [fileArg] -> do + contents <- getContentsFromFileOrStdin fileArg let table = parseTable tabDelimitedFormat contents csvText = formatTable csvFormat table putStr csvText + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/tabtopretty.hs b/tabtopretty.hs --- a/tabtopretty.hs +++ b/tabtopretty.hs @@ -1,24 +1,17 @@ -import Data.List import System.Directory import System.Environment -import System.Exit import System.IO import Database.TxtSushi.IO import Database.TxtSushi.Util.IOUtil +main :: IO () main = do args <- getArgs - if (length args) /= 1 - then do - hPutStrLn stderr $ - "ERROR: program requires a single command line argument " ++ - "(filename or '-')" - exitFailure - else do - let fileArg = head args - useStdio = (fileArg == "-") + case args of + [fileArg] -> do + let useStdio = (fileArg == "-") file <- if useStdio then bufferStdioToTempFile else return fileArg @@ -36,3 +29,6 @@ hClose handle1 hClose handle2 if useStdio then removeFile file else return () + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/transposecsv.hs b/transposecsv.hs new file mode 100644 --- /dev/null +++ b/transposecsv.hs @@ -0,0 +1,21 @@ +import Data.List +import System.Environment +import System.IO + +import Database.TxtSushi.IO +import Database.TxtSushi.Util.IOUtil + +main :: IO () +main = do + args <- getArgs + + case args of + [fileArg] -> do + contents <- getContentsFromFileOrStdin fileArg + + let table = transpose . parseTable csvFormat $ contents + csvText = formatTable csvFormat table + putStr csvText + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/transposetab.hs b/transposetab.hs new file mode 100644 --- /dev/null +++ b/transposetab.hs @@ -0,0 +1,21 @@ +import Data.List +import System.Environment +import System.IO + +import Database.TxtSushi.IO +import Database.TxtSushi.Util.IOUtil + +main :: IO () +main = do + args <- getArgs + + case args of + [fileArg] -> do + contents <- getContentsFromFileOrStdin fileArg + + let table = transpose . parseTable tabDelimitedFormat $ contents + tabText = formatTable tabDelimitedFormat table + putStr tabText + + -- we were expecting a single file name arg + _ -> printSingleFileUsage diff --git a/tssql.hs b/tssql.hs --- a/tssql.hs +++ b/tssql.hs @@ -10,6 +10,7 @@ -- ----------------------------------------------------------------------------- import Data.List +import Data.Version (Version(..)) import qualified Data.Map as Map import System.Environment import System.Exit @@ -20,10 +21,12 @@ import Database.TxtSushi.IO import Database.TxtSushi.SQLExecution import Database.TxtSushi.SQLParser -import Database.TxtSushi.Transform import Database.TxtSushi.Util.CommandLineArgument import Database.TxtSushi.Util.IOUtil +import Paths_txt_sushi + +helpOption :: OptionDescription helpOption = OptionDescription { isRequired = False, optionFlag = "-help", @@ -31,19 +34,30 @@ minArgumentCount = 0, argumentCountIsFixed = True} +externalSortOption :: OptionDescription +externalSortOption = OptionDescription { + isRequired = False, + optionFlag = "-external-sort", + argumentNames = [], + minArgumentCount = 0, + argumentCountIsFixed = True} + +tableDefOption :: OptionDescription tableDefOption = OptionDescription { isRequired = False, optionFlag = "-table", - argumentNames = ["CSV-file-name", "table-name"], + argumentNames = ["table_name", "CSV_file_name"], minArgumentCount = 2, argumentCountIsFixed = True} -turtleSqlOpts = [helpOption, tableDefOption] +allOpts :: [OptionDescription] +allOpts = [helpOption, externalSortOption, tableDefOption] +sqlCmdLine :: CommandLineDescription sqlCmdLine = CommandLineDescription { - options = turtleSqlOpts, + options = allOpts, minTailArgumentCount = 1, - tailArgumentNames = ["SQL-select-statement"], + tailArgumentNames = ["SQL_select_statement"], tailArgumentCountIsFixed = True} validateTableNames :: [String] -> [String] -> Bool @@ -55,24 +69,35 @@ error $ "The given table name \"" ++ argTblHead ++ "\" does not appear in the SELECT statement" +tableArgsToMap :: [[String]] -> Map.Map String String tableArgsToMap [] = Map.empty tableArgsToMap (currTableArgs:tailTableArgs) = case currTableArgs of - [fileName, tableName] -> - Map.insert fileName tableName (tableArgsToMap tailTableArgs) - otherwise -> + [fileName, tblName] -> + Map.insert fileName tblName (tableArgsToMap tailTableArgs) + _ -> error $ "the \"" ++ (optionFlag tableDefOption) ++ "\" option should have exactly two arguments" +unwrapMapList :: (Monad m) => [(t, m t1)] -> m [(t, t1)] unwrapMapList [] = return [] unwrapMapList ((key, value):mapTail) = do unwrappedValue <- value unwrappedTail <- unwrapMapList mapTail return $ (key, unwrappedValue):unwrappedTail -printUsage progName = +printUsage :: String -> IO () +printUsage progName = do + putStrLn $ progName ++ " (" ++ versionStr ++ ")" putStrLn $ "Usage: " ++ progName ++ " " ++ formatCommandLine sqlCmdLine + where + versionStr = intercalate "." (map show $ versionBranch version) +argsToSortConfig :: Map.Map OptionDescription a -> SortConfiguration +argsToSortConfig argMap = + if Map.member externalSortOption argMap then UseExternalSort else UseInMemorySort + +main :: IO () main = do args <- getArgs progName <- getProgName @@ -108,7 +133,8 @@ let unwrappedContentsMap = Map.fromList unwrappedContents textTableMap = Map.map (parseTable csvFormat) unwrappedContentsMap dbTableMap = Map.mapWithKey textTableToDatabaseTable textTableMap - selectedDbTable = select selectStmt dbTableMap + sortCfg = argsToSortConfig argMap + selectedDbTable = select sortCfg selectStmt dbTableMap selectedTxtTable = databaseTableToTextTable selectedDbTable putStr $ formatTable csvFormat selectedTxtTable diff --git a/txt-sushi.cabal b/txt-sushi.cabal --- a/txt-sushi.cabal +++ b/txt-sushi.cabal @@ -1,5 +1,5 @@ Name: txt-sushi -Version: 0.3.0 +Version: 0.4.0 Synopsis: Spreadsheets are databases! Description: TxtSushi is a collection of command line utilities for processing @@ -7,54 +7,65 @@ The most important utility (tssql) lets you perform SQL selects on CSV files. By focusing exclusively on processing text files with a tabular structure, TxtSushi simplifies common tasks like filtering, joining and transformation - that would take some effort to accomplish with a more powerful scripting - language. + that would take more effort to accomplish with a general purpose text + processing language. License: GPL License-File: COPYING Author: Keith Sheppard Maintainer: keithshep@gmail.com Homepage: http://keithsheppard.name/txt-sushi +Bug-Reports: http://code.google.com/p/txt-sushi/issues/list Build-Type: Simple Category: Database, Utils, Text -Cabal-Version: >=1.2 +Cabal-Version: >= 1.6 +Source-Repository head + type: darcs + location: http://patch-tag.com/r/keithshep/txt-sushi/pullrepo + +Source-Repository this + type: darcs + location: http://patch-tag.com/r/keithshep/txt-sushi/pullrepo + tag: 0.4.0 + Executable tssql Main-Is: tssql.hs - Build-Depends: base,haskell98,directory,containers,parsec,regex-posix - - -- creates highly optimized code (slow compile) - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall -- combine the following with the +RTS -xc -RTS runtime option for stack taces --GHC-Options: -prof -auto-all Executable csvtotab Main-Is: csvtotab.hs - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall Executable tabtocsv Main-Is: tabtocsv.hs - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall Executable csvtopretty Main-Is: csvtopretty.hs - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall Executable tabtopretty Main-Is: tabtopretty.hs - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall Executable namecolumns Main-Is: namecolumns.hs - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + GHC-Options: -O2 -Wall +Executable transposecsv + Main-Is: transposecsv.hs + GHC-Options: -O2 -Wall + +Executable transposetab + Main-Is: transposetab.hs + GHC-Options: -O2 -Wall + Library Exposed-Modules: + Database.TxtSushi.ExternalSort Database.TxtSushi.IO Database.TxtSushi.SQLExecution Database.TxtSushi.SQLParser @@ -63,5 +74,5 @@ Database.TxtSushi.Util.IOUtil Database.TxtSushi.Util.ListUtil - Build-Depends: base,haskell98,directory,containers - GHC-Options: -O2 -fvia-C + Build-Depends: base >= 3 && < 5,binary,bytestring,containers,directory,parsec,regex-posix + GHC-Options: -O2 -Wall