packages feed

txt-sushi 0.2 → 0.3.0

raw patch · 126 files changed

+2229/−2749 lines, 126 filessetup-changednew-component:exe:namecolumns

Files

− .boring 
@@ -1,116 +0,0 @@-# Boring file regexps:--# Stuff that's boring for txt-sushi-^dist$--### compiler and interpreter intermediate files-# haskell (ghc) interfaces-\.hi$-\.hi-boot$-\.o-boot$-# object files-\.o$-\.o\.cmd$-# profiling haskell-\.p_hi$-\.p_o$-# haskell program coverage resp. profiling info-\.tix$-\.prof$-# fortran module files-\.mod$-# linux kernel-\.ko\.cmd$-\.mod\.c$-(^|/)\.tmp_versions($|/)-# *.ko files aren't boring by default because they might-# be Korean translations rather than kernel modules-# \.ko$-# python, emacs, java byte code-\.py[co]$-\.elc$-\.class$-# objects and libraries; lo and la are libtool things-\.(obj|a|exe|so|lo|la)$-# compiled zsh configuration files-\.zwc$-# Common LISP output files for CLISP and CMUCL-\.(fas|fasl|sparcf|x86f)$--### build and packaging systems-# cabal intermediates-\.installed-pkg-config-\.setup-config-# standard cabal build dir, might not be boring for everybody-# ^dist(/|$)-# autotools-(^|/)autom4te\.cache($|/)-(^|/)config\.(log|status)$-# microsoft web expression, visual studio metadata directories-\_vti_cnf$-\_vti_pvt$-# gentoo tools-\.revdep-rebuild.*-# generated dependencies-^\.depend$--### version control systems-# cvs-(^|/)CVS($|/)-\.cvsignore$-# cvs, emacs locks-^\.#-# rcs-(^|/)RCS($|/)-,v$-# subversion-(^|/)\.svn($|/)-# mercurial-(^|/)\.hg($|/)-# git-(^|/)\.git($|/)-# bzr-\.bzr$-# sccs-(^|/)SCCS($|/)-# darcs-(^|/)_darcs($|/)-(^|/)\.darcsrepo($|/)-^\.darcs-temp-mail$--darcs-backup[[:digit:]]+$-# gnu arch-(^|/)(\+|,)-(^|/)vssver\.scc$-\.swp$-(^|/)MT($|/)-(^|/)\{arch\}($|/)-(^|/).arch-ids($|/)-# bitkeeper-(^|/)BitKeeper($|/)-(^|/)ChangeSet($|/)--### miscellaneous-# backup files-~$-\.bak$-\.BAK$-# patch originals and rejects-\.orig$-\.rej$-# X server-\..serverauth.*-# image spam-\#-(^|/)Thumbs\.db$-# vi, emacs tags-(^|/)(tags|TAGS)$-#(^|/)\.[^/]-# core dumps-(^|/|\.)core$-# partial broken files (KIO copy operations)-\.part$-# waf files, see http://code.google.com/p/waf/-(^|/)\.waf-[[:digit:].]+-[[:digit:]]+($|/)-(^|/)\.lock-wscript$-# mac os finder-(^|/)\.DS_Store$
+ Database/TxtSushi/IO.hs view
@@ -0,0 +1,200 @@+{- |+The 'FlatFile' module is for reading misc. 'FlatFile' formats like CSV or+tab delimited+-}+module Database.TxtSushi.IO (+    formatTableWithWidths,+    maxTableColumnWidths,+    formatTable,+    parseTable,+    Format(Format),+    csvFormat,+    tabDelimitedFormat,+    doubleQuote) where++import Data.List+import Database.TxtSushi.Util.ListUtil++{- |+'Format' allows you to specify different flat-file formats so that you+can use 'parseTable' for CSV, tab-delimited etc.+-}+data Format = Format {+    quote :: String,+    fieldDelimiter :: String,+    rowDelimiter :: String} deriving (Show)++csvFormat = Format "\"" "," "\n"+tabDelimitedFormat = Format "\"" "\t" "\n"++{- |+get a quote escape sequence for the given 'Format'+-}+doubleQuote :: Format -> String+doubleQuote format = (quote format) ++ (quote format)++formatTableWithWidths _ _ [] = []+formatTableWithWidths boundaryString widths (row:tableTail) =+    let+        (initCells, [lastCell]) = splitAt (length row - 1) row+    in+        (concat $ zipWith ensureWidth widths initCells) ++ lastCell +++        "\n" ++ (formatTableWithWidths boundaryString widths tableTail)+    where+        ensureWidth width field =+            let lengthField = length field+            in+                if width > lengthField then+                    field ++ (replicate (width - lengthField) ' ') ++ boundaryString+                else+                    field ++ boundaryString++{- |+for a table, calculate the max width in characters for each column+-}+maxTableColumnWidths :: [[String]] -> [Int]+maxTableColumnWidths [] = []+maxTableColumnWidths table =+    maxTableColumnWidthsInternal table []++maxTableColumnWidthsInternal :: [[String]] -> [Int] -> [Int]+maxTableColumnWidthsInternal [] prevMaxValues = prevMaxValues+maxTableColumnWidthsInternal (row:tableTail) prevMaxValues+    | seqList prevMaxValues = undefined+    | otherwise = maxTableColumnWidthsInternal tableTail (maxRowFieldWidths row prevMaxValues)++-- this filthy little function is for making the list strict... otherwise+-- we run out of memory+seqList [] = False+seqList (head:tail)+    | head `seq` False = undefined+    | otherwise = seqList tail++maxRowFieldWidths :: [String] -> [Int] -> [Int]+maxRowFieldWidths row prevMaxValues =+    zipWithD max (map length row) prevMaxValues++zipWithD :: (a -> a -> a) -> [a] -> [a] -> [a]+zipWithD f (x:xt) (y:yt) = (f x y):(zipWithD f xt yt)+zipWithD _ [] ys = ys+zipWithD _ xs [] = xs++{- |+Format the given table (the 2D String array) into a flat-file string using+the given 'Format'+-}+formatTable :: Format -> [[String]] -> String+formatTable _ [] = ""+formatTable format (headRow:tableTail) =+    (formatRow format headRow) ++ (rowDelimiter format) ++ (formatTable format tableTail)++{- |+Format the row into a flat file sub-string using the given 'Format'+-}+formatRow :: Format -> [String] -> String+formatRow _ [] = []+formatRow format (headField:rowTail) =+    -- we need to escape any quotes+    let escapedField = encodeField format headField+    in+        -- use a field delimiter on all but the last field+        if null rowTail then+            escapedField+        else+            escapedField ++ (fieldDelimiter format) ++ (formatRow format rowTail)++{- |+encode the given text field if it contains any special formatting characters+-}+encodeField format field =+    if (quote format) `isInfixOf` field then+        let escapedField = replaceAll field (quote format) (doubleQuote format)+        in  (quote format) ++ escapedField ++ (quote format)+    else if (rowDelimiter format) `isInfixOf` field ||+            (fieldDelimiter format) `isInfixOf` field then+        (quote format) ++ field ++ (quote format)+    else+        field++{- |+Parse the given text using the given flat file 'Format'. The result+is a list of list of strings. The strings are fields and the string+lists are rows+-}+parseTable :: Format -> String -> [[String]]+parseTable _ [] = []+parseTable format text =+    let (nextLine, remainingText) = parseLine format text+    in  nextLine:(parseTable  format remainingText)++-- parse a row giving (rowFields, remainingText)+parseLine :: Format -> String -> ([String], String)+parseLine _ [] = ([], "")+parseLine format text =+    let (nextField, moreFieldsInRow, textRemainingAfterField) = parseField format text+    in+        -- if there are more fields, recursively add them to the row+        if moreFieldsInRow then+            let (rowTail, remainingText) = parseLine format textRemainingAfterField+            in  (nextField:rowTail, remainingText)+        +        -- if there are no more fields return the current fields as a singleton+        -- list+        else+            ([nextField], textRemainingAfterField)++-- parse a field giving (field, moreFieldsInRow, remainingText)+parseField :: Format -> String -> (String, Bool, String)+parseField _ [] = ("", False, "")+parseField format text =+    -- check if this field is quoted or not+    if (quote format) `isPrefixOf` text then+        let tailOfQuote = drop (length (quote format)) text+        in  parseQuotedField format tailOfQuote+    else+        parseUnquotedField format text++-- parse a quoted field giving (field, moreFieldsInRow, remainingText)+parseQuotedField :: Format -> String -> (String, Bool, String)+parseQuotedField _ [] = ("", False, "")+parseQuotedField format text@(textHead:textTail) =+    -- a double quote is an escaped quote, so add a quote to the field+    if (doubleQuote format) `isPrefixOf` text then+        let tailOfDoubleQuote = drop (length (doubleQuote format)) text+            (fieldTail, moreFieldsInRow, remainingText) = parseQuotedField format tailOfDoubleQuote+        in  ((quote format) ++ fieldTail, moreFieldsInRow, remainingText)+    +    -- a single quote is the end of the field, we can use parseUnquotedField to+    -- chew up any chars between the ending quote and the next delimiter (there+    -- really shouldn't be any if the text is formatted well, but you never+    -- know)+    else if (quote format) `isPrefixOf` text then+        let tailOfQuote = drop (length (quote format)) text+            (_, moreFieldsInRow, remainingText) = parseUnquotedField format tailOfQuote+        in  ("", moreFieldsInRow, remainingText)+    +    -- just another character... toss it in the field and keep going+    else+        let (fieldTail, moreFieldsInRow, remainingText) = parseQuotedField format textTail+        in  (textHead:fieldTail, moreFieldsInRow, remainingText)++-- parse an unquoted field giving (field, moreFieldsInRow, remainingText)+parseUnquotedField :: Format -> String -> (String, Bool, String)+parseUnquotedField _ [] = ("", False, "")+parseUnquotedField format text@(textHead:textTail) =+    -- if we hit a field delimiter: return an empty string and let caller know+    -- there are more fields in this row+    if (fieldDelimiter format) `isPrefixOf` text then+        let tailOfDelimiter = drop (length (fieldDelimiter format)) text+        in  ([], True, tailOfDelimiter)+    +    -- if we hit a row delimiter: return an empty string and let caller know there+    -- are no more fields in this row+    else if (rowDelimiter format) `isPrefixOf` text then+        let tailOfDelimiter = drop (length (rowDelimiter format)) text+        in  ([], False, tailOfDelimiter)+    +    -- just another character... toss it in the field and keep going+    else+        let (fieldTail, moreFieldsInRow, remainingText) = parseUnquotedField format textTail+        in  (textHead:fieldTail, moreFieldsInRow, remainingText)
+ Database/TxtSushi/SQLExecution.hs view
@@ -0,0 +1,655 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Database.TxtSushi.SQLExecution+-- Copyright   :  (c) Keith Sheppard 2009+-- License     :  GPL3 or greater+-- Maintainer  :  keithshep@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Module for executing a SQL statement+--+-----------------------------------------------------------------------------++module Database.TxtSushi.SQLExecution (+    select,+    databaseTableToTextTable,+    textTableToDatabaseTable) where++import Data.Char+import Data.List+import qualified Data.Map as Map+import Text.Regex.Posix++import Database.TxtSushi.SQLParser+import Database.TxtSushi.Transform+import Database.TxtSushi.Util.ListUtil++-- | an SQL table data structure+--   TODO: need allColumnsColumnIdentifiers and allColumnsTableRows so that+--         we can filter and order on columns that are selected out. we also+--         should track any column ordering that is in place+data DatabaseTable = DatabaseTable {+    -- | the columns in this table+    columnIdentifiers :: [ColumnIdentifier],+    +    -- | the actual table data+    tableRows :: [[EvaluatedExpression]]}++emptyTable = DatabaseTable [] []++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")}++intExpression int = EvaluatedExpression {+    preferredType   = IntType,+    maybeIntValue   = Just int,+    maybeRealValue  = Just $ fromIntegral int,+    stringValue     = show int,+    maybeBoolValue  = Just $ int /= 0}++realExpression real = EvaluatedExpression {+    preferredType   = RealType,+    maybeIntValue   = Just $ floor real,+    maybeRealValue  = Just real,+    stringValue     = show real,+    maybeBoolValue  = Just $ real /= 0.0}++boolExpression bool = EvaluatedExpression {+    preferredType   = BoolType,+    maybeIntValue   = Nothing,+    maybeRealValue  = Nothing,+    stringValue     = show bool,+    maybeBoolValue  = Just bool}++intValue :: EvaluatedExpression -> Int+intValue evalExpr = case maybeIntValue evalExpr of+    Just int -> int+    Nothing ->+        error $ "could not convert \"" ++ (stringValue evalExpr) +++                "\" to an integer value"++realValue :: EvaluatedExpression -> Double+realValue evalExpr = case maybeRealValue evalExpr of+    Just real -> real+    Nothing ->+        error $ "could not convert \"" ++ (stringValue 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+    "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++boolCompare (EvaluatedExpression _ _ _ _ (Just b1)) (EvaluatedExpression _ _ _ _ (Just b2)) =+    compare b1 b2+boolCompare expr1 expr2 = stringCompare expr1 expr2++stringCompare expr1 expr2 = stringValue expr1 `compare` stringValue expr2++-- 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)+    where+        makeColId colName = ColumnIdentifier (Just tableName) colName++databaseTableToTextTable :: DatabaseTable -> [[String]]+databaseTableToTextTable dbTable =+    let+        headerRow = (map columnId (columnIdentifiers dbTable))+        tailRows = map (map stringValue) (tableRows dbTable)+    in+        headerRow:tailRows++-- | perform a SQL select with the given select statement on the+--   given table map+select :: SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable+select selectStatement 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+    in+        case maybeGroupByHaving selectStatement of+            Nothing ->+                if selectStatementContainsAggregates selectStatement then+                    finishWithAggregateSelect selectStatement [filteredTbl]+                else+                    finishWithNormalSelect selectStatement filteredTbl+            Just groupByPart ->+                let+                    tblGroups = performGroupBy groupByPart filteredTbl+                in+                    finishWithAggregateSelect selectStatement tblGroups++finishWithNormalSelect selectStatement filteredDbTable =+    let+        orderedTbl = orderRowsBy (orderByItems selectStatement) filteredDbTable+        selectedTbl =+            evaluateColumnSelections (columnSelections selectStatement) orderedTbl+    in+        selectedTbl++finishWithAggregateSelect selectStatement aggregateTbls =+    let+        orderedTbls = orderTablesBy (orderByItems selectStatement) aggregateTbls+        selectedTbl =+            evaluateAggregateColumnSelections (columnSelections selectStatement) orderedTbls+    in+        selectedTbl++performGroupBy :: ([Expression], Maybe Expression) -> DatabaseTable -> [DatabaseTable]+performGroupBy (groupByExprs, maybeExpr) dbTable =+    let+        tblGroups = groupRowsBy groupByExprs dbTable+    in+        case maybeExpr of+            Nothing -> tblGroups+            Just expr -> filterTablesBy expr tblGroups++-- | sorts table rows by the given order by items+orderRowsBy :: [OrderByItem] -> DatabaseTable -> DatabaseTable+orderRowsBy [] dbTable = dbTable+orderRowsBy 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)+    in+        dbTable {tableRows = sortedRows}++orderTablesBy :: [OrderByItem] -> [DatabaseTable] -> [DatabaseTable]+orderTablesBy [] dbTables = dbTables+orderTablesBy orderBys dbTables =+    sortBy (compareTablesOnOrderItems orderBys) dbTables++-- | Compares two rows using the given OrderByItems and column ID's+compareRowsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering+compareRowsOnOrderItems orderBys colIds row1 row2 =+    cascadingOrder $ toOrderList orderBys+    where+        toOrderList [] = []+        toOrderList (orderBy:orderByTail) =+            (compareRowsOnOrderItem orderBy colIds row1 row2):(toOrderList orderByTail)++-- | Compares two rows using the given OrderByItem and column ID's+compareRowsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering+compareRowsOnOrderItem orderBy colIds row1 row2 =+    let+        orderExpr = orderExpression orderBy+        rowComp = compareRowsOnExpression orderExpr colIds row1 row2+    in+        if orderAscending orderBy then+            rowComp+        else+            reverseOrdering rowComp++compareTablesOnOrderItems :: [OrderByItem] -> DatabaseTable -> DatabaseTable -> Ordering+compareTablesOnOrderItems orderBys dbTable1 dbTable2 =+    cascadingOrder $ toOrderList orderBys+    where+        toOrderList [] = []+        toOrderList (orderBy:orderByTail) =+            (compareTablesOnOrderItem orderBy dbTable1 dbTable2):(toOrderList orderByTail)++compareTablesOnOrderItem :: OrderByItem -> DatabaseTable -> DatabaseTable -> Ordering+compareTablesOnOrderItem orderBy dbTable1 dbTable2 =+    let+        orderExpr = orderExpression orderBy+        rowComp = compareTablesOnExpression orderExpr dbTable1 dbTable2+    in+        if orderAscending orderBy then+            rowComp+        else+            reverseOrdering rowComp++-- | reverses the given ordering. pretty CRAZY huh???+reverseOrdering :: Ordering -> Ordering+reverseOrdering EQ = EQ+reverseOrdering LT = GT+reverseOrdering GT = LT++-- | Compares two rows using the given expressions+compareRowsOnExpressions :: [Expression] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering+compareRowsOnExpressions exprs colIds row1 row2 =+    cascadingOrder $ toOrderList exprs+    where+        toOrderList [] = []+        toOrderList (expr:exprTail) =+            (compareRowsOnExpression expr colIds row1 row2):(toOrderList exprTail)++-- | Compares two rows using the given expression+compareRowsOnExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering+compareRowsOnExpression expr colIds row1 row2 =+    let+        row1Eval = evalExpression expr colIds row1+        row2Eval = evalExpression expr colIds row2+    in+        row1Eval `compare` row2Eval++compareTablesOnExpression :: Expression -> DatabaseTable -> DatabaseTable -> Ordering+compareTablesOnExpression expr tbl1 tbl2 =+    let+        tbl1Eval = evalAggregateExpression expr tbl1+        tbl2Eval = evalAggregateExpression expr tbl2+    in+        tbl1Eval `compare` tbl2Eval++groupRowsBy :: [Expression] -> DatabaseTable -> [DatabaseTable]+groupRowsBy groupByExprs dbTable =+    -- create a new table for every row grouping+    map replaceTableRows rowGroups+    where+        tblRows = tableRows dbTable+        +        -- curry in the exprs and col ID params to make a row comparison function+        compareRows = compareRowsOnExpressions groupByExprs (columnIdentifiers dbTable)+        row1 `rowsEq` row2 = (row1 `compareRows` row2) == EQ+        +        sortedRows = sortBy 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 =+    case tblExpr of+        TableIdentifier tblName maybeTblAlias ->+            let+                -- find the from table map (error if missing)+                noTblError = error $ "failed to find table named " ++ tblName+                table = Map.findWithDefault noTblError tblName tableMap+            in+                maybeRename maybeTblAlias table+        +        -- TODO inner join should allow joining on expressions too!!+        InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias ->+            let+                leftJoinTbl = evalTableExpression leftJoinTblExpr tableMap+                rightJoinTbl = evalTableExpression rightJoinTblExpr tableMap+                joinCols = extractJoinCols onConditionExpr+                joinIndices = joinColumnIndices leftJoinTbl rightJoinTbl joinCols+                joinedTbl = innerJoin joinIndices leftJoinTbl rightJoinTbl+            in+                maybeRename maybeTblAlias joinedTbl+        +        -- TODO implement me+        CrossJoin leftJoinTbl maybeTblAlias rightJoinTbl ->+            error "Sorry! CROSS JOIN is not yet implemented"+    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 (FunctionExpression sqlFunc [arg1, arg2]) =+    case sqlFunc of+        SQLFunction "AND" _ _   -> extractJoinCols arg1 ++ extractJoinCols arg2+        SQLFunction "=" _ _     -> extractJoinColPair arg1 arg2+        +        -- Only expecting "AND" or "="+        otherwise -> onPartFormattingError+    where+        extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)]+        +        -- Only expecting "AND" or "="+        extractJoinColPair _ _ = onPartFormattingError++-- Only expecting "AND" or "="+extractJoinCols _ = onPartFormattingError++onPartFormattingError =+    error $ "The \"ON\" part of a join must only contain column equalities " +++            "joined together by \"AND\" like: " +++            "\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\""++-- | perform an inner join using the given join indices on the given+--   tables+innerJoin :: [(Int, Int)] -> DatabaseTable -> DatabaseTable -> DatabaseTable+innerJoin joinIndices leftJoinTbl rightJoinTbl = DatabaseTable {+    columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),+    tableRows = joinTables joinIndices (tableRows leftJoinTbl) (tableRows rightJoinTbl)}++-- | convert the column ID pairs into index pairs+joinColumnIndices :: DatabaseTable -> DatabaseTable -> [(ColumnIdentifier, ColumnIdentifier)] -> [(Int, Int)]+joinColumnIndices leftJoinTbl rightJoinTbl joinCols =+    let+        leftHeader = columnIdentifiers leftJoinTbl+        rightHeader = columnIdentifiers rightJoinTbl+    in+        map (idPairToIndexPair leftHeader rightHeader) joinCols++-- | convert the column ID pair into an index pair+idPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> (Int, Int)+idPairToIndexPair leftColIds rightColIds joinColPair@(leftColId, rightColId) =+    let+        maybePairInOrder = maybeIdPairToIndexPair leftColIds rightColIds joinColPair+        maybePairSwapped = maybeIdPairToIndexPair leftColIds rightColIds (rightColId, leftColId)+    in+        case maybePairInOrder of+            Just thePairInOrder -> thePairInOrder+            Nothing ->+                case maybePairSwapped of+                    Just thePairSwapped -> thePairSwapped+                    Nothing -> error "failed to find given columns"++maybeIdPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> Maybe (Int, Int)+maybeIdPairToIndexPair leftColIds rightColIds (leftColId, rightColId) = do+    leftIndex <- findIndex (== leftColId) leftColIds+    rightIndex <- findIndex (== rightColId) rightColIds+    return (leftIndex, rightIndex)++evaluateColumnSelections :: [ColumnSelection] -> DatabaseTable -> DatabaseTable+evaluateColumnSelections colSelections dbTable =+    let+        selectionTbls = map ($ dbTable) (map evaluateColumnSelection colSelections)+    in+        foldl1' tableConcat selectionTbls++tableConcat :: DatabaseTable -> DatabaseTable -> DatabaseTable+tableConcat dbTable1 dbTable2 =+    let+        concatIds = (columnIdentifiers dbTable1) ++ (columnIdentifiers dbTable2)+        concatRows = zipWith (++) (tableRows dbTable1) (tableRows dbTable2)+    in+        DatabaseTable concatIds concatRows++evaluateAggregateColumnSelections :: [ColumnSelection] -> [DatabaseTable] -> DatabaseTable+evaluateAggregateColumnSelections colSelections tblGroups =+    let+        selectionTbls = map ($ tblGroups) (map evaluateAggregateColumnSelection colSelections)+    in+        foldl1' tableConcat selectionTbls++evaluateAggregateColumnSelection :: ColumnSelection -> [DatabaseTable] -> DatabaseTable+evaluateAggregateColumnSelection AllColumns tblGroups =+    error "* is not allowed for aggregate column selections"+evaluateAggregateColumnSelection (AllColumnsFrom srcTblName) tblGroups =+    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) =+    let+        tblColIds = columnIdentifiers headGrp+        exprColId = expressionIdentifier expr+        evaluatedExprs = map (evalAggregateExpression expr) tblGroups+    in+        DatabaseTable [exprColId] (transpose [evaluatedExprs])++evaluateColumnSelection :: ColumnSelection -> DatabaseTable -> DatabaseTable+evaluateColumnSelection AllColumns dbTable = dbTable+evaluateColumnSelection (AllColumnsFrom srcTblName) dbTable =+    let+        colIds = columnIdentifiers dbTable+        indices = findIndices matchesSrcTblName (map maybeTableName colIds)+        selectedColIds = selectIndices indices colIds+        selectedColRows = map (selectIndices indices) (tableRows dbTable)+    in+        DatabaseTable selectedColIds selectedColRows+    where+        matchesSrcTblName Nothing           = False+        matchesSrcTblName (Just tblName)    = tblName == srcTblName+        selectIndices indices xs = [xs !! i | i <- indices]+evaluateColumnSelection (ExpressionColumn expr) dbTable =+    let+        tblColIds = columnIdentifiers dbTable+        exprColId = expressionIdentifier expr+        evaluatedExprs = map (evalExpression expr tblColIds) (tableRows dbTable)+    in+        DatabaseTable [exprColId] (transpose [evaluatedExprs])++-- | This is a little different that a strict equals compare in that it returns+--   true if the query column has a Nothing table and the column name part+--   matches the reference column's name. Also not that this makes it+--   an asymetric comparison+columnMatches :: ColumnIdentifier -> ColumnIdentifier -> Bool+columnMatches (ColumnIdentifier Nothing queryColIdStr) referenceColumn =+    -- In this case we don't care about the table name so+    -- just check to make sure that the column names match up+    queryColIdStr == columnId referenceColumn++columnMatches queryColumn referenceColumn =+    -- table name is important here so match on the whole object+    queryColumn == referenceColumn++-- | filters the database's table rows on the given expression+filterRowsBy :: Expression -> DatabaseTable -> DatabaseTable+filterRowsBy filterExpr table =+    table {tableRows = filter myBoolEvalExpr (tableRows table)}+    where myBoolEvalExpr row =+            boolValue $ evalExpression filterExpr (columnIdentifiers table) row++filterTablesBy :: Expression -> [DatabaseTable] -> [DatabaseTable]+filterTablesBy expr dbTables =+    filter filterFunc dbTables+    where+        filterFunc = boolValue . evalAggregateExpression expr++-- | evaluate the given expression against a table+--   TODO need better error detection and reporting for non-aggregate+--   expressions+evalAggregateExpression :: Expression -> DatabaseTable -> EvaluatedExpression+evalAggregateExpression (StringConstantExpression string) _ = stringExpression string+evalAggregateExpression (IntegerConstantExpression int) _   = intExpression int+evalAggregateExpression (RealConstantExpression real) _     = realExpression real+evalAggregateExpression (ColumnExpression col) dbTable =+    case findIndex (columnMatches col) (columnIdentifiers dbTable) of+        Just colIndex -> (head $ tableRows dbTable) !! colIndex+        Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col)++evalAggregateExpression (FunctionExpression sqlFun funArgs) dbTable =+    evalSQLFunction sqlFun $ if isAggregate sqlFun then manyArgs else aggregatedArgs+    where+        aggregatedArgs = map (\e -> evalAggregateExpression e dbTable) funArgs+        manyArgs =+            let+                tblColIds = columnIdentifiers dbTable+                tblRows = tableRows dbTable+                evaluateExprs expr = map (evalExpression expr tblColIds) tblRows+                allArgs = concatMap evaluateExprs funArgs+            in+                allArgs++-- | evaluate the given expression against a table row+evalExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> EvaluatedExpression+evalExpression (StringConstantExpression string) _ _    = stringExpression string+evalExpression (IntegerConstantExpression int) _ _      = intExpression int+evalExpression (RealConstantExpression real) _ _        = realExpression real+evalExpression (ColumnExpression col) columnIds tblRow =+    case findIndex (columnMatches col) columnIds of+        Just colIndex -> tblRow !! colIndex+        Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col)+evalExpression (FunctionExpression sqlFun funArgs) columnIds tblRow =+    evalSQLFunction sqlFun (map evalArgExpr funArgs)+    where+        evalArgExpr expr = evalExpression expr columnIds tblRow++evalSQLFunction sqlFun evaluatedArgs+    -- Global validation+    -- TODO this error should be more helpful than it is+    | not $ argCountIsValid =+        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 == substringFromToFunction =+        stringExpression $ take (intValue arg3) (drop (intValue arg2 - 1) (stringValue arg1))+    | sqlFun == substringFromFunction =+        stringExpression $ drop (intValue arg2 - 1) (stringValue arg1)+    | sqlFun == regexMatchFunction = boolExpression $ (stringValue arg1) =~ (stringValue 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)+    +    -- algebraic+    | sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs+    | sqlFun == divideFunction = realExpression $ (realValue arg1) / (realValue 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)+    +    -- aggregate+    | sqlFun == avgFunction =+        realExpression $ foldl1' (+) (map realValue evaluatedArgs) / (fromIntegral $ length evaluatedArgs)+    | sqlFun == countFunction = intExpression $ length evaluatedArgs+    | sqlFun == firstFunction = head evaluatedArgs+    | sqlFun == lastFunction = last evaluatedArgs+    | sqlFun == maxFunction = maximum evaluatedArgs+    | sqlFun == minFunction = minimum evaluatedArgs+    | sqlFun == sumFunction = algebraWithCoercion (+) (+) evaluatedArgs+    +    -- error!!+    | otherwise = error $+        "internal error: missing evaluation code for function: " +++        functionName sqlFun ++ ". please report this error"+    +    where+        arg1 = head evaluatedArgs+        arg2 = evaluatedArgs !! 1+        arg3 = evaluatedArgs !! 2+        subStringF start extent string = take extent (drop start string)+        algebraWithCoercion intFunc realFunc args =+            if any useRealAlgebra args then+                realExpression $ foldl1' realFunc (map realValue args)+            else+                intExpression $ foldl1' intFunc (map intValue args)+        +        useRealAlgebra expr =+            let+                prefType = preferredType expr+                maybeInt = maybeIntValue expr+            in+                prefType == RealType || maybeInt == Nothing+        +        argCountIsValid =+            let+                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}+-}++-- | trims leading and trailing spaces+trimSpace :: String -> String+trimSpace = f . f+   where f = reverse . dropWhile isSpace
+ Database/TxtSushi/SQLParser.hs view
@@ -0,0 +1,864 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Database.TxtSushi.SQLParser+-- Copyright   :  (c) Keith Sheppard 2009+-- License     :  GPL3 or greater+-- Maintainer  :  keithshep@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Module for parsing SQL+--+-----------------------------------------------------------------------------++module Database.TxtSushi.SQLParser (+    allMaybeTableNames,+    parseSelectStatement,+    SelectStatement(..),+    TableExpression(..),+    ColumnIdentifier(..),+    prettyFormatColumn,+    ColumnSelection(..),+    expressionIdentifier,+    Expression(..),+    OrderByItem(..),+    prettyFormatWithArgs,+    SQLFunction(..),+    withTrailing,+    withoutTrailing,+    isAggregate,+    selectStatementContainsAggregates,+    +    -- aggregates+    avgFunction,+    countFunction,+    firstFunction,+    lastFunction,+    maxFunction,+    minFunction,+    sumFunction,+    +    -- String SQL function+    concatenateFunction,+    upperFunction,+    lowerFunction,+    trimFunction,+    substringFromFunction,+    substringFromToFunction,+    +    -- Algebraic SQL functions+    multiplyFunction,+    divideFunction,+    plusFunction,+    minusFunction,+    negateFunction,+    +    -- Boolean SQL functions+    isFunction,+    isNotFunction,+    lessThanFunction,+    lessThanOrEqualToFunction,+    greaterThanFunction,+    greaterThanOrEqualToFunction,+    andFunction,+    orFunction,+    notFunction,+    regexMatchFunction,+    +    -- Etc...+    maybeReadInt,+    maybeReadReal) where++import Data.Char+import Data.List+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Expr+import Database.TxtSushi.Util.ListUtil++--------------------------------------------------------------------------------+-- The data definition for select statements+--------------------------------------------------------------------------------++-- | represents a select statement+--   TODO this should be moved inside the TableExpression type+data SelectStatement = SelectStatement {+    columnSelections :: [ColumnSelection],+    maybeFromTable :: Maybe TableExpression,+    maybeWhereFilter :: Maybe Expression,+    maybeGroupByHaving :: Maybe ([Expression], Maybe Expression),+    orderByItems :: [OrderByItem]}+    deriving (Show, Ord, Eq)++data TableExpression =+    TableIdentifier {+        tableName :: String,+        maybeTableAlias :: Maybe String} |+    InnerJoin {+        leftJoinTable :: TableExpression,+        rightJoinTable :: TableExpression,+        onCondition :: Expression,+        maybeTableAlias :: Maybe String} |+    CrossJoin {+        leftJoinTable :: TableExpression,+        rightJoinTable :: TableExpression,+        maybeTableAlias :: Maybe String}+    deriving (Show, Ord, Eq)++-- | convenience function for extracting all of the table names used by the+--   given table expression+allMaybeTableNames :: (Maybe TableExpression) -> [String]+allMaybeTableNames Nothing = []+allMaybeTableNames (Just tblExp) = allTableNames tblExp++allTableNames (TableIdentifier tblName _) = [tblName]+allTableNames (InnerJoin lftTbl rtTbl _ _) =+    (allTableNames lftTbl) ++ (allTableNames rtTbl)+allTableNames (CrossJoin lftTbl rtTbl _) =+    (allTableNames lftTbl) ++ (allTableNames rtTbl)++data ColumnSelection =+    AllColumns |+    AllColumnsFrom {sourceTableName :: String} |+    ExpressionColumn {expression :: Expression}+    --QualifiedColumn {+    --    qualifiedColumnId :: ColumnIdentifier}+    deriving (Show, Ord, Eq)++data ColumnIdentifier =+    ColumnIdentifier {+        maybeTableName :: Maybe String,+        columnId :: String}+    deriving (Show, Ord, Eq)++-- | I wanted to leave the default Show, but I also wanted a pretty print, so+--   here it is!+prettyFormatColumn :: ColumnIdentifier -> String+prettyFormatColumn (ColumnIdentifier (Just tblName) colId) = tblName ++ "." ++ colId+prettyFormatColumn (ColumnIdentifier (Nothing) colId) = colId++data Expression =+    FunctionExpression {+        sqlFunction :: SQLFunction,+        functionArguments :: [Expression]} |+    ColumnExpression {+        column :: ColumnIdentifier} |+    StringConstantExpression {+        stringConstant :: String} |+    IntegerConstantExpression {+        intConstant :: Int} |+    RealConstantExpression {+        realConstant :: Double}+    deriving (Show, Ord, Eq)++-- | an aggregate function is one whose min function count is 1 and whose+--   arg count is not fixed+isAggregate :: SQLFunction -> Bool+isAggregate sqlFun = minArgCount sqlFun == 1 && not (argCountIsFixed sqlFun)++containsAggregates :: Expression -> Bool+containsAggregates (FunctionExpression sqlFun args) =+    isAggregate sqlFun || any containsAggregates args+containsAggregates _ = False++selectionContainsAggregates :: ColumnSelection -> Bool+selectionContainsAggregates (ExpressionColumn expr) =+    containsAggregates expr+selectionContainsAggregates _ = False++orderByItemContainsAggregates :: OrderByItem -> Bool+orderByItemContainsAggregates (OrderByItem expr _) =+    containsAggregates expr++selectStatementContainsAggregates :: SelectStatement -> Bool+selectStatementContainsAggregates select =+    any selectionContainsAggregates (columnSelections select) ||+    any orderByItemContainsAggregates (orderByItems select)++expressionIdentifier :: Expression -> ColumnIdentifier+expressionIdentifier (FunctionExpression func args) =+    ColumnIdentifier Nothing ((prettyFormatWithArgs func) args)+expressionIdentifier (ColumnExpression col) = col+expressionIdentifier (StringConstantExpression str) =+    ColumnIdentifier Nothing ("\"" ++ str ++ "\"")+expressionIdentifier (IntegerConstantExpression int) =+    ColumnIdentifier Nothing (show int)+expressionIdentifier (RealConstantExpression real) =+    ColumnIdentifier Nothing (show real)++needsParens :: Expression -> Bool+needsParens (FunctionExpression _ _) = True+needsParens _ = False++toArgString :: Expression -> String+toArgString expr =+    let exprFmt = prettyFormatColumn $ expressionIdentifier expr+    in if needsParens expr then "(" ++ exprFmt ++ ")" else exprFmt++prettyFormatWithArgs :: SQLFunction -> [Expression] -> String+prettyFormatWithArgs sqlFunc funcArgs+    | sqlFunc `elem` normalSyntaxFunctions = prettyFormatNormalFunctionExpression sqlFunc funcArgs+    | or (map (sqlFunc `elem`) infixFunctions) = prettyFormatInfixFunctionExpression sqlFunc funcArgs+    | sqlFunc == negateFunction = "-" ++ toArgString (head funcArgs)+    | sqlFunc == countFunction = functionName countFunction ++ "(*)"+    | sqlFunc == substringFromToFunction ||+      sqlFunc == substringFromFunction ||+      sqlFunc == notFunction =+        prettyFormatNormalFunctionExpression sqlFunc funcArgs++prettyFormatInfixFunctionExpression :: SQLFunction -> [Expression] -> String+prettyFormatInfixFunctionExpression sqlFunc funcArgs =+    let+        arg1 = head funcArgs+        arg2 = funcArgs !! 1+    in+        toArgString arg1 ++ functionName sqlFunc ++ toArgString arg2++prettyFormatNormalFunctionExpression :: SQLFunction -> [Expression] -> String+prettyFormatNormalFunctionExpression sqlFunc funcArgs =+    let argString = intercalate ", " (map toArgString funcArgs)+    in functionName sqlFunc ++ "(" ++ argString ++ ")"++data SQLFunction = SQLFunction {+    functionName :: String,+    minArgCount :: Int,+    argCountIsFixed :: Bool}+    deriving (Show, Ord, Eq)++data OrderByItem = OrderByItem {+    orderExpression :: Expression,+    orderAscending :: Bool}+    deriving (Show, Ord, Eq)++-- | Parses a SQL select statement+parseSelectStatement :: GenParser Char st SelectStatement+parseSelectStatement = (try $ spaces >> parseToken "SELECT") >> parseSelectBody++-- | Parses all of the stuff that comes after "SELECT "+parseSelectBody :: GenParser Char st SelectStatement+parseSelectBody = do+    columnVals <- parseColumnSelections+    -- TODO need a better error message for missing "ON" etc. in+    -- the from part, can do this by grabing "FROM" first+    maybeFrom <- maybeParseFromPart+    maybeWhere <- maybeParseWherePart+    groupByExprs <- maybeParseGroupByPart+    orderBy <- parseOrderByPart+    +    return SelectStatement {+        columnSelections    = columnVals,+        maybeFromTable      = maybeFrom,+        maybeWhereFilter    = maybeWhere,+        orderByItems        = orderBy,+        maybeGroupByHaving  = groupByExprs}+    +    where+        maybeParseFromPart =+            ifParseThen (parseToken "FROM") parseTableExpression+        +        maybeParseWherePart =+            ifParseThen (parseToken "WHERE") parseExpression++-- | Parses the "ORDER BY ..." part of a select statement returning the list+--   of OrderByItem's that were parsed (this list will be empty if there is no+--   "ORDER BY" parsed+parseOrderByPart :: GenParser Char st [OrderByItem]+parseOrderByPart =+    ifParseThenElse+        -- if we see an "ORDER BY"+        (parseToken "ORDER")+        +        -- then parse the order expressions+        (parseToken "BY" >> sepByAtLeast 1 parseOrderByItem commaSeparator)+        +        -- else there is nothing to sort by+        (return [])+    +    where+        parseOrderByItem :: GenParser Char st OrderByItem+        parseOrderByItem = do+            orderExpr <- parseExpression+            isAscending <- ifParseThenElse+                -- if we parse "DESC"+                (try parseDescending)+                +                -- then return false, it isn't ascending+                (return False)+                +                -- else try to consume "ASC" but even if we don't it's still+                -- ascending so return true unconditionally+                ((parseAscending <|> return []) >> return True)+            +            return $ OrderByItem orderExpr isAscending+        +        parseAscending  = parseToken "ASCENDING" <|> parseToken "ASC"+        parseDescending = parseToken "DESCENDING" <|> parseToken "DESC"++maybeParseGroupByPart =+    ifParseThen+        -- if we see a "GROUP BY"+        (parseToken "GROUP")+        +        -- then parse the expressions+        (parseToken "BY" >> parseGroupBy)+    +    where+        parseGroupBy = do+            groupExprs <- atLeastOneExpr+            maybeHavingExpr <- ifParseThen (parseToken "HAVING") parseExpression+            return (groupExprs, maybeHavingExpr)++atLeastOneExpr = sepByAtLeast 1 parseExpression commaSeparator++--------------------------------------------------------------------------------+-- Functions for parsing the column names specified after "SELECT"+--------------------------------------------------------------------------------++parseColumnSelections =+    sepBy1 parseAnyColType (try commaSeparator)+    where parseAnyColType = parseAllCols <|>+                            (try parseAllColsFromTbl) <|>+                            (try parseColExpression)++parseAllCols = parseToken "*" >> return AllColumns++parseAllColsFromTbl = do+    tableVal <- parseIdentifier+    string "." >> spaces >> parseToken "*"+    +    return $ AllColumnsFrom tableVal++parseColExpression = parseExpression >>= \expr -> return $ ExpressionColumn expr++parseColumnId = do+    firstId <- parseIdentifier+    +    maybeFullyQual <- maybeParse $ (char '.' >> spaces)+    case maybeFullyQual of+        -- No '.' means it's a partially qualified column+        Nothing -> return $ ColumnIdentifier Nothing firstId+        Just _ -> do+            secondId <- parseIdentifier+            return $ ColumnIdentifier (Just firstId) secondId++--------------------------------------------------------------------------------+-- Functions for parsing the table part (after "FROM")+--------------------------------------------------------------------------------++parseTableExpression = do+    nextTblChunk <- parseNextTblExpChunk+    +    let ifInnerJoinParse = ifParseThenElse+            -- if+            ((maybeParse $ parseToken "INNER") >> parseToken "JOIN")+            -- then+            (parseInnerJoinRemainder nextTblChunk)+            -- else+            (return nextTblChunk)+        +        ifCrossOrInnerJoinParse = ifParseThenElse+            -- if+            (parseToken "CROSS" >> parseToken "JOIN")+            -- then+            (parseCrossJoinRemainder nextTblChunk)+            -- else+            ifInnerJoinParse+    +    ifCrossOrInnerJoinParse++parseNextTblExpChunk =+    parenthesize parseTableExpression <|>  parseTableIdentifier++parseInnerJoinRemainder leftTblExpr = do+    rightTblExpr <- parseTableExpression+    +    parseToken "ON"+    onPart <- parseExpression+    +    maybeAlias <- maybeParse parseTableAlias+    +    return InnerJoin {+            leftJoinTable=leftTblExpr,+            rightJoinTable=rightTblExpr,+            onCondition=onPart,+            maybeTableAlias=maybeAlias}++parseCrossJoinRemainder leftTblExpr = do+    rightTblExpr <- parseTableExpression+    maybeAlias <- maybeParse parseTableAlias+    +    return CrossJoin {+            leftJoinTable=leftTblExpr,+            rightJoinTable=rightTblExpr,+            maybeTableAlias=maybeAlias}++parseTableIdentifier = do+    theId <- parseIdentifier+    maybeAlias <- maybeParse parseTableAlias+    return $ TableIdentifier theId maybeAlias++parseTableAlias = parseToken "AS" >> parseIdentifier++--------------------------------------------------------------------------------+-- Expression parsing: These can be after "SELECT", "WHERE" or "HAVING"+--------------------------------------------------------------------------------++parseExpression :: GenParser Char st Expression+parseExpression =+    let opTable = map (map parseInfixOp) infixFunctions+    in buildExpressionParser opTable parseAnyNonInfixExpression <?> "expression"++parseAnyNonInfixExpression :: GenParser Char st Expression+parseAnyNonInfixExpression =+    parenthesize parseExpression <|>+    parseStringConstant <|>+    try parseRealConstant <|>+    try parseIntConstant <|>+    parseAnyNormalFunction <|>+    parseNegateFunction <|>+    parseSubstringFunction <|>+    parseNotFunction <|>+    parseCountStar <|>+    (parseColumnId >>= (\colId -> return $ ColumnExpression colId))++parseStringConstant :: GenParser Char st Expression+parseStringConstant =+    (quotedText True '"' <|> quotedText True '\'') >>=+    (\txt -> return $ StringConstantExpression txt)++parseIntConstant :: GenParser Char st Expression+parseIntConstant =+    parseInt >>= (\int -> return $ IntegerConstantExpression int)++parseInt :: GenParser Char st Int+parseInt = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do+    digitTxt <- anyParseTxt+    return $ read digitTxt+    where+        anyParseTxt = signedParseTxt <|> unsignedParseTxt <?> "integer"+        unsignedParseTxt = many1 digit+        signedParseTxt = do+            char '-'+            unsignedDigitTxt <- unsignedParseTxt+            return ('-':unsignedDigitTxt)++-- | returns an int if it can be read from the string+maybeReadInt :: String -> Maybe Int+maybeReadInt intStr =+    case parse (withTrailing (spaces >> eof) (spaces >> parseInt)) "" intStr of+        Left _      -> Nothing+        Right int   -> Just int++-- | returns a real if it can be read from the string+maybeReadReal :: String -> Maybe Double+maybeReadReal realStr =+    case parse (withTrailing (spaces >> eof) (spaces >> parseReal)) "" realStr of+        Left _      -> maybeReadInt realStr >>= (\int -> Just $ fromIntegral int)+        Right real  -> Just real++parseRealConstant :: GenParser Char st Expression+parseRealConstant =+    parseReal >>= (\real -> return $ RealConstantExpression real)++parseReal :: GenParser Char st Double+parseReal = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do+    realTxt <- anyParseTxt+    return $ read realTxt+    where+        anyParseTxt = signedParseTxt <|> unsignedParseTxt <?> "real"+        unsignedParseTxt = do+            intTxt <- many1 digit+            char '.'+            fracTxt <- many1 digit+            return $ intTxt ++ "." ++ fracTxt+        signedParseTxt = do+            char '-'+            unsignedDigitTxt <- unsignedParseTxt+            return ('-':unsignedDigitTxt)++parseAnyNormalFunction :: GenParser Char st Expression+parseAnyNormalFunction =+    let allParsers = map parseNormalFunction normalSyntaxFunctions+    in choice allParsers++parseNormalFunction sqlFunc =+    try (parseToken $ functionName sqlFunc) >> parseNormalFunctionArgs sqlFunc++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 =+    [upperFunction, lowerFunction, trimFunction,+     -- all aggregates except count which accepts a (*)+     avgFunction, firstFunction, lastFunction, maxFunction,+     minFunction, sumFunction]++-- non aggregates+upperFunction = SQLFunction {+    functionName    = "UPPER",+    minArgCount     = 1,+    argCountIsFixed = True}++lowerFunction = SQLFunction {+    functionName    = "LOWER",+    minArgCount     = 1,+    argCountIsFixed = True}++trimFunction = SQLFunction {+    functionName    = "TRIM",+    minArgCount     = 1,+    argCountIsFixed = True}++-- aggregates+avgFunction = SQLFunction {+    functionName    = "AVG",+    minArgCount     = 1,+    argCountIsFixed = False}++countFunction = SQLFunction {+    functionName    = "COUNT",+    minArgCount     = 1,+    argCountIsFixed = False}++firstFunction = SQLFunction {+    functionName    = "FIRST",+    minArgCount     = 1,+    argCountIsFixed = False}++lastFunction = SQLFunction {+    functionName    = "LAST",+    minArgCount     = 1,+    argCountIsFixed = False}++maxFunction = SQLFunction {+    functionName    = "MAX",+    minArgCount     = 1,+    argCountIsFixed = False}++minFunction = SQLFunction {+    functionName    = "MIN",+    minArgCount     = 1,+    argCountIsFixed = False}++sumFunction = SQLFunction {+    functionName    = "SUM",+    minArgCount     = 1,+    argCountIsFixed = False}++-- Infix functions --+infixFunctions =+    [[multiplyFunction, divideFunction],+     [plusFunction, minusFunction],+     [concatenateFunction],+     [isFunction, isNotFunction, lessThanFunction, lessThanOrEqualToFunction,+      greaterThanFunction, greaterThanOrEqualToFunction, regexMatchFunction],+     [andFunction],+     [orFunction]]++-- | 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 infixFunc =+    -- use the magic infix type, always assuming left associativity+    Infix opParser AssocLeft+    where+        opParser = parseToken (functionName infixFunc) >> return buildExpr+        buildExpr leftSubExpr rightSubExpr = FunctionExpression {+            sqlFunction = infixFunc,+            functionArguments = [leftSubExpr, rightSubExpr]}++-- Algebraic+multiplyFunction = SQLFunction {+    functionName    = "*",+    minArgCount     = 2,+    argCountIsFixed = True}++divideFunction = SQLFunction {+    functionName    = "/",+    minArgCount     = 2,+    argCountIsFixed = True}++plusFunction = SQLFunction {+    functionName    = "+",+    minArgCount     = 2,+    argCountIsFixed = True}++minusFunction = SQLFunction {+    functionName    = "-",+    minArgCount     = 2,+    argCountIsFixed = True}++-- Boolean+isFunction = SQLFunction {+    functionName    = "=",+    minArgCount     = 2,+    argCountIsFixed = True}++isNotFunction = SQLFunction {+    functionName    = "<>",+    minArgCount     = 2,+    argCountIsFixed = True}++lessThanFunction = SQLFunction {+    functionName    = "<",+    minArgCount     = 2,+    argCountIsFixed = True}++lessThanOrEqualToFunction = SQLFunction {+    functionName    = "<=",+    minArgCount     = 2,+    argCountIsFixed = True}++greaterThanFunction = SQLFunction {+    functionName    = ">",+    minArgCount     = 2,+    argCountIsFixed = True}++greaterThanOrEqualToFunction = SQLFunction {+    functionName    = ">=",+    minArgCount     = 2,+    argCountIsFixed = True}++andFunction = SQLFunction {+    functionName    = "AND",+    minArgCount     = 2,+    argCountIsFixed = True}++orFunction = SQLFunction {+    functionName    = "OR",+    minArgCount     = 2,+    argCountIsFixed = True}++concatenateFunction = SQLFunction {+    functionName    = "||",+    minArgCount     = 2,+    argCountIsFixed = True}++regexMatchFunction = SQLFunction {+    functionName    = "=~",+    minArgCount     = 2,+    argCountIsFixed = True}++-- Functions with special syntax --+specialFunctions = [substringFromFunction,+                    substringFromToFunction,+                    negateFunction,+                    notFunction]++-- | SUBSTRING(extraction_string FROM starting_position [FOR length]+--             [COLLATE collation_name])+--   TODO implement COLLATE part+substringFromFunction = SQLFunction {+    functionName    = "SUBSTRING",+    minArgCount     = 2,+    argCountIsFixed = True}+substringFromToFunction = SQLFunction {+    functionName    = "SUBSTRING",+    minArgCount     = 3,+    argCountIsFixed = True}++parseSubstringFunction :: GenParser Char st Expression+parseSubstringFunction = do+    parseToken $ functionName substringFromFunction+    eatSpacesAfter $ char '('+    strExpr <- parseExpression+    parseToken "FROM"+    startExpr <- parseExpression+    maybeLength <- ifParseThen (parseToken "FOR") parseExpression+    eatSpacesAfter $ char ')'+    +    return $ case maybeLength of+        Nothing     -> FunctionExpression substringFromFunction [strExpr, startExpr]+        Just len    -> FunctionExpression substringFromToFunction [strExpr, startExpr, len]++negateFunction = SQLFunction {+    functionName    = "-",+    minArgCount     = 1,+    argCountIsFixed = True}++parseNegateFunction :: GenParser Char st Expression+parseNegateFunction = do+    parseToken "-"+    expr <- parseAnyNonInfixExpression+    return $ FunctionExpression negateFunction [expr]++notFunction = SQLFunction {+    functionName    = "NOT",+    minArgCount     = 1,+    argCountIsFixed = True}++parseNotFunction = do+    parseToken $ functionName notFunction+    expr <- parseAnyNonInfixExpression+    return $ FunctionExpression notFunction [expr]++parseCountStar = do+    try (parseToken $ functionName countFunction)+    try parseStar <|> parseNormalFunctionArgs countFunction+    +    where+        parseStar = do+            parenthesize $ parseToken "*"+            return $ FunctionExpression countFunction [IntegerConstantExpression 0]++--------------------------------------------------------------------------------+-- Parse utility functions+--------------------------------------------------------------------------------++parseOpChar = oneOf opChars++opChars = "~!@#$%^&*-+=|\\<>/?"++withoutTrailing end p = p >>= (\x -> genNotFollowedBy end >> return x)++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 p = p >>= (\x -> spaces >> return x)++-- | find out if the given string ends with an op char+endsWithOp strToTest = last strToTest `elem` opChars++-- | A token parser that allows either upper or lower case. all trailing+--   whitespace is consumed+parseToken :: String -> GenParser Char st String+parseToken tokStr =+    eatSpacesAfter (try $ if endsWithOp tokStr then parseOpTok else parseAlphaNumTok)+    where+        parseOpTok = withoutTrailing parseOpChar (string tokStr)+        parseAlphaNumTok = withoutTrailing alphaNum (upperOrLower tokStr)++-- | parses an identifier. you can use a tick '`' as a quote for+--   an identifier with white-space+parseIdentifier = do+    let parseId = do+            let idChar = alphaNum <|> char '_'+            notFollowedBy digit+            quotedText False '`' <|> many1 idChar+    ((eatSpacesAfter parseId) `genExcept` parseReservedWord) <?> "identifier"++-- | quoted text which allows escaping by doubling the quote char+--   like "escaped quote char here:"""+quotedText allowEmpty quoteChar = do+    let quote = char quoteChar+        manyFunc = if allowEmpty then many else many1+    +    quote+    textValue <- manyFunc $ (anyChar `genExcept` quote) <|>+                            try (escapedQuote quoteChar)+    quote+    spaces+    +    return textValue++exceptChar parser theException = notFollowedBy theException >> parser++escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar++commaSeparator = eatSpacesAfter $ char ','++-- | Wraps parentheses parsers around the given inner parser+parenthesize :: GenParser Char st a -> GenParser Char st a+parenthesize innerParser = do+    eatSpacesAfter $ char '('+    innerParseResults <- innerParser+    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"++-- | if the ifParse parser succeeds return the result of thenParse, else+--   return Nothing without parsing any input+ifParseThen :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Maybe b)+ifParseThen ifParse thenPart = do+    ifResult <- maybeParse ifParse+    case ifResult of+        Just _ ->   thenPart >>= (\x -> return $ Just x)+        Nothing ->  return Nothing++-- | if ifParse succeeds then parse thenPart otherwise parse elsePart+ifParseThenElse :: GenParser tok st a -> GenParser tok st b -> GenParser tok st b -> GenParser tok st b+ifParseThenElse ifParse thenPart elsePart = do+    ifResult <- maybeParse ifParse+    case ifResult of+        Just _ -> thenPart+        Nothing -> elsePart++parseReservedWord = do+    let reservedWordParsers = map parseToken reservedWords+    choice reservedWordParsers++-- TODO are function names reserved... i don't think so+reservedWords =+    map functionName normalSyntaxFunctions +++    map functionName (concat infixFunctions) +++    map functionName specialFunctions +++    ["BY","CROSS", "FROM", "FOR", "GROUP", "HAVING", "INNER", "JOIN", "ON", "ORDER", "SELECT", "WHERE"]++-- | tries parsing both the upper and lower case versions of the given string+upperOrLower :: String -> GenParser Char st String+upperOrLower stringToParse =+    string (map toUpper stringToParse) <|>+    string (map toLower stringToParse) <?> stringToParse++-- | accepst the same input as the given parser except and input that matches+--   theException parser+genExcept :: (Show b) => GenParser tok st a -> GenParser tok st b -> GenParser tok st a+genExcept parser theException = do+    genNotFollowedBy theException+    parser++-- | a generic version of the notFollowedBy library function. We require+--   Show types so that we can better report failures+genNotFollowedBy :: (Show a) => GenParser tok st a -> GenParser tok st ()+genNotFollowedBy theParser = try $ do+    mayParseResult <- maybeParse theParser+    case mayParseResult of+        Nothing -> return ()+        Just x -> unexpected $ show x++-- | 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++-- | 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+    in parseEach itemParsers+    where+        -- for an empty parser list return an empty result+        parseEach [] = return []+        +        -- for a parser list of 1 we don't want to use a separator+        parseEach [lastParser] = lastParser >>= (\x -> return [x])+        +        -- for lists greater than 1 we do need to care about the separator+        parseEach (headParser:parserTail) = do+            resultHead <- headParser+            sepParser+            resultTail <- parseEach parserTail+            +            return $ resultHead:resultTail++-- | parse `itemParser`s seperated by at least `minCount` `sepParser`s+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)
+ Database/TxtSushi/Transform.hs view
@@ -0,0 +1,162 @@+{- |+Simple table transformations+-}+module Database.TxtSushi.Transform (+    selectColumns,+    sortColumns,+    fileBasedSortTable,+    mergeAllBy,+    joinTables,+    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 columns table =+    sortBy (rowComparison columns) table++-- | compare two rows based on given column balues+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++-- | join together two tables on the given column index pairs+joinTables :: (Ord o) => [(Int, Int)] -> [[o]] -> [[o]] -> [[o]]+joinTables joinColumnZipList table1 table2 =+    let+        (joinColumns1, joinColumns2) = unzip joinColumnZipList+        sortedTable1 = sortColumns joinColumns1 table1+        sortedTable2 = sortColumns joinColumns2 table2+    in+        joinPresortedTables joinColumnZipList sortedTable1 sortedTable2++-- | join together two tables that are presorted on the given column index pairs+joinPresortedTables :: (Ord o) => [(Int, Int)] -> [[o]] -> [[o]] -> [[o]]+joinPresortedTables joinColumnZipList sortedTable1 sortedTable2 =+    let+        (joinColumns1, joinColumns2) = unzip joinColumnZipList+        rowEq1 = (\a b -> (rowComparison joinColumns1 a b) == EQ)+        rowEq2 = (\a b -> (rowComparison joinColumns2 a b) == EQ)+        tableGroups1 = groupBy rowEq1 sortedTable1+        tableGroups2 = groupBy rowEq2 sortedTable2+    in+        joinGroupedTables joinColumnZipList tableGroups1 tableGroups2++permutePrependRows [] _ = []+permutePrependRows _ [] = []+permutePrependRows (table1HeadRow:table1Tail) table2 =+    let+        prependHead = (table1HeadRow ++)+        newTable2 = map prependHead table2+    in+        newTable2 ++ (permutePrependRows table1Tail table2)++joinGroupedTables _ [] _  = []+joinGroupedTables _ _  [] = []+joinGroupedTables joinColumnZipList tableGroups1@(headTableGroup1:tableGroupsTail1) tableGroups2@(headTableGroup2:tableGroupsTail2) =+    let+        headRow1 = head headTableGroup1+        headRow2 = head headTableGroup2+    in+        case asymmetricRowComparison joinColumnZipList headRow1 headRow2 of+            -- drop the 1st group if its smaller+            LT -> joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroups2+            +            -- drop the 2nd group if its smaller+            GT -> joinGroupedTables joinColumnZipList tableGroups1 tableGroupsTail2+            +            -- the two groups are equal so permute+            otherwise ->+                (permutePrependRows headTableGroup1 headTableGroup2) +++                (joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroupsTail2)++asymmetricRowComparison [] _ _ = EQ+asymmetricRowComparison (columnsZipHead:columnsZipTail) row1 row2 =+    let+        (columnHead1, columnHead2) = columnsZipHead+        colComparison = (row1 !! columnHead1) `compare` (row2 !! columnHead2)+    in+        case colComparison of+            EQ          -> asymmetricRowComparison columnsZipTail row1 row2+            otherwise   -> colComparison+
+ Database/TxtSushi/Util/CommandLineArgument.hs view
@@ -0,0 +1,213 @@+module Database.TxtSushi.Util.CommandLineArgument (+    extractCommandLineArguments,+    formatCommandLine,+    CommandLineDescription(CommandLineDescription),+    options,+    minTailArgumentCount,+    tailArgumentNames,+    tailArgumentCountIsFixed,+    OptionDescription(OptionDescription),+    isRequired,+    optionFlag,+    argumentNames,+    minArgumentCount,+    argumentCountIsFixed) where++import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+--import Test.HUnit++data CommandLineDescription = CommandLineDescription {+    options :: [OptionDescription],+    +    minTailArgumentCount :: Int,+    +    tailArgumentNames :: [String],+    +    tailArgumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)++-- | a data structure for describing command line arguments+data OptionDescription = OptionDescription {+    +    -- | determines if this is a required option or not+    isRequired :: Bool,+    +    {- |+    What flag should we use. Eg: "-pretty-output"+    -}+    optionFlag :: String,+    +    {- |+    The name(s) to use for the argument(s).+    -}+    argumentNames :: [String],+    +    {- |+    the minimum number of args allowed+    -}+    minArgumentCount :: Int,+    +    {- |+    if true then 'minArgumentCount' is the upper threshold+    -}+    argumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)++space = " ";+etc = "...";++formatCommandLine commandLine =+    let formattedOptions = formatOptions (options commandLine)+        formattedTailArgs = formatTailArguments commandLine+    in+        if null formattedOptions || null formattedTailArgs then+            formattedOptions ++ formattedTailArgs+        else+            formattedOptions ++ space ++ formattedTailArgs++formatTailArguments commandLine =+    let tailArgs = tailArgumentNames commandLine+        minTailArgs = minTailArgumentCount commandLine+        formattedTailArgs = intercalate space (take minTailArgs (cycle tailArgs))+    in+        if tailArgumentCountIsFixed commandLine then+            formattedTailArgs+         else+            if null formattedTailArgs then etc+            else formattedTailArgs ++ space ++ etc++formatOptions :: [OptionDescription] -> String+formatOptions [] = ""+formatOptions (headOption:optionsTail) =+    let argSubstring = argumentSubstring headOption+        spacedArgSubstring = if null argSubstring then "" else space ++ argSubstring+        requiredOptionString = (optionFlag headOption) ++ spacedArgSubstring+        formattedOptionsTail = if null optionsTail then "" else space ++ (formatOptions optionsTail)+    in+        if isRequired headOption then+            requiredOptionString ++ formattedOptionsTail+        else+            "[" ++ requiredOptionString ++ "]" ++ formattedOptionsTail++argumentSubstring option =+    let minArgs = minArgumentCount option+    in+        if argumentCountIsFixed option then+            if minArgs == 0 then ""+            else intercalate space (take minArgs (cycle (argumentNames option)))+        else+            -- take care of the bounded case+            (intercalate space (take minArgs (cycle (argumentNames option)))) ++ space ++ etc++extractCommandLineArguments ::+    CommandLineDescription ->+    [String] ->+    (Map.Map OptionDescription [[String]], [String])+extractCommandLineArguments cmdLineDesc argValues =+    let unreservedArgCount = (length argValues) - (minTailArgumentCount cmdLineDesc)+        (unreservedArgs, reservedArgs) = splitAt unreservedArgCount argValues+        theOptions = options cmdLineDesc+        (optionMap, remainingArgs) = extractOptions theOptions unreservedArgs+        anyOptionsInReservedArgs =+            let (hopefullyEmptyMap, _) = extractOptions theOptions reservedArgs+            in not $ Map.null hopefullyEmptyMap+    in+        -- TODO this if else is really lame. we should replace all this+        --      along w/ error handling with status codes+        if anyOptionsInReservedArgs then+            (Map.empty, [])+        else+            (optionMap, remainingArgs ++ reservedArgs)++extractOptions ::+    [OptionDescription] ->+    [String] ->+    (Map.Map OptionDescription [[String]], [String])+extractOptions [] argValues = (Map.empty, argValues)+extractOptions _ [] = (Map.empty, [])+extractOptions optDescs argValues@(argHead:argTail) =+    case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of+        Nothing ->+            (Map.empty, argValues)+        Just optDesc ->+            let (optArgs, afterOptArgs) = extractOption optDesc optDescs argValues+                (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs+            in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs)++extractOption ::+    OptionDescription ->+    [OptionDescription] ->+    [String] ->+    ([String], [String])+extractOption optDesc allOptDescs (argHead:argTail) =+    let optArgExtent = argumentExtent optDesc allOptDescs argTail+    in splitAt optArgExtent argTail++argumentExtent :: OptionDescription -> [OptionDescription] -> [String] -> Int+argumentExtent optionDescription allOptDescs afterOptArgs =+    let allOptFlags = map optionFlag allOptDescs+        maybeNextArgIndex = findIndex (\arg -> any (== arg) allOptFlags) afterOptArgs+        minArgCount = minArgumentCount optionDescription+        isFixed = argumentCountIsFixed optionDescription+    in+        case maybeNextArgIndex of+            Nothing ->+                let afterOptLength = length afterOptArgs+                in+                    if afterOptLength < minArgCount then missingParameters+                    else if isFixed then minArgCount+                    else afterOptLength+            Just nextArgIndex ->+                if nextArgIndex < minArgCount then missingParameters+                else if isFixed then minArgCount+                else nextArgIndex+    where+        missingParameters =+            error $ "missing parameter(s) for " ++ (optionFlag optionDescription)++addOptionArgsToMap ::+    Map.Map OptionDescription [[String]] ->+    OptionDescription ->+    [String] ->+    Map.Map OptionDescription [[String]]+addOptionArgsToMap optArgMap opt args =+    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)+-}
+ Database/TxtSushi/Util/IOUtil.hs view
@@ -0,0 +1,35 @@+module Database.TxtSushi.Util.IOUtil (+    bufferStdioToTempFile,+    getContentsFromFileOrStdin,+    getAll) where++import System.Directory+import System.IO++bufferStdioToTempFile = do+    stdioText <- getContents+    tempDir <- getTemporaryDirectory+    (tempFilePath, tempFileHandle) <- openTempFile tempDir "stdiobuffer.txt"+    hPutStr tempFileHandle stdioText+    hClose tempFileHandle+    return tempFilePath++getContentsFromFileOrStdin filePath = do+    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)++-- | returns an infinite list of gets from a monad+keepGetting getAction = do+    headVal <- getAction+    tailVal <- keepGetting getAction+    return (headVal:tailVal)
+ Database/TxtSushi/Util/ListUtil.hs view
@@ -0,0 +1,27 @@+module Database.TxtSushi.Util.ListUtil (+    cascadingOrder,+    replaceAll) where++import Data.List++{-+replace all instances of 'targetSublist' found in 'list' with+'replacementList'+-}+replaceAll :: (Eq a) => [a] -> [a] -> [a] -> [a]+replaceAll [] _ _ = []+replaceAll list@(listHead:listTail) targetSublist replacementList =+    if targetSublist `isPrefixOf` list then+        let remainingList = drop (length targetSublist) list+        in  replacementList ++ (replaceAll remainingList targetSublist replacementList)+    else+        listHead:(replaceAll listTail targetSublist replacementList)++-- | applies a cascading order logic where 1st non-equal ordering defines+--   the ordering for the list. If they're all equal (or the list is empty)+--   then return EQ+cascadingOrder :: [Ordering] -> Ordering+cascadingOrder [] = EQ+cascadingOrder (LT:_) = LT+cascadingOrder (GT:_) = GT+cascadingOrder (EQ:tailOrders) = cascadingOrder tailOrders
Setup.hs view
@@ -4,7 +4,7 @@  import Text.ParserCombinators.Parsec -import TxtSushi.SQLParser+import Database.TxtSushi.SQLParser  main = defaultMainWithHooks $ simpleUserHooks {runTests = runTxtSushiTests} @@ -31,7 +31,8 @@                                     ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table2", columnId = "col1"}}]},                             maybeTableAlias = Nothing}),                     maybeWhereFilter = Nothing,-                    orderByItems = []}+                    orderByItems = [],+                    maybeGroupByHaving = Nothing}         stmt1_1Txt =             "select table1.col1, table2.* " ++             "from table1 inner join table2 on table1.col1 = table2.col1"@@ -64,7 +65,8 @@                                 FunctionExpression {                                     sqlFunction = SQLFunction {functionName = "LOWER", minArgCount = 1, argCountIsFixed = True},                                     functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}),-                    orderByItems = []}+                    orderByItems = [],+                    maybeGroupByHaving = Nothing}         stmt2_1Txt =             "select table1.col1, table2.* " ++             "from table1 join table2 on table1.col1 = table2.col1 " ++@@ -101,7 +103,8 @@                                     functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}),                     orderByItems = [OrderByItem {                         orderExpression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "firstName"}},-                        orderAscending = True}]}+                        orderAscending = True}],+                    maybeGroupByHaving = Nothing}         stmt3_1Txt =             "select table1.col1, table2.* " ++             "from table1 join table2 on table1.col1 = table2.col1 " ++@@ -142,7 +145,8 @@                                     functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}),                     orderByItems = [OrderByItem {                         orderExpression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "firstName"}},-                        orderAscending = False}]}+                        orderAscending = False}],+                    maybeGroupByHaving = Nothing}         stmt4_1Txt =             "select table1.col1, table2.* " ++             "from table1 join table2 on table1.col1 = table2.col1 " ++@@ -177,7 +181,7 @@  testSqlSelect :: SelectStatement -> String -> IO () testSqlSelect expectedResult selectStatementText = do-    let stmtParseResult = parse parseSelectStatement "" selectStatementText+    let stmtParseResult = parse (withTrailing eof parseSelectStatement) "" selectStatementText         colNums = take (length selectStatementText) ([1 .. 9] ++ cycle [0 .. 9])     putStrLn ""     putStrLn "Testing:"
− TxtSushi/IO.hs 
@@ -1,200 +0,0 @@-{- |-The 'FlatFile' module is for reading misc. 'FlatFile' formats like CSV or-tab delimited--}-module TxtSushi.IO (-    formatTableWithWidths,-    maxTableColumnWidths,-    formatTable,-    parseTable,-    Format(Format),-    csvFormat,-    tabDelimitedFormat,-    doubleQuote) where--import Data.List-import Util.ListUtil--{- |-'Format' allows you to specify different flat-file formats so that you-can use 'parseTable' for CSV, tab-delimited etc.--}-data Format = Format {-    quote :: String,-    fieldDelimiter :: String,-    rowDelimiter :: String} deriving (Show)--csvFormat = Format "\"" "," "\n"-tabDelimitedFormat = Format "\"" "\t" "\n"--{- |-get a quote escape sequence for the given 'Format'--}-doubleQuote :: Format -> String-doubleQuote format = (quote format) ++ (quote format)--formatTableWithWidths _ _ [] = []-formatTableWithWidths boundaryString widths (row:tableTail) =-    let-        (initCells, [lastCell]) = splitAt (length row - 1) row-    in-        (concat $ zipWith ensureWidth widths initCells) ++ lastCell ++-        "\n" ++ (formatTableWithWidths boundaryString widths tableTail)-    where-        ensureWidth width field =-            let lengthField = length field-            in-                if width > lengthField then-                    field ++ (replicate (width - lengthField) ' ') ++ boundaryString-                else-                    field ++ boundaryString--{- |-for a table, calculate the max width in characters for each column--}-maxTableColumnWidths :: [[String]] -> [Int]-maxTableColumnWidths [] = []-maxTableColumnWidths table =-    maxTableColumnWidthsInternal table []--maxTableColumnWidthsInternal :: [[String]] -> [Int] -> [Int]-maxTableColumnWidthsInternal [] prevMaxValues = prevMaxValues-maxTableColumnWidthsInternal (row:tableTail) prevMaxValues-    | seqList prevMaxValues = undefined-    | otherwise = maxTableColumnWidthsInternal tableTail (maxRowFieldWidths row prevMaxValues)---- this filthy little function is for making the list strict... otherwise--- we run out of memory-seqList [] = False-seqList (head:tail)-    | head `seq` False = undefined-    | otherwise = seqList tail--maxRowFieldWidths :: [String] -> [Int] -> [Int]-maxRowFieldWidths row prevMaxValues =-    zipWithD max (map length row) prevMaxValues--zipWithD :: (a -> a -> a) -> [a] -> [a] -> [a]-zipWithD f (x:xt) (y:yt) = (f x y):(zipWithD f xt yt)-zipWithD _ [] ys = ys-zipWithD _ xs [] = xs--{- |-Format the given table (the 2D String array) into a flat-file string using-the given 'Format'--}-formatTable :: Format -> [[String]] -> String-formatTable _ [] = ""-formatTable format (headRow:tableTail) =-    (formatRow format headRow) ++ (rowDelimiter format) ++ (formatTable format tableTail)--{- |-Format the row into a flat file sub-string using the given 'Format'--}-formatRow :: Format -> [String] -> String-formatRow _ [] = []-formatRow format (headField:rowTail) =-    -- we need to escape any quotes-    let escapedField = encodeField format headField-    in-        -- use a field delimiter on all but the last field-        if null rowTail then-            escapedField-        else-            escapedField ++ (fieldDelimiter format) ++ (formatRow format rowTail)--{- |-encode the given text field if it contains any special formatting characters--}-encodeField format field =-    if (quote format) `isInfixOf` field then-        let escapedField = replaceAll field (quote format) (doubleQuote format)-        in  (quote format) ++ escapedField ++ (quote format)-    else if (rowDelimiter format) `isInfixOf` field ||-            (fieldDelimiter format) `isInfixOf` field then-        (quote format) ++ field ++ (quote format)-    else-        field--{- |-Parse the given text using the given flat file 'Format'. The result-is a list of list of strings. The strings are fields and the string-lists are rows--}-parseTable :: Format -> String -> [[String]]-parseTable _ [] = []-parseTable format text =-    let (nextLine, remainingText) = parseLine format text-    in  nextLine:(parseTable  format remainingText)---- parse a row giving (rowFields, remainingText)-parseLine :: Format -> String -> ([String], String)-parseLine _ [] = ([], "")-parseLine format text =-    let (nextField, moreFieldsInRow, textRemainingAfterField) = parseField format text-    in-        -- if there are more fields, recursively add them to the row-        if moreFieldsInRow then-            let (rowTail, remainingText) = parseLine format textRemainingAfterField-            in  (nextField:rowTail, remainingText)-        -        -- if there are no more fields return the current fields as a singleton-        -- list-        else-            ([nextField], textRemainingAfterField)---- parse a field giving (field, moreFieldsInRow, remainingText)-parseField :: Format -> String -> (String, Bool, String)-parseField _ [] = ("", False, "")-parseField format text =-    -- check if this field is quoted or not-    if (quote format) `isPrefixOf` text then-        let tailOfQuote = drop (length (quote format)) text-        in  parseQuotedField format tailOfQuote-    else-        parseUnquotedField format text---- parse a quoted field giving (field, moreFieldsInRow, remainingText)-parseQuotedField :: Format -> String -> (String, Bool, String)-parseQuotedField _ [] = ("", False, "")-parseQuotedField format text@(textHead:textTail) =-    -- a double quote is an escaped quote, so add a quote to the field-    if (doubleQuote format) `isPrefixOf` text then-        let tailOfDoubleQuote = drop (length (doubleQuote format)) text-            (fieldTail, moreFieldsInRow, remainingText) = parseQuotedField format tailOfDoubleQuote-        in  ((quote format) ++ fieldTail, moreFieldsInRow, remainingText)-    -    -- a single quote is the end of the field, we can use parseUnquotedField to-    -- chew up any chars between the ending quote and the next delimiter (there-    -- really shouldn't be any if the text is formatted well, but you never-    -- know)-    else if (quote format) `isPrefixOf` text then-        let tailOfQuote = drop (length (quote format)) text-            (_, moreFieldsInRow, remainingText) = parseUnquotedField format tailOfQuote-        in  ("", moreFieldsInRow, remainingText)-    -    -- just another character... toss it in the field and keep going-    else-        let (fieldTail, moreFieldsInRow, remainingText) = parseQuotedField format textTail-        in  (textHead:fieldTail, moreFieldsInRow, remainingText)---- parse an unquoted field giving (field, moreFieldsInRow, remainingText)-parseUnquotedField :: Format -> String -> (String, Bool, String)-parseUnquotedField _ [] = ("", False, "")-parseUnquotedField format text@(textHead:textTail) =-    -- if we hit a field delimiter: return an empty string and let caller know-    -- there are more fields in this row-    if (fieldDelimiter format) `isPrefixOf` text then-        let tailOfDelimiter = drop (length (fieldDelimiter format)) text-        in  ([], True, tailOfDelimiter)-    -    -- if we hit a row delimiter: return an empty string and let caller know there-    -- are no more fields in this row-    else if (rowDelimiter format) `isPrefixOf` text then-        let tailOfDelimiter = drop (length (rowDelimiter format)) text-        in  ([], False, tailOfDelimiter)-    -    -- just another character... toss it in the field and keep going-    else-        let (fieldTail, moreFieldsInRow, remainingText) = parseUnquotedField format textTail-        in  (textHead:fieldTail, moreFieldsInRow, remainingText)
− TxtSushi/SQLExecution.hs 
@@ -1,438 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  TxtSushi.SQLExecution--- Copyright   :  (c) Keith Sheppard 2009--- License     :  GPL3 or greater--- Maintainer  :  keithshep@gmail.com--- Stability   :  experimental--- Portability :  portable------ Module for executing a SQL statement-----------------------------------------------------------------------------------module TxtSushi.SQLExecution (-    select,-    databaseTableToTextTable,-    textTableToDatabaseTable) where--import Data.Char-import Data.List-import qualified Data.Map as Map-import Text.Regex.Posix--import TxtSushi.SQLParser-import TxtSushi.Transform-import Util.ListUtil---- | an SQL table data structure---   TODO: need allColumnsColumnIdentifiers and allColumnsTableRows so that---         we can filter and order on columns that are selected out. we also---         should track any column ordering that is in place-data DatabaseTable = DatabaseTable {-    -- | the columns in this table-    columnIdentifiers :: [ColumnIdentifier],-    -    -- | the actual table data-    tableRows :: [[EvaluatedExpression]]}--emptyTable = DatabaseTable [] []--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")}--intExpression int = EvaluatedExpression {-    preferredType   = IntType,-    maybeIntValue   = Just int,-    maybeRealValue  = Just $ fromIntegral int,-    stringValue     = show int,-    maybeBoolValue  = Just $ int /= 0}--realExpression real = EvaluatedExpression {-    preferredType   = RealType,-    maybeIntValue   = Just $ floor real,-    maybeRealValue  = Just real,-    stringValue     = show real,-    maybeBoolValue  = Just $ real /= 0.0}--boolExpression bool = EvaluatedExpression {-    preferredType   = BoolType,-    maybeIntValue   = Nothing,-    maybeRealValue  = Nothing,-    stringValue     = show bool,-    maybeBoolValue  = Just bool}--intValue :: EvaluatedExpression -> Int-intValue evalExpr = case maybeIntValue evalExpr of-    Just int -> int-    Nothing ->-        error $ "could not convert \"" ++ (stringValue evalExpr) ++-                "\" to an integer value"--realValue :: EvaluatedExpression -> Double-realValue evalExpr = case maybeRealValue evalExpr of-    Just real -> real-    Nothing ->-        error $ "could not convert \"" ++ (stringValue 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-    "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--boolCompare (EvaluatedExpression _ _ _ _ (Just b1)) (EvaluatedExpression _ _ _ _ (Just b2)) =-    compare b1 b2-boolCompare expr1 expr2 = stringCompare expr1 expr2--stringCompare expr1 expr2 = stringValue expr1 `compare` stringValue expr2---- 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)-    where-        makeColId colName = ColumnIdentifier (Just tableName) colName--databaseTableToTextTable :: DatabaseTable -> [[String]]-databaseTableToTextTable dbTable =-    let-        headerRow = (map columnId (columnIdentifiers dbTable))-        tailRows = map (map stringValue) (tableRows dbTable)-    in-        headerRow:tailRows---- | perform a SQL select with the given select statement on the---   given table map-select :: SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable-select selectStatement 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-        orderedTbl = orderRowsBy (orderByItems selectStatement) filteredTbl-        selectedTbl =-            evaluateColumnSelections (columnSelections selectStatement) orderedTbl-    in-        selectedTbl---- | sorts table rows by the given order by items-orderRowsBy :: [OrderByItem] -> DatabaseTable -> DatabaseTable-orderRowsBy [] dbTable = dbTable-orderRowsBy orderBys dbTable =-    let-        -- curry in the order and col ID params to make a row comparison function-        compareFunc = compareRowsOnOrderItems orderBys (columnIdentifiers dbTable)-    in-        dbTable {tableRows = sortBy compareFunc (tableRows dbTable)}---- | Compares two rows using the given OrderByItem and column ID's-compareRowsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering-compareRowsOnOrderItems orderBys colIds row1 row2 =-    cascadingOrder $ toOrderList orderBys-    where-        toOrderList [] = []-        toOrderList (orderBy:orderByTail) =-            (compareRowsOnOrderItem orderBy colIds row1 row2):(toOrderList orderByTail)---- | Compares two rows using the given OrderByItem and column ID's-compareRowsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering-compareRowsOnOrderItem orderBy colIds row1 row2 =-    let-        orderExpr = orderExpression orderBy-        row1Eval = evalExpression orderExpr colIds row1-        row2Eval = evalExpression orderExpr colIds row2-        rowComp = row1Eval `compare` row2Eval-    in-        if orderAscending orderBy then-            rowComp-        else-            reverseOrdering rowComp---- | reverses the given ordering. pretty CRAZY huh???-reverseOrdering :: Ordering -> Ordering-reverseOrdering EQ = EQ-reverseOrdering LT = GT-reverseOrdering GT = LT---- | 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 =-    case tblExpr of-        TableIdentifier tblName maybeTblAlias ->-            let-                -- find the from table map (error if missing)-                noTblError = error $ "failed to find table named " ++ tblName-                table = Map.findWithDefault noTblError tblName tableMap-            in-                maybeRename maybeTblAlias table-        -        -- TODO inner join should allow joining on expressions too!!-        InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias ->-            let-                leftJoinTbl = evalTableExpression leftJoinTblExpr tableMap-                rightJoinTbl = evalTableExpression rightJoinTblExpr tableMap-                joinCols = extractJoinCols onConditionExpr-                joinIndices = joinColumnIndices leftJoinTbl rightJoinTbl joinCols-                joinedTbl = innerJoin joinIndices leftJoinTbl rightJoinTbl-            in-                maybeRename maybeTblAlias joinedTbl-        -        -- TODO implement me-        CrossJoin leftJoinTbl maybeTblAlias rightJoinTbl ->-            error "Sorry! CROSS JOIN is not yet implemented"-    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 (FunctionExpression sqlFunc [arg1, arg2]) =-    case sqlFunc of-        SQLFunction "AND" _ _   -> extractJoinCols arg1 ++ extractJoinCols arg2-        SQLFunction "=" _ _     -> extractJoinColPair arg1 arg2-        -        -- Only expecting "AND" or "="-        otherwise -> onPartFormattingError-    where-        extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)]-        -        -- Only expecting "AND" or "="-        extractJoinColPair _ _ = onPartFormattingError---- Only expecting "AND" or "="-extractJoinCols _ = onPartFormattingError--onPartFormattingError =-    error $ "The \"ON\" part of a join must only contain column equalities " ++-            "joined together by \"AND\" like: " ++-            "\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\""---- | perform an inner join using the given join indices on the given---   tables-innerJoin :: [(Int, Int)] -> DatabaseTable -> DatabaseTable -> DatabaseTable-innerJoin joinIndices leftJoinTbl rightJoinTbl = DatabaseTable {-    columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl),-    tableRows = joinTables joinIndices (tableRows leftJoinTbl) (tableRows rightJoinTbl)}---- | convert the column ID pairs into index pairs-joinColumnIndices :: DatabaseTable -> DatabaseTable -> [(ColumnIdentifier, ColumnIdentifier)] -> [(Int, Int)]-joinColumnIndices leftJoinTbl rightJoinTbl joinCols =-    let-        leftHeader = columnIdentifiers leftJoinTbl-        rightHeader = columnIdentifiers rightJoinTbl-    in-        map (idPairToIndexPair leftHeader rightHeader) joinCols---- | convert the column ID pair into an index pair-idPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> (Int, Int)-idPairToIndexPair leftColIds rightColIds joinColPair@(leftColId, rightColId) =-    let-        maybePairInOrder = maybeIdPairToIndexPair leftColIds rightColIds joinColPair-        maybePairSwapped = maybeIdPairToIndexPair leftColIds rightColIds (rightColId, leftColId)-    in-        case maybePairInOrder of-            Just thePairInOrder -> thePairInOrder-            Nothing ->-                case maybePairSwapped of-                    Just thePairSwapped -> thePairSwapped-                    Nothing -> error "failed to find given columns"--maybeIdPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> Maybe (Int, Int)-maybeIdPairToIndexPair leftColIds rightColIds (leftColId, rightColId) = do-    leftIndex <- findIndex (== leftColId) leftColIds-    rightIndex <- findIndex (== rightColId) rightColIds-    return (leftIndex, rightIndex)--evaluateColumnSelections :: [ColumnSelection] -> DatabaseTable -> DatabaseTable-evaluateColumnSelections colSelections dbTable =-    let-        selectionTbls = map ($ dbTable) (map evaluateColumnSelection colSelections)-    in-        foldl1' tableConcat selectionTbls--tableConcat :: DatabaseTable -> DatabaseTable -> DatabaseTable-tableConcat dbTable1 dbTable2 =-    let-        concatIds = (columnIdentifiers dbTable1) ++ (columnIdentifiers dbTable2)-        concatRows = zipWith (++) (tableRows dbTable1) (tableRows dbTable2)-    in-        DatabaseTable concatIds concatRows--evaluateColumnSelection :: ColumnSelection -> DatabaseTable -> DatabaseTable-evaluateColumnSelection AllColumns dbTable = dbTable-evaluateColumnSelection (AllColumnsFrom srcTblName) dbTable =-    let-        colIds = columnIdentifiers dbTable-        indices = findIndices matchesSrcTblName (map maybeTableName colIds)-        selectedColIds = selectIndices indices colIds-        selectedColRows = map (selectIndices indices) (tableRows dbTable)-    in-        DatabaseTable selectedColIds selectedColRows-    where-        matchesSrcTblName Nothing           = False-        matchesSrcTblName (Just tblName)    = tblName == srcTblName-        selectIndices indices xs = [xs !! i | i <- indices]-evaluateColumnSelection (ExpressionColumn expr) dbTable =-    let-        tblColIds = columnIdentifiers dbTable-        exprColId = expressionIdentifier expr-        evaluatedExprs = map (evalExpression expr tblColIds) (tableRows dbTable)-    in-        DatabaseTable [exprColId] (transpose [evaluatedExprs])---- | This is a little different that a strict equals compare in that it returns---   true if the query column has a Nothing table and the column name part---   matches the reference column's name. Also not that this makes it---   an asymetric comparison-columnMatches :: ColumnIdentifier -> ColumnIdentifier -> Bool-columnMatches (ColumnIdentifier Nothing queryColIdStr) referenceColumn =-    -- In this case we don't care about the table name so-    -- just check to make sure that the column names match up-    queryColIdStr == columnId referenceColumn--columnMatches queryColumn referenceColumn =-    -- table name is important here so match on the whole object-    queryColumn == referenceColumn---- | filters the database's table rows on the given expression-filterRowsBy :: Expression -> DatabaseTable -> DatabaseTable-filterRowsBy filterExpr table =-    table {tableRows = filter myBoolEvalExpr (tableRows table)}-    where myBoolEvalExpr row =-            boolValue $ evalExpression filterExpr (columnIdentifiers table) row--evalExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> EvaluatedExpression--- Here's the easy stuff. evaluate constants-evalExpression (StringConstantExpression string) _ _ = stringExpression string-evalExpression (IntegerConstantExpression int) _ _ = intExpression int-evalExpression (RealConstantExpression real) _ _ = realExpression real---- A little bit harder. evaluate a column expression-evalExpression (ColumnExpression col) columnIds tblRow =-    case findIndex (columnMatches col) columnIds of-        Just colIndex -> tblRow !! colIndex-        Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col)---- this is where the action is. evaluate a function-evalExpression (FunctionExpression sqlFun funArgs) columnIds tblRow-    -- 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 == substringFromToFunction =-        stringExpression $ take (intValue arg3) (drop (intValue arg2 - 1) (stringValue arg1))-    | sqlFun == substringFromFunction =-        stringExpression $ drop (intValue arg2 - 1) (stringValue arg1)-    | sqlFun == regexMatchFunction = boolExpression $ (stringValue arg1) =~ (stringValue arg2)-    -    -- negate-    | sqlFun == negateFunction =-        if length evaluatedArgs /= 1 then-            error "internal error: found a negate function with multiple args"-        else-            let evaldArg = head evaluatedArgs-            in-                if useRealAlgebra evaldArg then-                    realExpression $ negate (realValue evaldArg)-                else-                    intExpression $ negate (intValue evaldArg)-    -    -- algebraic-    | sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs-    | sqlFun == divideFunction = realExpression $ foldl1' (/) (map realValue evaluatedArgs)-    | 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)-    -    where-        arg1 = head evaluatedArgs-        arg2 = evaluatedArgs !! 1-        arg3 = evaluatedArgs !! 2-        subStringF start extent string = take extent (drop start string)-        evaluatedArgs = map evalArgExpr funArgs-        evalArgExpr expr = evalExpression expr columnIds tblRow-        algebraWithCoercion intFunc realFunc args =-            if any useRealAlgebra args then-                realExpression $ foldl1' realFunc (map realValue args)-            else-                intExpression $ foldl1' intFunc (map intValue args)-        -        useRealAlgebra expr =-            let-                prefType = preferredType expr-                maybeInt = maybeIntValue expr-            in-                prefType == RealType || maybeInt == Nothing---- | trims leading and trailing spaces-trimSpace :: String -> String-trimSpace = f . f-   where f = reverse . dropWhile isSpace
− TxtSushi/SQLParser.hs 
@@ -1,775 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  TxtSushi.SQLParser--- Copyright   :  (c) Keith Sheppard 2009--- License     :  GPL3 or greater--- Maintainer  :  keithshep@gmail.com--- Stability   :  experimental--- Portability :  portable------ Module for parsing SQL-----------------------------------------------------------------------------------module TxtSushi.SQLParser (-    allMaybeTableNames,-    parseSelectStatement,-    SelectStatement(..),-    TableExpression(..),-    ColumnIdentifier(..),-    prettyFormatColumn,-    ColumnSelection(..),-    expressionIdentifier,-    Expression(..),-    OrderByItem(..),-    prettyFormatWithArgs,-    SQLFunction(..),-    -    -- String SQL function-    concatenateFunction,-    upperFunction,-    lowerFunction,-    trimFunction,-    substringFromFunction,-    substringFromToFunction,-    -    -- Algebraic SQL functions-    multiplyFunction,-    divideFunction,-    plusFunction,-    minusFunction,-    negateFunction,-    -    -- Boolean SQL functions-    isFunction,-    isNotFunction,-    lessThanFunction,-    lessThanOrEqualToFunction,-    greaterThanFunction,-    greaterThanOrEqualToFunction,-    andFunction,-    orFunction,-    notFunction,-    regexMatchFunction,-    -    -- Etc...-    maybeReadInt,-    maybeReadReal) where--import Data.Char-import Data.List-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Expr-import Util.ListUtil------------------------------------------------------------------------------------- The data definition for select statements------------------------------------------------------------------------------------- | represents a select statement---   TODO this should be moved inside the TableExpression type-data SelectStatement = SelectStatement {-    columnSelections :: [ColumnSelection],-    maybeFromTable :: Maybe TableExpression,-    maybeWhereFilter :: Maybe Expression,-    orderByItems :: [OrderByItem]}-    deriving (Show, Ord, Eq)--data TableExpression =-    TableIdentifier {-        tableName :: String,-        maybeTableAlias :: Maybe String} |-    InnerJoin {-        leftJoinTable :: TableExpression,-        rightJoinTable :: TableExpression,-        onCondition :: Expression,-        maybeTableAlias :: Maybe String} |-    CrossJoin {-        leftJoinTable :: TableExpression,-        rightJoinTable :: TableExpression,-        maybeTableAlias :: Maybe String}-    deriving (Show, Ord, Eq)---- | convenience function for extracting all of the table names used by the---   given table expression-allMaybeTableNames :: (Maybe TableExpression) -> [String]-allMaybeTableNames Nothing = []-allMaybeTableNames (Just tblExp) = allTableNames tblExp--allTableNames (TableIdentifier tblName _) = [tblName]-allTableNames (InnerJoin lftTbl rtTbl _ _) =-    (allTableNames lftTbl) ++ (allTableNames rtTbl)-allTableNames (CrossJoin lftTbl rtTbl _) =-    (allTableNames lftTbl) ++ (allTableNames rtTbl)--data ColumnSelection =-    AllColumns |-    AllColumnsFrom {sourceTableName :: String} |-    ExpressionColumn {expression :: Expression}-    --QualifiedColumn {-    --    qualifiedColumnId :: ColumnIdentifier}-    deriving (Show, Ord, Eq)--data ColumnIdentifier =-    ColumnIdentifier {-        maybeTableName :: Maybe String,-        columnId :: String}-    deriving (Show, Ord, Eq)---- | I wanted to leave the default Show, but I also wanted a pretty print, so---   here it is!-prettyFormatColumn :: ColumnIdentifier -> String-prettyFormatColumn (ColumnIdentifier (Just tblName) colId) = tblName ++ "." ++ colId-prettyFormatColumn (ColumnIdentifier (Nothing) colId) = colId--data Expression =-    FunctionExpression {-        sqlFunction :: SQLFunction,-        functionArguments :: [Expression]} |-    ColumnExpression {-        column :: ColumnIdentifier} |-    StringConstantExpression {-        stringConstant :: String} |-    IntegerConstantExpression {-        intConstant :: Int} |-    RealConstantExpression {-        realConstant :: Double}-    deriving (Show, Ord, Eq)--expressionIdentifier :: Expression -> ColumnIdentifier-expressionIdentifier (FunctionExpression func args) =-    ColumnIdentifier Nothing ((prettyFormatWithArgs func) args)-expressionIdentifier (ColumnExpression col) = col-expressionIdentifier (StringConstantExpression str) =-    ColumnIdentifier Nothing ("\"" ++ str ++ "\"")-expressionIdentifier (IntegerConstantExpression int) =-    ColumnIdentifier Nothing (show int)-expressionIdentifier (RealConstantExpression real) =-    ColumnIdentifier Nothing (show real)--needsParens :: Expression -> Bool-needsParens (FunctionExpression _ _) = True-needsParens _ = False--toArgString :: Expression -> String-toArgString expr =-    let exprFmt = prettyFormatColumn $ expressionIdentifier expr-    in if needsParens expr then "(" ++ exprFmt ++ ")" else exprFmt--prettyFormatWithArgs :: SQLFunction -> [Expression] -> String-prettyFormatWithArgs sqlFunc funcArgs-    | sqlFunc `elem` normalSyntaxFunctions = prettyFormatNormalFunctionExpression sqlFunc funcArgs-    | or (map (sqlFunc `elem`) infixFunctions) = prettyFormatInfixFunctionExpression sqlFunc funcArgs-    | sqlFunc == negateFunction = "-" ++ toArgString (head funcArgs)-    | sqlFunc == substringFromToFunction ||-      sqlFunc == substringFromFunction ||-      sqlFunc == notFunction =-        prettyFormatNormalFunctionExpression sqlFunc funcArgs--prettyFormatInfixFunctionExpression :: SQLFunction -> [Expression] -> String-prettyFormatInfixFunctionExpression sqlFunc funcArgs =-    let-        arg1 = head funcArgs-        arg2 = funcArgs !! 1-    in-        toArgString arg1 ++ functionName sqlFunc ++ toArgString arg2--prettyFormatNormalFunctionExpression :: SQLFunction -> [Expression] -> String-prettyFormatNormalFunctionExpression sqlFunc funcArgs =-    let argString = intercalate ", " (map toArgString funcArgs)-    in functionName sqlFunc ++ "(" ++ argString ++ ")"--data SQLFunction = SQLFunction {-    functionName :: String,-    minArgCount :: Int,-    argCountIsFixed :: Bool}-    deriving (Show, Ord, Eq)--data OrderByItem = OrderByItem {-    orderExpression :: Expression,-    orderAscending :: Bool}-    deriving (Show, Ord, Eq)---- | Parses a SQL select statement-parseSelectStatement :: GenParser Char st SelectStatement-parseSelectStatement = do-    try $ upperOrLower "SELECT" >> spaces1-    parseSelectBody---- | Parses all of the stuff that comes after "SELECT "-parseSelectBody :: GenParser Char st SelectStatement-parseSelectBody = do-    columnVals <- parseColumnSelections-    -- TODO need a better error message for missing "ON" etc. in-    -- the from part, can do this by grabing "FROM" first-    maybeFrom <- maybeParseFromPart-    maybeWhere <- maybeParseWherePart-    orderBy <- parseOrderByPart-    -    spaces-    eof-    -    return SelectStatement {-        columnSelections    = columnVals,-        maybeFromTable      = maybeFrom,-        maybeWhereFilter    = maybeWhere,-        orderByItems        = orderBy}-    -    where-        maybeParseFromPart =-            ifParseThen (spaces1 >> upperOrLower "FROM" >> spaces1) parseTableExpression-        -        maybeParseWherePart =-            ifParseThen (spaces1 >> upperOrLower "WHERE" >> spaces1) parseExpression---- | Parses the "ORDER BY ..." part of a select statement returning the list---   of OrderByItem's that were parsed (this list will be empty if there is no---   "ORDER BY" parsed-parseOrderByPart :: GenParser Char st [OrderByItem]-parseOrderByPart =-    ifParseThenElse-        -- if we see an "ORDER BY"-        (spaces1 >> upperOrLower "ORDER" >> spaces1 >> upperOrLower "BY" >> spaces1)-        -        -- then parse the order expression-        (sepByAtLeast 1 parseOrderByItem parseCommaSeparator)-        -        -- else there is nothing to sort by-        (return [])-    -    where-        parseOrderByItem :: GenParser Char st OrderByItem-        parseOrderByItem = do-            orderExpr <- parseExpression-            isAscending <- ifParseThenElse-                -- if we parse "DESC"-                (try parseDescending)-                -                -- then return false, it isn't ascending-                (return False)-                -                -- else try to consume "ASC" but even if we don't it's still-                -- ascending so return true-                ((try parseAscending <|> return []) >> return True)-            -            return $ OrderByItem orderExpr isAscending-        -        parseAscending  = spaces1 >> ((try $ upperOrLower "ASCENDING") <|> upperOrLower "ASC")-        parseDescending = spaces1 >> ((try $ upperOrLower "DESCENDING") <|> upperOrLower "DESC")------------------------------------------------------------------------------------- Functions for parsing the column names specified after "SELECT"-----------------------------------------------------------------------------------parseColumnSelections =-    sepBy1 parseAnyColType (try parseCommaSeparator)-    where parseAnyColType = parseAllCols <|>-                            (try parseAllColsFromTbl) <|>-                            (try parseColExpression)--parseAllCols = string "*" >> return AllColumns--parseAllColsFromTbl = do-    tableVal <- parseIdentifier-    string ".*"-    -    return $ AllColumnsFrom tableVal--parseColExpression = parseExpression >>= \expr -> return $ ExpressionColumn expr--parseColumnId = do-    firstId <- parseIdentifier-    -    maybeFullyQual <- maybeParse $ char '.'-    case maybeFullyQual of-        -- No '.' means it's a partially qualified column-        Nothing -> return $ ColumnIdentifier Nothing firstId-        Just _ -> do-            secondId <- parseIdentifier-            return $ ColumnIdentifier (Just firstId) secondId------------------------------------------------------------------------------------- Functions for parsing the table part (after "FROM")-----------------------------------------------------------------------------------parseTableExpression = do-    nextTblChunk <- parseNextTblExpChunk-    -    let ifInnerJoinParse = ifParseThenElse-            -- if-            parseInnerJoinKeywords-            -- then-            (parseInnerJoinRemainder nextTblChunk)-            -- else-            (return nextTblChunk)-        -        ifCrossOrInnerJoinParse = ifParseThenElse-            -- if-            parseCrossJoinKeywords-            -- then-            (parseCrossJoinRemainder nextTblChunk)-            -- else-            ifInnerJoinParse-    -    ifCrossOrInnerJoinParse--parseNextTblExpChunk =-    parenthesize parseTableExpression <|>  parseTableIdentifier--parseCrossJoinKeywords = do-    spaces1-    upperOrLower "CROSS"-    spaces1-    upperOrLower "JOIN"-    spaces1--parseInnerJoinKeywords = do-    spaces1-    maybeParse $ upperOrLower "INNER" >> spaces1-    upperOrLower "JOIN"-    spaces1--parseInnerJoinRemainder leftTblExpr = do-    rightTblExpr <- parseTableExpression-    -    spaces1-    upperOrLower "ON"-    spaces1-    onPart <- parseExpression-    -    maybeAlias <- maybeParse $ spaces1 >> parseTableAlias-    -    return InnerJoin {-            leftJoinTable=leftTblExpr,-            rightJoinTable=rightTblExpr,-            onCondition=onPart,-            maybeTableAlias=maybeAlias}--parseCrossJoinRemainder leftTblExpr = do-    rightTblExpr <- parseTableExpression-    maybeAlias <- maybeParse $ spaces1 >> parseTableAlias-    -    return CrossJoin {-            leftJoinTable=leftTblExpr,-            rightJoinTable=rightTblExpr,-            maybeTableAlias=maybeAlias}--parseTableIdentifier = do-    theId <- parseIdentifier-    maybeAlias <- maybeParse $ spaces1 >> parseTableAlias-    return $ TableIdentifier theId maybeAlias--parseTableAlias = upperOrLower "AS" >> spaces1 >> parseIdentifier------------------------------------------------------------------------------------- Expression parsing: These can be after "SELECT", "WHERE" or "HAVING"-----------------------------------------------------------------------------------parseExpression :: GenParser Char st Expression-parseExpression =-    let opTable = map (map parseInfixOp) infixFunctions-    in buildExpressionParser opTable parseAnyNonInfixExpression--parseAnyNonInfixExpression :: GenParser Char st Expression-parseAnyNonInfixExpression =-    parenthesize parseExpression <|>-    parseStringConstant <|>-    try parseRealConstant <|>-    try parseIntConstant <|>-    parseAnyNormalFunction <|>-    parseNegateFunction <|>-    parseSubstringFunction <|>-    parseNotFunction <|>-    (parseColumnId >>= (\colId -> return $ ColumnExpression colId))--parseStringConstant :: GenParser Char st Expression-parseStringConstant =-    (quotedText True '"' <|> quotedText True '\'') >>=-    (\txt -> return $ StringConstantExpression txt)--parseIntConstant :: GenParser Char st Expression-parseIntConstant =-    parseInt >>= (\int -> return $ IntegerConstantExpression int)--parseInt :: GenParser Char st Int-parseInt = do-    digitTxt <- anyParseTxt-    return $ read digitTxt-    where-        anyParseTxt = signedParseTxt <|> unsignedParseTxt <?> "integer"-        unsignedParseTxt = many1 digit-        signedParseTxt = do-            char '-'-            unsignedDigitTxt <- unsignedParseTxt-            return ('-':unsignedDigitTxt)---- | returns an int if it can be read from the string-maybeReadInt :: String -> Maybe Int-maybeReadInt intStr =-    case parse (parseToEof parseInt) "" intStr of-        Left _      -> Nothing-        Right int   -> Just int---- | returns a real if it can be read from the string-maybeReadReal :: String -> Maybe Double-maybeReadReal realStr =-    case parse (parseToEof parseReal) "" realStr of-        Left _      -> maybeReadInt realStr >>= (\int -> Just $ fromIntegral int)-        Right real  -> Just real--parseToEof p = p >>= \x -> (eof >> return x)--parseRealConstant :: GenParser Char st Expression-parseRealConstant =-    parseReal >>= (\real -> return $ RealConstantExpression real)--parseReal :: GenParser Char st Double-parseReal = do-    realTxt <- anyParseTxt-    return $ read realTxt-    where-        anyParseTxt = signedParseTxt <|> unsignedParseTxt <?> "real"-        unsignedParseTxt = do-            intTxt <- many1 digit-            char '.'-            fracTxt <- many1 digit-            return $ intTxt ++ "." ++ fracTxt-        signedParseTxt = do-            char '-'-            unsignedDigitTxt <- unsignedParseTxt-            return ('-':unsignedDigitTxt)--parseAnyNormalFunction :: GenParser Char st Expression-parseAnyNormalFunction =-    let allParsers = map parseNormalFunction normalSyntaxFunctions-    in choice allParsers--parseNormalFunction sqlFunc = do-    try $ (upperOrLower $ functionName sqlFunc)-    spaces -- TODO careful here: what happens with upperVar? it breaks because of "upper" (maybe a blog entry!!)-    args <- parenthesize $ argSepBy (minArgCount sqlFunc) parseExpression parseCommaSeparator-    return $ FunctionExpression sqlFunc args-    where argSepBy = if argCountIsFixed sqlFunc then sepByExactly else sepByAtLeast---- Functions with "normal" syntax ---normalSyntaxFunctions = [upperFunction, lowerFunction, trimFunction]--upperFunction = SQLFunction {-    functionName    = "UPPER",-    minArgCount     = 1,-    argCountIsFixed = True}--lowerFunction = SQLFunction {-    functionName    = "LOWER",-    minArgCount     = 1,-    argCountIsFixed = True}--trimFunction = SQLFunction {-    functionName    = "TRIM",-    minArgCount     = 1,-    argCountIsFixed = True}---- Infix functions ---infixFunctions =-    [[multiplyFunction, divideFunction],-     [plusFunction, minusFunction],-     [concatenateFunction],-     [isFunction, isNotFunction, lessThanFunction, lessThanOrEqualToFunction,-      greaterThanFunction, greaterThanOrEqualToFunction, regexMatchFunction],-     [andFunction],-     [orFunction]]---- | 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 infixFunc =-    -- use the magic infix type, always assuming left associativity-    Infix opParser AssocLeft-    where-        opParser =-            if funcIsAlphaNum-            then do-                try (spaces1 >> (upperOrLower $ functionName infixFunc) >> spaces1)-                return $ buildExpr-            else do-                try (spaces >> (upperOrLower $ functionName infixFunc) >> notOpChar) >> spaces-                return $ buildExpr-        buildExpr leftSubExpr rightSubExpr =-            FunctionExpression {-                sqlFunction = infixFunc,-                functionArguments = [leftSubExpr, rightSubExpr]}-        funcIsAlphaNum = any isAlphaNum (functionName infixFunc)--notOpChar =-    notFollowedBy $ oneOf "*/+-=<>^|~"---- Algebraic-multiplyFunction = SQLFunction {-    functionName    = "*",-    minArgCount     = 2,-    argCountIsFixed = True}--divideFunction = SQLFunction {-    functionName    = "/",-    minArgCount     = 2,-    argCountIsFixed = True}--plusFunction = SQLFunction {-    functionName    = "+",-    minArgCount     = 2,-    argCountIsFixed = True}--minusFunction = SQLFunction {-    functionName    = "-",-    minArgCount     = 2,-    argCountIsFixed = True}---- Boolean-isFunction = SQLFunction {-    functionName    = "=",-    minArgCount     = 2,-    argCountIsFixed = True}--isNotFunction = SQLFunction {-    functionName    = "<>",-    minArgCount     = 2,-    argCountIsFixed = True}--lessThanFunction = SQLFunction {-    functionName    = "<",-    minArgCount     = 2,-    argCountIsFixed = True}--lessThanOrEqualToFunction = SQLFunction {-    functionName    = "<=",-    minArgCount     = 2,-    argCountIsFixed = True}--greaterThanFunction = SQLFunction {-    functionName    = ">",-    minArgCount     = 2,-    argCountIsFixed = True}--greaterThanOrEqualToFunction = SQLFunction {-    functionName    = ">=",-    minArgCount     = 2,-    argCountIsFixed = True}--andFunction = SQLFunction {-    functionName    = "AND",-    minArgCount     = 2,-    argCountIsFixed = True}--orFunction = SQLFunction {-    functionName    = "OR",-    minArgCount     = 2,-    argCountIsFixed = True}--concatenateFunction = SQLFunction {-    functionName    = "||",-    minArgCount     = 2,-    argCountIsFixed = True}--regexMatchFunction = SQLFunction {-    functionName    = "=~",-    minArgCount     = 2,-    argCountIsFixed = True}---- Functions with special syntax ---specialFunctions = [substringFromFunction,-                    substringFromToFunction,-                    negateFunction,-                    notFunction]---- | SUBSTRING(extraction_string FROM starting_position [FOR length]---             [COLLATE collation_name])---   TODO implement COLLATE part-substringFromFunction = SQLFunction {-    functionName    = "SUBSTRING",-    minArgCount     = 2,-    argCountIsFixed = True}-substringFromToFunction = SQLFunction {-    functionName    = "SUBSTRING",-    minArgCount     = 3,-    argCountIsFixed = True}--parseSubstringFunction :: GenParser Char st Expression-parseSubstringFunction = do-    try $ upperOrLower (functionName substringFromFunction) >> spaces >> char '('-    spaces-    strExpr <- parseExpression-    spaces1-    upperOrLower "FROM"-    spaces1-    startExpr <- parseExpression-    -- TODO doesn't need to be spaces. it can just be '('-    maybeLength <- maybeParse $ spaces1 >> upperOrLower "FOR" >> spaces1 >> parseExpression-    spaces-    char ')'-    -    return $ case maybeLength of-        Nothing     -> FunctionExpression substringFromFunction [strExpr, startExpr]-        Just len    -> FunctionExpression substringFromToFunction [strExpr, startExpr, len]--negateFunction = SQLFunction {-    functionName    = "-",-    minArgCount     = 1,-    argCountIsFixed = True}--parseNegateFunction :: GenParser Char st Expression-parseNegateFunction = do-    try $ char '-' >> notOpChar-    expr <- parseAnyNonInfixExpression-    return $ FunctionExpression negateFunction [expr]--notFunction = SQLFunction {-    functionName    = "NOT",-    minArgCount     = 1,-    argCountIsFixed = True}--parseNotFunction = do-    try $ upperOrLower (functionName notFunction) >>-          genNotFollowedBy (anyChar `exceptChar` (space <|> char '('))-    spaces-    expr <- parseAnyNonInfixExpression-    return $ FunctionExpression notFunction [expr]------------------------------------------------------------------------------------- Parse utility functions------------------------------------------------------------------------------------- | parses an identifier. you can use a tick '`' as a quote for---   an identifier with white-space-parseIdentifier = do-    let parseId = do-            let idChar = alphaNum <|> char '_'-            quotedText False '`' <|> many1 idChar-    (parseId `genExcept` parseReservedWord) <?> "identifier"---- | quoted text which allows escaping by doubling the quote char---   like "escaped quote char here:"""-quotedText allowEmpty quoteChar = do-    let quote = char quoteChar-        manyFunc = if allowEmpty then many else many1-    -    quote-    textValue <- manyFunc $ (anyChar `genExcept` quote) <|>-                            try (escapedQuote quoteChar)-    quote-    -    return textValue--exceptChar parser theException = notFollowedBy theException >> parser--escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar--parseCommaSeparator = spaces >> char ',' >> spaces---- | Wraps parentheses parsers around the given inner parser-parenthesize :: GenParser Char st a -> GenParser Char st a-parenthesize innerParser = do-    char '('-    spaces-    innerParseResults <- innerParser-    spaces-    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"---- | if the ifParse parser succeeds return the result of thenParse, else---   return Nothing without parsing any input-ifParseThen :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Maybe b)-ifParseThen ifParse thenPart = do-    ifResult <- maybeParse ifParse-    case ifResult of-        Just _ ->   thenPart >>= (\x -> return $ Just x)-        Nothing ->  return Nothing---- | if ifParse succeeds then parse thenPart otherwise parse elsePart-ifParseThenElse :: GenParser tok st a -> GenParser tok st b -> GenParser tok st b -> GenParser tok st b-ifParseThenElse ifParse thenPart elsePart = do-    ifResult <- maybeParse ifParse-    case ifResult of-        Just _ -> thenPart-        Nothing -> elsePart--parseReservedWord = do-    let reservedWordParsers = map reservedWordParser reservedWords-    choice reservedWordParsers-    where reservedWordParser word = do-            parseVal <- upperOrLower word-            notFollowedBy alphaNum-            return parseVal---- TODO are function names reserved... i don't think so-reservedWords =-    map functionName normalSyntaxFunctions ++-    map functionName (concat infixFunctions) ++-    map functionName specialFunctions ++-    ["BY","CROSS", "FROM", "FOR", "GROUP", "HAVING", "INNER", "JOIN", "ON", "ORDER", "SELECT", "WHERE"]---- | tries parsing both the upper and lower case versions of the given string-upperOrLower :: String -> GenParser Char st String-upperOrLower stringToParse =-    string (map toUpper stringToParse) <|>-    string (map toLower stringToParse) <?> stringToParse---- | accepst the same input as the given parser except and input that matches---   theException parser-genExcept :: (Show b) => GenParser tok st a -> GenParser tok st b -> GenParser tok st a-genExcept parser theException = do-    genNotFollowedBy theException-    parser---- | a generic version of the notFollowedBy library function. We require---   Show types so that we can better report failures-genNotFollowedBy :: (Show a) => GenParser tok st a -> GenParser tok st ()-genNotFollowedBy theParser = try $ do-    mayParseResult <- maybeParse theParser-    case mayParseResult of-        Nothing -> return ()-        Just x -> unexpected $ show x---- | 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---- | 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-    in parseEach itemParsers-    where-        -- for an empty parser list return an empty result-        parseEach [] = return []-        -        -- for a parser list of 1 we don't want to use a separator-        parseEach [lastParser] = lastParser >>= (\x -> return [x])-        -        -- for lists greater than 1 we do need to care about the separator-        parseEach (headParser:parserTail) = do-            resultHead <- headParser-            sepParser-            resultTail <- parseEach parserTail-            -            return $ resultHead:resultTail---- | parse `itemParser`s seperated by at least `minCount` `sepParser`s-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)
− TxtSushi/Transform.hs 
@@ -1,162 +0,0 @@-{- |-Simple table transformations--}-module TxtSushi.Transform (-    selectColumns,-    sortColumns,-    fileBasedSortTable,-    mergeAllBy,-    joinTables,-    joinPresortedTables,-    rowComparison) where--import Data.List-import System.Directory-import System.IO--import 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 columns table =-    sortBy (rowComparison columns) table---- | compare two rows based on given column balues-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---- | join together two tables on the given column index pairs-joinTables :: (Ord o) => [(Int, Int)] -> [[o]] -> [[o]] -> [[o]]-joinTables joinColumnZipList table1 table2 =-    let-        (joinColumns1, joinColumns2) = unzip joinColumnZipList-        sortedTable1 = sortColumns joinColumns1 table1-        sortedTable2 = sortColumns joinColumns2 table2-    in-        joinPresortedTables joinColumnZipList sortedTable1 sortedTable2---- | join together two tables that are presorted on the given column index pairs-joinPresortedTables :: (Ord o) => [(Int, Int)] -> [[o]] -> [[o]] -> [[o]]-joinPresortedTables joinColumnZipList sortedTable1 sortedTable2 =-    let-        (joinColumns1, joinColumns2) = unzip joinColumnZipList-        rowEq1 = (\a b -> (rowComparison joinColumns1 a b) == EQ)-        rowEq2 = (\a b -> (rowComparison joinColumns2 a b) == EQ)-        tableGroups1 = groupBy rowEq1 sortedTable1-        tableGroups2 = groupBy rowEq2 sortedTable2-    in-        joinGroupedTables joinColumnZipList tableGroups1 tableGroups2--permutePrependRows [] _ = []-permutePrependRows _ [] = []-permutePrependRows (table1HeadRow:table1Tail) table2 =-    let-        prependHead = (table1HeadRow ++)-        newTable2 = map prependHead table2-    in-        newTable2 ++ (permutePrependRows table1Tail table2)--joinGroupedTables _ [] _  = []-joinGroupedTables _ _  [] = []-joinGroupedTables joinColumnZipList tableGroups1@(headTableGroup1:tableGroupsTail1) tableGroups2@(headTableGroup2:tableGroupsTail2) =-    let-        headRow1 = head headTableGroup1-        headRow2 = head headTableGroup2-    in-        case asymmetricRowComparison joinColumnZipList headRow1 headRow2 of-            -- drop the 1st group if its smaller-            LT -> joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroups2-            -            -- drop the 2nd group if its smaller-            GT -> joinGroupedTables joinColumnZipList tableGroups1 tableGroupsTail2-            -            -- the two groups are equal so permute-            otherwise ->-                (permutePrependRows headTableGroup1 headTableGroup2) ++-                (joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroupsTail2)--asymmetricRowComparison [] _ _ = EQ-asymmetricRowComparison (columnsZipHead:columnsZipTail) row1 row2 =-    let-        (columnHead1, columnHead2) = columnsZipHead-        colComparison = (row1 !! columnHead1) `compare` (row2 !! columnHead2)-    in-        case colComparison of-            EQ          -> asymmetricRowComparison columnsZipTail row1 row2-            otherwise   -> colComparison-
− Util/CommandLineArgument.hs 
@@ -1,213 +0,0 @@-module Util.CommandLineArgument (-    extractCommandLineArguments,-    formatCommandLine,-    CommandLineDescription(CommandLineDescription),-    options,-    minTailArgumentCount,-    tailArgumentNames,-    tailArgumentCountIsFixed,-    OptionDescription(OptionDescription),-    isRequired,-    optionFlag,-    argumentNames,-    minArgumentCount,-    argumentCountIsFixed) where--import Data.List-import Data.Map (Map)-import qualified Data.Map as Map---import Test.HUnit--data CommandLineDescription = CommandLineDescription {-    options :: [OptionDescription],-    -    minTailArgumentCount :: Int,-    -    tailArgumentNames :: [String],-    -    tailArgumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)---- | a data structure for describing command line arguments-data OptionDescription = OptionDescription {-    -    -- | determines if this is a required option or not-    isRequired :: Bool,-    -    {- |-    What flag should we use. Eg: "-pretty-output"-    -}-    optionFlag :: String,-    -    {- |-    The name(s) to use for the argument(s).-    -}-    argumentNames :: [String],-    -    {- |-    the minimum number of args allowed-    -}-    minArgumentCount :: Int,-    -    {- |-    if true then 'minArgumentCount' is the upper threshold-    -}-    argumentCountIsFixed :: Bool} deriving (Show, Eq, Ord)--space = " ";-etc = "...";--formatCommandLine commandLine =-    let formattedOptions = formatOptions (options commandLine)-        formattedTailArgs = formatTailArguments commandLine-    in-        if null formattedOptions || null formattedTailArgs then-            formattedOptions ++ formattedTailArgs-        else-            formattedOptions ++ space ++ formattedTailArgs--formatTailArguments commandLine =-    let tailArgs = tailArgumentNames commandLine-        minTailArgs = minTailArgumentCount commandLine-        formattedTailArgs = intercalate space (take minTailArgs (cycle tailArgs))-    in-        if tailArgumentCountIsFixed commandLine then-            formattedTailArgs-         else-            if null formattedTailArgs then etc-            else formattedTailArgs ++ space ++ etc--formatOptions :: [OptionDescription] -> String-formatOptions [] = ""-formatOptions (headOption:optionsTail) =-    let argSubstring = argumentSubstring headOption-        spacedArgSubstring = if null argSubstring then "" else space ++ argSubstring-        requiredOptionString = (optionFlag headOption) ++ spacedArgSubstring-        formattedOptionsTail = if null optionsTail then "" else space ++ (formatOptions optionsTail)-    in-        if isRequired headOption then-            requiredOptionString ++ formattedOptionsTail-        else-            "[" ++ requiredOptionString ++ "]" ++ formattedOptionsTail--argumentSubstring option =-    let minArgs = minArgumentCount option-    in-        if argumentCountIsFixed option then-            if minArgs == 0 then ""-            else intercalate space (take minArgs (cycle (argumentNames option)))-        else-            -- take care of the bounded case-            (intercalate space (take minArgs (cycle (argumentNames option)))) ++ space ++ etc--extractCommandLineArguments ::-    CommandLineDescription ->-    [String] ->-    (Map.Map OptionDescription [[String]], [String])-extractCommandLineArguments cmdLineDesc argValues =-    let unreservedArgCount = (length argValues) - (minTailArgumentCount cmdLineDesc)-        (unreservedArgs, reservedArgs) = splitAt unreservedArgCount argValues-        theOptions = options cmdLineDesc-        (optionMap, remainingArgs) = extractOptions theOptions unreservedArgs-        anyOptionsInReservedArgs =-            let (hopefullyEmptyMap, _) = extractOptions theOptions reservedArgs-            in not $ Map.null hopefullyEmptyMap-    in-        -- TODO this if else is really lame. we should replace all this-        --      along w/ error handling with status codes-        if anyOptionsInReservedArgs then-            (Map.empty, [])-        else-            (optionMap, remainingArgs ++ reservedArgs)--extractOptions ::-    [OptionDescription] ->-    [String] ->-    (Map.Map OptionDescription [[String]], [String])-extractOptions [] argValues = (Map.empty, argValues)-extractOptions _ [] = (Map.empty, [])-extractOptions optDescs argValues@(argHead:argTail) =-    case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of-        Nothing ->-            (Map.empty, argValues)-        Just optDesc ->-            let (optArgs, afterOptArgs) = extractOption optDesc optDescs argValues-                (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs-            in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs)--extractOption ::-    OptionDescription ->-    [OptionDescription] ->-    [String] ->-    ([String], [String])-extractOption optDesc allOptDescs (argHead:argTail) =-    let optArgExtent = argumentExtent optDesc allOptDescs argTail-    in splitAt optArgExtent argTail--argumentExtent :: OptionDescription -> [OptionDescription] -> [String] -> Int-argumentExtent optionDescription allOptDescs afterOptArgs =-    let allOptFlags = map optionFlag allOptDescs-        maybeNextArgIndex = findIndex (\arg -> any (== arg) allOptFlags) afterOptArgs-        minArgCount = minArgumentCount optionDescription-        isFixed = argumentCountIsFixed optionDescription-    in-        case maybeNextArgIndex of-            Nothing ->-                let afterOptLength = length afterOptArgs-                in-                    if afterOptLength < minArgCount then missingParameters-                    else if isFixed then minArgCount-                    else afterOptLength-            Just nextArgIndex ->-                if nextArgIndex < minArgCount then missingParameters-                else if isFixed then minArgCount-                else nextArgIndex-    where-        missingParameters =-            error $ "missing parameter(s) for " ++ (optionFlag optionDescription)--addOptionArgsToMap ::-    Map.Map OptionDescription [[String]] ->-    OptionDescription ->-    [String] ->-    Map.Map OptionDescription [[String]]-addOptionArgsToMap optArgMap opt args =-    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)--}
− Util/IOUtil.hs 
@@ -1,35 +0,0 @@-module Util.IOUtil (-    bufferStdioToTempFile,-    getContentsFromFileOrStdin,-    getAll) where--import System.Directory-import System.IO--bufferStdioToTempFile = do-    stdioText <- getContents-    tempDir <- getTemporaryDirectory-    (tempFilePath, tempFileHandle) <- openTempFile tempDir "stdiobuffer.txt"-    hPutStr tempFileHandle stdioText-    hClose tempFileHandle-    return tempFilePath--getContentsFromFileOrStdin filePath = do-    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)---- | returns an infinite list of gets from a monad-keepGetting getAction = do-    headVal <- getAction-    tailVal <- keepGetting getAction-    return (headVal:tailVal)
− Util/ListUtil.hs 
@@ -1,27 +0,0 @@-module Util.ListUtil (-    cascadingOrder,-    replaceAll) where--import Data.List--{--replace all instances of 'targetSublist' found in 'list' with-'replacementList'--}-replaceAll :: (Eq a) => [a] -> [a] -> [a] -> [a]-replaceAll [] _ _ = []-replaceAll list@(listHead:listTail) targetSublist replacementList =-    if targetSublist `isPrefixOf` list then-        let remainingList = drop (length targetSublist) list-        in  replacementList ++ (replaceAll remainingList targetSublist replacementList)-    else-        listHead:(replaceAll listTail targetSublist replacementList)---- | applies a cascading order logic where 1st non-equal ordering defines---   the ordering for the list. If they're all equal (or the list is empty)---   then return EQ-cascadingOrder :: [Ordering] -> Ordering-cascadingOrder [] = EQ-cascadingOrder (LT:_) = LT-cascadingOrder (GT:_) = GT-cascadingOrder (EQ:tailOrders) = cascadingOrder tailOrders
− _darcs/format 
@@ -1,2 +0,0 @@-hashed-darcs-2
− _darcs/hashed_inventory 
@@ -1,8 +0,0 @@-pristine:0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f07800936c5acb260-Starting with inventory:-0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e19f69207-[TAG release 0.2-keithshep@gmail.com**20090521033210- Ignore-this: b0ed58fccf2f95a610521713d9c1a499-] -hash: 0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d094046526
− _darcs/inventories/0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e

binary file changed (686 → absent bytes)

− _darcs/inventories/0000006394-dd21a7fa69cce91d38242dda31118e5085023e7aecfddff8f8da0cac

binary file changed (2957 → absent bytes)

− _darcs/patches/0000000191-2c40a8181d0d6b42236bb2abe2767fc51ffa6d2188cf0021d18edd89ab9d

binary file changed (155 → absent bytes)

− _darcs/patches/0000000191-69a041fd53c8f7e5b11f835e60b49daed29b88b43b0883d94275efaa2c69

binary file changed (161 → absent bytes)

− _darcs/patches/0000000201-d27210175d1d081a056238cd9769a42c7ff50dede48181fa8f1b903bc379

binary file changed (184 → absent bytes)

− _darcs/patches/0000000274-fb6ae1f888a0ae95c79a8c88327e34b133890b754cef6ab3a1c9f87f6795

binary file changed (225 → absent bytes)

− _darcs/patches/0000000378-118496eba00c44a2334983e28a06cfaed256bd373079edef16ec469d3e36

binary file changed (242 → absent bytes)

− _darcs/patches/0000000454-837c722676d15daf644fe71a0071838789d7b496db348af85374cad4650e

binary file changed (274 → absent bytes)

− _darcs/patches/0000000474-3e80349a7a5f8eaabc8813f1144636e87e9b781f5b4013942a6cdc2046db

binary file changed (219 → absent bytes)

− _darcs/patches/0000000504-d7bfdb8aa7370ef5916acda9945f1ad0a2f00320a5f04072ea57058e68ce

binary file changed (312 → absent bytes)

− _darcs/patches/0000000505-7003ad42b1c6a26ab34ed80b54cfa6fab8f2c81bda2dbcccb6725525ac2d

binary file changed (233 → absent bytes)

− _darcs/patches/0000000609-f1b0b1a03c3d8421d17dc15a39609949c9e5960e3f7b6ceb8f7292053975

binary file changed (418 → absent bytes)

− _darcs/patches/0000000628-16a1c0e32bda87c79248cd7435ce6da9f7a0ce7de475ef25132a7423d79c

binary file changed (364 → absent bytes)

− _darcs/patches/0000000757-19220ad0f4ad47d4e83a893e999066eccf7579e1b9527b1606806cd4e48e

binary file changed (459 → absent bytes)

− _darcs/patches/0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d09404

binary file changed (387 → absent bytes)

− _darcs/patches/0000000983-b4088fe2ce96d588b9a854e5e200c66e66b107bab5ef3dd0c1b06e52817e

binary file changed (359 → absent bytes)

− _darcs/patches/0000001149-31511fe20855eacbdbd6a435e1d33e136f5a811802e793e3316dff1b9a41

binary file changed (685 → absent bytes)

− _darcs/patches/0000001733-08c8318da1c4bc1e961bb9eba067af69d50dfaebc73818cf327054466c0a

binary file changed (654 → absent bytes)

− _darcs/patches/0000001787-e542485f9074ec93d1fa924c68d8bad1d597af6c0fd6bf4a333f6e5ed702

binary file changed (527 → absent bytes)

− _darcs/patches/0000001970-2037710eb055cda2b6fd3c21e3ff1388bfbad784523153362591a3067741

binary file changed (579 → absent bytes)

− _darcs/patches/0000002001-1c05b971133432912d672cab5b5b7a742b3cf7971b6ae8116c6b67b3a13f

binary file changed (699 → absent bytes)

− _darcs/patches/0000002026-882079cdc55867c7febe504e9a79e5232b0ed543139844442cbf937734bb

binary file changed (507 → absent bytes)

− _darcs/patches/0000002333-48fdb810a3d1f4e24e501e30113fc0ce3faed45db34a0a0d01d985dbdbe8

binary file changed (1225 → absent bytes)

− _darcs/patches/0000002339-7a3bb3fc3e515f5cd742bb3ab1e575a149fbd01a477ab5630f99112635e5

binary file changed (715 → absent bytes)

− _darcs/patches/0000002642-864c4d8b2d200fe4b4dc9c36a4bfcd72642cb975ac81634a8ddc8d0d7d10

binary file changed (901 → absent bytes)

− _darcs/patches/0000002674-0dfb35863da7e573bf060c4fdb93a6f352005a256afea55ecfc69f812a59

binary file changed (681 → absent bytes)

− _darcs/patches/0000002734-114e244d4026f048f8328ff09f306774b285630374b19867f259253fdc67

binary file changed (980 → absent bytes)

− _darcs/patches/0000003029-267c6668ee3b23a1873b81bf13bf94ad4357cfc056c31412f2eec8ad0025

binary file changed (1047 → absent bytes)

− _darcs/patches/0000003945-20edbc0e6ba404e934b2e40c37cf2199d3eb19811bceb5c6e5e1a54dd7d7

binary file changed (1079 → absent bytes)

− _darcs/patches/0000003958-40c17a6c5e486cb4fd2fc0381898ef942a799ee662d7066466090cba7eb0

binary file changed (1616 → absent bytes)

− _darcs/patches/0000004103-1efcde4b404484b6d87566c4a32d6a0eae29af6dbe1b5576a833b35909b7

binary file changed (1126 → absent bytes)

− _darcs/patches/0000004761-5308225b40ae211903a8f2f822b3b42bed9f89393ea40e53b18e97ae0358

binary file changed (949 → absent bytes)

− _darcs/patches/0000005281-3dc871668663e6efe214646a8bd241142807c859729b591f8d1c082fbb88

binary file changed (1277 → absent bytes)

− _darcs/patches/0000006021-64a3588aba279ddb985f7b324489c7964545079137eeebfdbbbc9ec57039

binary file changed (1538 → absent bytes)

− _darcs/patches/0000006540-e909d3a393f7f1bde11301fe78f45c9ca0f9d8dbc819cef0ef9b0ff87961

binary file changed (1567 → absent bytes)

− _darcs/patches/0000007338-d61110b41ba3dba61ede97ee514dbeea0170d6bf68685f1aefb20d3edbaf

binary file changed (1998 → absent bytes)

− _darcs/patches/0000007357-6f774098abed7937b6ceff17f852d2fc9103fd67f563c8eaeeffffaa5236

binary file changed (2268 → absent bytes)

− _darcs/patches/0000018238-8b063fa0fab2a4a3aa27fe91a2ef6bc5d72b88ba0aac7e41f94b115806c8

binary file changed (3817 → absent bytes)

− _darcs/patches/0000036783-1d29937d76c9599242f1c2d9ce139111ef108d4635119e4d74a686950f6d

binary file changed (12773 → absent bytes)

− _darcs/patches/0000070374-475515c8f051c8c3f01a02e1bd957749267881da8f7a853a7b9be4efac61

binary file changed (16259 → absent bytes)

− _darcs/patches/pending.tentative 
@@ -1,2 +0,0 @@-{-}
− _darcs/prefs/binaries 
@@ -1,59 +0,0 @@-# Binary file regexps:-\.png$-\.PNG$-\.gz$-\.GZ$-\.pdf$-\.PDF$-\.jpg$-\.JPG$-\.jpeg$-\.JPEG$-\.gif$-\.GIF$-\.tif$-\.TIF$-\.tiff$-\.TIFF$-\.pnm$-\.PNM$-\.pbm$-\.PBM$-\.pgm$-\.PGM$-\.ppm$-\.PPM$-\.bmp$-\.BMP$-\.mng$-\.MNG$-\.tar$-\.TAR$-\.bz2$-\.BZ2$-\.z$-\.Z$-\.zip$-\.ZIP$-\.jar$-\.JAR$-\.so$-\.SO$-\.a$-\.A$-\.tgz$-\.TGZ$-\.mpg$-\.MPG$-\.mpeg$-\.MPEG$-\.iso$-\.ISO$-\.exe$-\.EXE$-\.doc$-\.DOC$-\.elc$-\.ELC$-\.pyc$-\.PYC$
− _darcs/prefs/boring 
@@ -1,113 +0,0 @@-# Boring file regexps:--### compiler and interpreter intermediate files-# haskell (ghc) interfaces-\.hi$-\.hi-boot$-\.o-boot$-# object files-\.o$-\.o\.cmd$-# profiling haskell-\.p_hi$-\.p_o$-# haskell program coverage resp. profiling info-\.tix$-\.prof$-# fortran module files-\.mod$-# linux kernel-\.ko\.cmd$-\.mod\.c$-(^|/)\.tmp_versions($|/)-# *.ko files aren't boring by default because they might-# be Korean translations rather than kernel modules-# \.ko$-# python, emacs, java byte code-\.py[co]$-\.elc$-\.class$-# objects and libraries; lo and la are libtool things-\.(obj|a|exe|so|lo|la)$-# compiled zsh configuration files-\.zwc$-# Common LISP output files for CLISP and CMUCL-\.(fas|fasl|sparcf|x86f)$--### build and packaging systems-# cabal intermediates-\.installed-pkg-config-\.setup-config-# standard cabal build dir, might not be boring for everybody-# ^dist(/|$)-# autotools-(^|/)autom4te\.cache($|/)-(^|/)config\.(log|status)$-# microsoft web expression, visual studio metadata directories-\_vti_cnf$-\_vti_pvt$-# gentoo tools-\.revdep-rebuild.*-# generated dependencies-^\.depend$--### version control systems-# cvs-(^|/)CVS($|/)-\.cvsignore$-# cvs, emacs locks-^\.#-# rcs-(^|/)RCS($|/)-,v$-# subversion-(^|/)\.svn($|/)-# mercurial-(^|/)\.hg($|/)-# git-(^|/)\.git($|/)-# bzr-\.bzr$-# sccs-(^|/)SCCS($|/)-# darcs-(^|/)_darcs($|/)-(^|/)\.darcsrepo($|/)-^\.darcs-temp-mail$--darcs-backup[[:digit:]]+$-# gnu arch-(^|/)(\+|,)-(^|/)vssver\.scc$-\.swp$-(^|/)MT($|/)-(^|/)\{arch\}($|/)-(^|/).arch-ids($|/)-# bitkeeper-(^|/)BitKeeper($|/)-(^|/)ChangeSet($|/)--### miscellaneous-# backup files-~$-\.bak$-\.BAK$-# patch originals and rejects-\.orig$-\.rej$-# X server-\..serverauth.*-# image spam-\#-(^|/)Thumbs\.db$-# vi, emacs tags-(^|/)(tags|TAGS)$-#(^|/)\.[^/]-# core dumps-(^|/|\.)core$-# partial broken files (KIO copy operations)-\.part$-# waf files, see http://code.google.com/p/waf/-(^|/)\.waf-[[:digit:].]+-[[:digit:]]+($|/)-(^|/)\.lock-wscript$-# mac os finder-(^|/)\.DS_Store$
− _darcs/prefs/defaultrepo 
@@ -1,1 +0,0 @@-http://patch-tag.com/r/txt-sushi/pullrepo
− _darcs/prefs/motd 
− _darcs/prefs/prefs 
@@ -1,1 +0,0 @@-boringfile .boring
− _darcs/prefs/repos 
@@ -1,1 +0,0 @@-http://patch-tag.com/r/txt-sushi/pullrepo
− _darcs/prefs/sources 
@@ -1,3 +0,0 @@-repo:http://patch-tag.com/r/txt-sushi/pullrepo-thisrepo:/Users/keith/temp/txt-sushi-0.2-cache:/Users/keith/.darcs/cache
− _darcs/pristine.hashed/0000000088-2061bfc1d7e7ec5e518faee92edbbe7e4472e558cbae9ce84fc8 
binary file changed (106 → absent bytes)
− _darcs/pristine.hashed/0000000111-2eb4b905deb944c0862657c882064532176f86535181e46e7bce 
binary file changed (104 → absent bytes)
− _darcs/pristine.hashed/0000000200-e7e4b45569ce239f362a5c76d649eaf15813287b9030345c7a74 
binary file changed (133 → absent bytes)
− _darcs/pristine.hashed/0000000286-f5df68519401593190ddd743563beb6fc0323da0bfe27784109a 
binary file changed (213 → absent bytes)
− _darcs/pristine.hashed/0000000291-9f5e432df6f1bc2d706d98e6d03e3863223f8fef6398a859e712 
binary file changed (215 → absent bytes)
− _darcs/pristine.hashed/0000000376-5b92e0d16d8aacbf288cedc6ec477ba4cf43017327a542362992 
binary file changed (259 → absent bytes)
− _darcs/pristine.hashed/0000000445-2956c382ba76682981c52ac0b823a1498c3b985f0f0248c0bbac 
binary file changed (277 → absent bytes)
− _darcs/pristine.hashed/0000000522-4aceb8d853e003efc12f16b82875a9d151e9263a62d6a523a5cb 
binary file changed (349 → absent bytes)
− _darcs/pristine.hashed/0000000523-682613113249839d8ce475b8ac48d760a593eb9cba6c07e7f998 
binary file changed (325 → absent bytes)
− _darcs/pristine.hashed/0000000608-50982335dfb9bdaf3468db64cc53839e5a552bc928ac9c153459 
binary file changed (319 → absent bytes)
− _darcs/pristine.hashed/0000000626-7b94f2ad9b5ddaa9d78c1bbbbc1bf24404122c1c9415239316fd 
binary file changed (321 → absent bytes)
− _darcs/pristine.hashed/0000000650-4d5fa370e5a998b4346e9c2df2e81ddf09bc6435c0f7dbca0afd 
binary file changed (424 → absent bytes)
− _darcs/pristine.hashed/0000000733-b497d395fe2a8d6f42e771045322ae663ac67d81db8ace0eaba4 
binary file changed (448 → absent bytes)
− _darcs/pristine.hashed/0000000853-5c22e0c03f2bd51e17dab53bd12d109965be878b6ec35636aa88 
binary file changed (483 → absent bytes)
− _darcs/pristine.hashed/0000000854-ca1995790b7158e896bfd840685e52837e55fb75f21f1910f197 
binary file changed (386 → absent bytes)
− _darcs/pristine.hashed/0000000929-42e83abfbfc514fbce439a61f955f3e73c2676647266dab06da2 
binary file changed (419 → absent bytes)
− _darcs/pristine.hashed/0000001118-0d6474967277971e0f30b93baf1a90e52db1ceb04de1157261b6 
binary file changed (623 → absent bytes)
− _darcs/pristine.hashed/0000001207-bc201d58790f04a515cdecf786a94812b0b7644b50b76c7f1eed 
binary file changed (479 → absent bytes)
− _darcs/pristine.hashed/0000001225-d85bae845f150051981654adb19422822721931022f5efac3dc1 
binary file changed (483 → absent bytes)
− _darcs/pristine.hashed/0000001352-f4b63f1a6fe106adc86e8b58af29d4a078755ee01322d887f6e1 
binary file changed (534 → absent bytes)
− _darcs/pristine.hashed/0000001382-0fe562a03070b1c03130d81917674ad6b950cc0ce9f314731994 
binary file changed (560 → absent bytes)
− _darcs/pristine.hashed/0000001500-6297c5727d10ee993de16a5b475efb3c35bb0ba9a301a2f2aa23 
binary file changed (595 → absent bytes)
− _darcs/pristine.hashed/0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f0780 
binary file changed (856 → absent bytes)
− _darcs/pristine.hashed/0000001710-9ede27ebfdd59187303a5aae1b2cda57b3e2284b295d6d24e850 
binary file changed (693 → absent bytes)
− _darcs/pristine.hashed/0000002042-31f05b2de17e2cafc6e292556cad02125548830edbf55da03032 
binary file changed (1092 → absent bytes)
− _darcs/pristine.hashed/0000002342-06e125d86b412c96aeb7f856ff7bdaf7d8e70f455499fbf8d834 
binary file changed (743 → absent bytes)
− _darcs/pristine.hashed/0000004451-04d981a18f7e94e1461cb7235d19608ce25b741ed9085fe5b9c9 
binary file changed (1244 → absent bytes)
− _darcs/pristine.hashed/0000004624-52cac272f443c622f640299a179e984932582f60479117a477c8 
binary file changed (1477 → absent bytes)
− _darcs/pristine.hashed/0000006425-16c0f4848f8e361361d200395b98d895385e5f90f61a636b7432 
binary file changed (1752 → absent bytes)
− _darcs/pristine.hashed/0000007422-d76d386b471ecbf7126236116e30d46a193a39f5eee11c93086a 
binary file changed (1933 → absent bytes)
− _darcs/pristine.hashed/0000007530-baac5ef4de73ccb7c3a3c5ed104932bbc7d99c5c332b16df3b39 
binary file changed (2074 → absent bytes)
− _darcs/pristine.hashed/0000012267-af3a69b0dc65220116215bbf886f1c42a112640b3ecce2b454ad 
binary file changed (1261 → absent bytes)
− _darcs/pristine.hashed/0000018571-53e87b4f3da210d9ce301522df0cb4217ef69efa54424246ffc3 
binary file changed (4750 → absent bytes)
− _darcs/pristine.hashed/0000025902-7e39012f7884c9eaae8c5462329524b9cc60eb55b77abd12f411 
binary file changed (6144 → absent bytes)
− _darcs/pristine.hashed/0000035147-8ceb4b9ee5adedde47b31e975c1d90c73ad27b6b165a1dcd80c7 
binary file changed (12137 → absent bytes)
− _darcs/pristine.hashed/da39a3ee5e6b4b0d3255bfef95601890afd80709 
− _darcs/tentative_hashed_inventory 
@@ -1,8 +0,0 @@-pristine:0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f07800936c5acb260-Starting with inventory:-0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e19f69207-[TAG release 0.2-keithshep@gmail.com**20090521033210- Ignore-this: b0ed58fccf2f95a610521713d9c1a499-] -hash: 0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d094046526
− _darcs/tentative_pristine 
@@ -1,1 +0,0 @@-pristine:0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f07800936c5acb260
csvtopretty.hs view
@@ -4,8 +4,8 @@ import System.Exit import System.IO -import TxtSushi.IO-import Util.IOUtil+import Database.TxtSushi.IO+import Database.TxtSushi.Util.IOUtil  main = do     args <- getArgs
csvtotab.hs view
@@ -3,8 +3,8 @@ import System.Exit import System.IO -import TxtSushi.IO-import Util.IOUtil+import Database.TxtSushi.IO+import Database.TxtSushi.Util.IOUtil  main = do     args <- getArgs
− examples/create-view-metricstats.bash 
@@ -1,17 +0,0 @@-#!/bin/bash--# replicating 1st CREATE VIEW from-# http://www.itl.nist.gov/div897/ctg/dm/sql_examples.htm-#-# CREATE VIEW METRIC_STATS (ID, MONTH, TEMP_C, RAIN_C) AS-# SELECT ID,-# MONTH,-# (TEMP_F - 32) * 5 /9,-# RAIN_I * 0.3937-# FROM STATS;--# After redirecting to metric_stats.csv we can simply use that as a table.-# So, that's as close as TxtSushi gets to creating a view :-)-../dist/build/tssql/tssql -table STATS stats.csv \-'SELECT ID, MONTH, (TEMP_F - 32) * 5 /9, RAIN_I * 0.3937 FROM STATS' \-> metric_stats.csv
− examples/example1.csv 
@@ -1,242 +0,0 @@-"id","some val","other val"-12,43,"hello 33"-13,44,"hello 34"-14,45,"hello 35"-15,46,"hello 36"-16,47,"hello 37"-17,48,"hello 38"-18,49,"hello 39"-19,50,"hello 40"-20,51,"hello 41"-21,52,"hello 42"-22,53,"hello 43"-23,54,"hello 44"-24,55,"hello 45"-25,56,"hello 46"-26,57,"hello 47"-27,58,"hello 48"-28,59,"hello 49"-29,60,"hello 50"-30,61,"hello 51"-31,62,"hello 52"-32,63,"hello 53"-33,64,"hello 54"-34,65,"hello 55"-35,66,"hello 56"-36,67,"hello 57"-37,68,"hello 58"-38,69,"hello 59"-39,70,"hello 60"-40,71,"hello 61"-41,72,"hello 62"-42,73,"hello 63"-43,74,"hello 64"-44,75,"hello 65"-45,76,"hello 66"-46,77,"hello 67"-47,78,"hello 68"-48,79,"hello 69"-49,80,"hello 70"-50,81,"hello 71"-51,82,"hello 72"-52,83,"hello 73"-53,84,"hello 74"-54,85,"hello 75"-55,86,"hello 76"-56,87,"hello 77"-57,43,"hello 78"-58,43,"hello 79"-59,43,"hello 80"-60,43,"hello 81"-61,43,"hello 82"-62,43,"hello 83"-63,43,"hello 84"-64,43,"hello 85"-65,44,"hello 86"-66,44,"hello 87"-67,44,"hello 88"-68,44,"hello 89"-69,44,"hello 90"-70,44,"hello 91"-71,44,"hello 92"-72,43,"hello 93"-73,43,"hello 94"-74,43,"hello 95"-75,43,"hello 96"-76,43,"hello 97"-77,43,"hello 98"-78,43,"hello 99"-79,43,"hello 100"-80,43,"hello 101"-81,43,"hello 102"-82,43,"hello 103"-83,43,"hello 104"-84,43,"hello 105"-85,43,"hello 106"-86,43,"hello 107"-87,43,"hello 108"-88,44,"hello 109"-89,44,"hello 110"-90,44,"hello 111"-91,44,"hello 112"-92,44,"hello 113"-93,44,"hello 114"-94,44,"hello 115"-95,43,"hello 116"-96,43,"hello 117"-97,43,"hello 118"-98,43,"hello 119"-99,43,"hello 120"-100,43,"hello 121"-101,43,"hello 122"-102,43,"hello 123"-103,43,"hello 124"-104,43,"hello 125"-105,43,"hello 126"-106,43,"hello 127"-107,43,"hello 128"-108,43,"hello 129"-109,43,"hello 130"-110,43,"hello 131"-111,43,"hello 132"-112,43,"hello 133"-113,43,"hello 134"-114,43,"hello 135"-115,43,"hello 136"-116,43,"hello 137"-117,43,"hello 138"-118,43,"hello 139"-119,43,"hello 140"-120,43,"hello 141"-121,43,"hello 142"-122,43,"hello 143"-123,43,"hello 144"-124,43,"hello 145"-125,43,"hello 146"-126,43,"hello 147"-127,43,"hello 148"-128,43,"hello 149"-129,43,"hello 150"-130,43,"hello 151"-131,43,"hello 152"-132,43,"hello 153"-133,43,"hello 154"-134,43,"hello 155"-135,43,"hello 156"-136,43,"hello 157"-137,43,"hello 158"-138,43,"hello 159"-139,43,"hello 160"-140,43,"hello 161"-141,43,"hello 162"-142,43,"hello 163"-143,43,"hello 164"-144,43,"hello 165"-145,43,"hello 166"-146,43,"hello 167"-147,43,"hello 168"-148,43,"hello 169"-149,43,"hello 170"-150,43,"hello 171"-151,43,"hello 172"-152,43,"hello 173"-153,43,"hello 174"-154,43,"hello 175"-155,43,"hello 176"-156,43,"hello 177"-157,43,"hello 178"-158,43,"hello 179"-159,43,"hello 180"-160,43,"hello 181"-161,43,"hello 182"-162,43,"hello 183"-163,43,"hello 184"-164,43,"hello 185"-165,43,"hello 186"-166,43,"hello 187"-167,43,"hello 188"-168,43,"hello 189"-169,43,"hello 190"-170,43,"hello 191"-171,43,"hello 192"-172,43,"hello 193"-173,43,"hello 194"-174,43,"hello 195"-175,43,"hello 196"-176,43,"hello 197"-177,43,"hello 198"-178,43,"hello 199"-179,43,"hello 200"-180,43,"hello 201"-181,43,"hello 202"-182,43,"hello 203"-183,43,"hello 204"-184,43,"hello 205"-185,43,"hello 206"-186,43,"hello 207"-187,43,"hello 208"-188,43,"hello 209"-189,43,"hello 210"-190,43,"hello 211"-191,43,"hello 212"-192,43,"hello 213"-193,43,"hello 214"-194,43,"hello 215"-195,43,"hello 216"-196,43,"hello 217"-197,43,"hello 218"-198,43,"hello 219"-199,43,"hello 220"-200,43,"hello 221"-201,43,"hello 222"-202,43,"hello 223"-203,43,"hello 224"-204,43,"hello 225"-205,43,"hello 226"-206,43,"hello 227"-207,43,"hello 228"-208,43,"hello 229"-209,43,"hello 230"-210,43,"hello 231"-211,43,"hello 232"-212,43,"hello 233"-213,43,"hello 234"-214,43,"hello 235"-215,43,"hello 236"-216,43,"hello 237"-217,43,"hello 238"-218,43,"hello 239"-219,43,"hello 240"-220,43,"hello 241"-221,43,"hello 242"-222,43,"hello 243"-223,43,"hello 244"-224,43,"hello 245"-225,43,"hello 246"-226,43,"hello 247"-227,43,"hello 248"-228,43,"hello 249"-229,43,"hello 250"-230,43,"hello 251"-231,43,"hello 252"-232,43,"hello 253"-233,43,"hello 254"-234,43,"hello 255"-235,43,"hello 256"-236,43,"hello 257"-237,43,"hello 258"-238,43,"hello 259"-239,43,"hello 260"-240,43,"hello 261"-241,43,"hello 262"-242,43,"hello 263"-243,43,"hello 264"-244,43,"hello 265"-245,43,"hello 266"-246,43,"hello 267"-247,43,"hello '268"""-248,"this --- has -a couple of newlines","hello 269"-249,43,"hello 270"-250,43,"hello 271"
− examples/example2.csv 
@@ -1,8 +0,0 @@-"id2","some val","other val"-244,"some","hello 265"-245,"other","hello 266"-246,"values","hello 267"-247,"than","hello '268"""-248,"example","hello 269"-249,"number","hello 270"-250,"one","hello 271"
− examples/join-stats-station.bash 
@@ -1,15 +0,0 @@-#!/bin/bash--# replicating JOIN from-# http://www.itl.nist.gov/div897/ctg/dm/sql_examples.htm-#-# SELECT LAT_N, CITY, TEMP_F-# FROM STATS, STATION-# WHERE MONTH = 7-# AND STATS.ID = STATION.ID-# ORDER BY TEMP_F;--../dist/build/tssql/tssql -table STATION station.csv -table STATS stats.csv \-'SELECT LAT_N, CITY, TEMP_F FROM STATS JOIN STATION ON STATS.ID = STATION.ID-WHERE MONTH = 7 ORDER BY TEMP_F' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/kitchen-sink.bash 
@@ -1,12 +0,0 @@-#!/bin/bash--# Our kitchen sink example to exercise all of the TxtSushi functionality as-# we can in one SELECT.-# NOTE: the "+ 0" is needed to coerce id to an integer. Otherwise it is-# sorted as text which is not what we want-../dist/build/tssql/tssql \-'select `example1.csv`.*, `example2.csv`.`other val`, `example2.csv`.id2-from `example1.csv` join `example2.csv` on `example1.csv`.id = `example2.csv`.id2-where `other val` <> "hello 269" and id2 > 246-order by id + 0 asc' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/query-imputed-SNPs-regex.bash 
@@ -1,15 +0,0 @@-#!/bin/bash--# An example of using TxtSushi to query one of the CGD (center for genome dynamics)-# datasets-# -# Selects chromosome, base pair position, data source and a couple of strains.-# Filters out any rows from perlegen and any rows where A/J and BPH/2J differ--curl -s http://cgd.jax.org/ImputedSNPData/v1.1/PBupdatedv1.1_HMM_filleddata/PBupdatedv1.1_SNP_genoData_chr4.csv.gz \-| zcat \-| ../dist/build/tssql/tssql -table cgd - \-'select ChrID, `build 36 bp Position`, Source, `BPH/2J`, `A/J`, (Source =~ "Celera2"), (Source =~ "^Celera2"), not (Source =~ "^Celera2") from cgd-where not (Source =~ "^Perlegen36_b03$") and `A/J` = `BPH/2J`-order by `build 36 bp Position` + 0 desc' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/query-imputed-SNPs.bash 
@@ -1,15 +0,0 @@-#!/bin/bash--# An example of using TxtSushi to query one of the CGD (center for genome dynamics)-# datasets-# -# Selects chromosome, base pair position, data source and a couple of strains.-# Filters out any rows from perlegen and any rows where A/J and BPH/2J differ--curl -s http://cgd.jax.org/ImputedSNPData/v1.1/PBupdatedv1.1_HMM_filleddata/PBupdatedv1.1_SNP_genoData_chr4.csv.gz \-| zcat \-| ../dist/build/tssql/tssql -table cgd - \-'select ChrID, `build 36 bp Position`, Source, `BPH/2J`, `A/J` from cgd-where Source <> "Perlegen36_b03" and `A/J` = `BPH/2J`-order by `build 36 bp Position` + 0 desc' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/query-mgi-markers.bash 
@@ -1,18 +0,0 @@-#!/bin/bash--# An example of using TxtSushi to query one of the MGI (mouse genome informatics)-# database reports-#-# Selects accession ID, Symbol, chromosome, ID and centimorgan position (without-# the "trim" we end up with extra spaces).-# Only select chromosomes 1, 8 and 19 and look for "N/A" positions-# Sort the rows by chromosome (the "+0" coerces the chromosome from text to an-# integer) then symbol--wget -q -O - ftp://ftp.informatics.jax.org/pub/reports/MRK_List2.rpt \-| ../dist/build/tabtocsv/tabtocsv - \-| ../dist/build/tssql/tssql -table mgi - \-'select substring(`MGI Accession ID` from 5), substring(`MGI Accession ID` from 5 for 3), `MGI Accession ID`, Symbol, Chr, trim(`cM Position`)-from mgi where (Chr = 1 or Chr = 8 or Chr = 19) and trim(`cM Position`) = "N/A"-order by Chr+0, Symbol' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/select-station.bash 
@@ -1,11 +0,0 @@-#!/bin/bash--# replicating SELECT from-# http://www.itl.nist.gov/div897/ctg/dm/sql_examples.htm-#-# SELECT * FROM STATION-# WHERE LAT_N > 39.7--../dist/build/tssql/tssql -table STATION station.csv \-'SELECT * FROM STATION WHERE LAT_N > 39.7' \-| ../dist/build/csvtopretty/csvtopretty -
− examples/station.csv 
@@ -1,4 +0,0 @@-ID,CITY,STATE,LAT_N,LONG_W-13,Phoenix,AZ,33,112-44,Denver,CO,40,105-66,Caribou,ME,47,68
− examples/stats.csv 
@@ -1,7 +0,0 @@-ID,MONTH,TEMP_F,RAIN_I-13,1,57.4,0.31-13,7,91.7,5.15-44,1,27.3,0.18-44,7,74.8,2.11-66,1,6.7,2.1-66,7,65.8,4.52
− joincol.hs 
@@ -1,60 +0,0 @@-import Data.List-import System.Directory-import System.Environment-import System.Exit-import System.IO--import TxtSushi.IO-import TxtSushi.Transform-import Util.IOUtil--closeAll [] = do return ()-closeAll (handle:tail) = do-    hClose handle-    closeAll tail--removeAll [] = do return ()-removeAll (file:tail) = do-    removeFile file-    removeAll tail--main = do-    args <- getArgs-    -    let lenArgs = length args-    -    if lenArgs < 4 || odd lenArgs-        then do-            hPutStrLn stderr $-                    "ERROR: program requires at least four arguments " ++-                    "(two or more join column arguments and two filenames), " ++-                    "also the argument count should be even"-            exitFailure-        else do-            let lenNonFileArgs = (lenArgs - 2)-                (nonFileArgs, fileName1:fileName2:[]) = splitAt lenNonFileArgs args-                allJoinIndices = map read nonFileArgs :: [Int]-                table1ColIndices = [allJoinIndices !! i | i <- [0, 2 .. (lenNonFileArgs - 1)]]-                table2ColIndices = [allJoinIndices !! i | i <- [1, 3 .. (lenNonFileArgs - 1)]]-                zippedColumnIndices = zip table1ColIndices table2ColIndices-            -            contents1 <- getContentsFromFileOrStdin fileName1-            contents2 <- getContentsFromFileOrStdin fileName2-            -            let table1 = parseTable csvFormat contents1-                table2 = parseTable csvFormat contents2-            -            (partialSortTables1, partialSortFileHandles1, partialSortFiles1) <- fileBasedSortTable table1ColIndices table1-            (partialSortTables2, partialSortFileHandles2, partialSortFiles2) <- fileBasedSortTable table2ColIndices table2-            -            let sortedTable1 = mergeAllBy (rowComparison table1ColIndices) partialSortTables1-                sortedTable2 = mergeAllBy (rowComparison table2ColIndices) partialSortTables2-                joinedTable = joinPresortedTables zippedColumnIndices sortedTable1 sortedTable2-                joinedTableText = formatTable csvFormat joinedTable-            -            putStr joinedTableText-            -            closeAll $ partialSortFileHandles1 ++ partialSortFileHandles2-            removeAll $ partialSortFiles1 ++ partialSortFiles2-            -            return ()
+ namecolumns.hs view
@@ -0,0 +1,25 @@+import Data.List+import System.Environment+import System.Exit+import System.IO++import Database.TxtSushi.IO+import Database.TxtSushi.Util.IOUtil++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+            +            putStr $ if null table then "" else formatTable csvFormat namedTable
− selectcol.hs 
@@ -1,51 +0,0 @@-import Data.List-import System.Environment-import System.Exit-import System.IO--import TxtSushi.IO-import TxtSushi.Transform-import Util.CommandLineArgument-import Util.IOUtil--{--byNameOption = OptionDescription-    False       -- isRequired-    "-by-name"  -- optionFlag-    []          -- argumentNames-    0           -- minArgumentCount-    True        -- argumentCountIsFixed--helpOption = OptionDescription-    False       -- isRequired-    "-help"     -- optionFlag-    []          -- argumentNames-    0           -- minArgumentCount-    True        -- argumentCountIsFixed--options = [helpOption, byNameOption]--}----toColumnIndices optionMap [] = --main = do-    args <- getArgs-    progName <- getProgName-    -    if (length args) <= 1-        then do-            error $ progName ++ " requires at least two arguments " ++-                    "(one column argument and a filename or '-')"-        else do-            let argCount = length args-                (argsWithoutFile, [fileName]) = splitAt (argCount - 1) args-                --(optionsMap, tailArgs) = extractOptions options argsWithoutFile-                colIndices = map read (init args) :: [Int]-            -            contents <- getContentsFromFileOrStdin fileName-            -            let table = parseTable csvFormat contents-                subsetTable = selectColumns colIndices table-                subsetTableText = formatTable csvFormat subsetTable-            putStr subsetTableText-            return ()
− selectcolname.hs 
@@ -1,38 +0,0 @@-import Data.List-import System.Environment-import System.Exit-import System.IO--import TxtSushi.IO-import TxtSushi.Transform-import Util.IOUtil--maybeIndexToIndexOrError :: [String] -> [Maybe Int] -> [Int]-maybeIndexToIndexOrError [] [] = []-maybeIndexToIndexOrError (name:namesTail) (Nothing:indexTail) =-    error $ "Could not find column header named \"" ++ name ++ "\""-maybeIndexToIndexOrError (name:namesTail) ((Just index):indexTail) =-    index:(maybeIndexToIndexOrError namesTail indexTail)--main = do-    args <- getArgs-    -    if (length args) <= 1-        then do-            hPutStrLn stderr $-                    "ERROR: program requires at least two arguments " ++-                    "(one column name argument and a filename or '-')"-            exitFailure-        else do-            contents <- getContentsFromFileOrStdin (last args)-            -            let argsWithoutFile = init args-                colNames = init args-                table = parseTable csvFormat contents-                header = head table-                maybeColIndices = [elemIndex name header | name <- colNames]-                colIndices = maybeIndexToIndexOrError colNames maybeColIndices-                subsetTable = selectColumns colIndices table-                subsetTableText = formatTable csvFormat subsetTable-            putStr subsetTableText-            return ()
− sortcol.hs 
@@ -1,47 +0,0 @@-import Data.List-import System.Directory-import System.Environment-import System.Exit-import System.IO--import TxtSushi.IO-import TxtSushi.Transform-import Util.IOUtil--closeAll [] = do return ()-closeAll (handle:tail) = do-    hClose handle-    closeAll tail--removeAll [] = do return ()-removeAll (file:tail) = do-    removeFile file-    removeAll tail--main = do-    args <- getArgs-    -    if (length args) <= 1-        then do-            hPutStrLn stderr $-                    "ERROR: program requires at least two arguments " ++-                    "(one column argument and a filename or '-')"-            exitFailure-        else do-            contents <- getContentsFromFileOrStdin (last args)-            -            let argsWithoutFile = init args-                colIndices = map read (init args) :: [Int]-                table = parseTable csvFormat contents-            -            (partialSortTables, partialSortFileHandles, partialSortFiles) <- fileBasedSortTable colIndices table-            -            let sortedTable     = mergeAllBy (rowComparison colIndices) partialSortTables-                sortedTableText = formatTable csvFormat sortedTable-            -            putStr sortedTableText-            -            closeAll partialSortFileHandles-            removeAll partialSortFiles-            -            return ()
tabtocsv.hs view
@@ -3,8 +3,8 @@ import System.Exit import System.IO -import TxtSushi.IO-import Util.IOUtil+import Database.TxtSushi.IO+import Database.TxtSushi.Util.IOUtil  main = do     args <- getArgs
tabtopretty.hs view
@@ -4,8 +4,8 @@ import System.Exit import System.IO -import TxtSushi.IO-import Util.IOUtil+import Database.TxtSushi.IO+import Database.TxtSushi.Util.IOUtil  main = do     args <- getArgs
tssql.hs view
@@ -17,12 +17,12 @@  import Text.ParserCombinators.Parsec -import TxtSushi.IO-import TxtSushi.SQLExecution-import TxtSushi.SQLParser-import TxtSushi.Transform-import Util.CommandLineArgument-import Util.IOUtil+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  helpOption = OptionDescription {     isRequired              = False,@@ -79,7 +79,7 @@          let (argMap, argTail) = extractCommandLineArguments sqlCmdLine args         showHelp = Map.member helpOption argMap || length argTail /= 1-        parseOutcome = parse parseSelectStatement "" (head argTail)+        parseOutcome = parse (withTrailing eof parseSelectStatement) "" (head argTail)          if showHelp then printUsage progName else         case parseOutcome of
txt-sushi.cabal view
@@ -1,19 +1,21 @@ Name:                txt-sushi-Version:             0.2+Version:             0.3.0 Synopsis:            Spreadsheets are databases! Description:     TxtSushi is a collection of command line utilities for processing     comma-separated and tab-delimited files (AKA flat files, spreadsheets).+    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. TxtSushi's homepage is <http://keithsheppard.name/txt-sushi>.+    language. License:             GPL License-File:        COPYING Author:              Keith Sheppard Maintainer:          keithshep@gmail.com+Homepage:            http://keithsheppard.name/txt-sushi Build-Type:          Simple-Category:            Utils, Text, Database+Category:            Database, Utils, Text Cabal-Version:       >=1.2  Executable tssql@@ -43,5 +45,23 @@  Executable tabtopretty   Main-Is:          tabtopretty.hs+  Build-Depends:    base,haskell98,directory,containers+  GHC-Options:      -O2 -fvia-C++Executable namecolumns+  Main-Is:          namecolumns.hs+  Build-Depends:    base,haskell98,directory,containers+  GHC-Options:      -O2 -fvia-C++Library+  Exposed-Modules:+    Database.TxtSushi.IO+    Database.TxtSushi.SQLExecution+    Database.TxtSushi.SQLParser+    Database.TxtSushi.Transform+    Database.TxtSushi.Util.CommandLineArgument+    Database.TxtSushi.Util.IOUtil+    Database.TxtSushi.Util.ListUtil+     Build-Depends:    base,haskell98,directory,containers   GHC-Options:      -O2 -fvia-C