txt-sushi 0.3.0 → 0.4.0

raw patch · 16 files changed

+880/−551 lines, 16 filesdep +binarydep +bytestringdep −haskell98dep ~basenew-component:exe:transposecsvnew-component:exe:transposetabPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, bytestring

Dependencies removed: haskell98

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Database/TxtSushi/ExternalSort.hs +165/−0
• Database/TxtSushi/IO.hs +9/−3
• Database/TxtSushi/SQLExecution.hs +340/−256
• Database/TxtSushi/SQLParser.hs +154/−53
• Database/TxtSushi/Transform.hs +16/−89
• Database/TxtSushi/Util/CommandLineArgument.hs +15/−45
• Database/TxtSushi/Util/IOUtil.hs +24/−18
• csvtopretty.hs +7/−11
• csvtotab.hs +7/−10
• namecolumns.hs +20/−15
• tabtocsv.hs +7/−10
• tabtopretty.hs +7/−11
• transposecsv.hs +21/−0
• transposetab.hs +21/−0
• tssql.hs +36/−10
• txt-sushi.cabal +31/−20

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)--}

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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