diff --git a/.boring b/.boring deleted file mode 100644 --- a/.boring +++ /dev/null @@ -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$ diff --git a/Database/TxtSushi/IO.hs b/Database/TxtSushi/IO.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/IO.hs @@ -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) diff --git a/Database/TxtSushi/SQLExecution.hs b/Database/TxtSushi/SQLExecution.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/SQLExecution.hs @@ -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 diff --git a/Database/TxtSushi/SQLParser.hs b/Database/TxtSushi/SQLParser.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/SQLParser.hs @@ -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) diff --git a/Database/TxtSushi/Transform.hs b/Database/TxtSushi/Transform.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/Transform.hs @@ -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 + diff --git a/Database/TxtSushi/Util/CommandLineArgument.hs b/Database/TxtSushi/Util/CommandLineArgument.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/Util/CommandLineArgument.hs @@ -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) +-} diff --git a/Database/TxtSushi/Util/IOUtil.hs b/Database/TxtSushi/Util/IOUtil.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/Util/IOUtil.hs @@ -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) diff --git a/Database/TxtSushi/Util/ListUtil.hs b/Database/TxtSushi/Util/ListUtil.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/Util/ListUtil.hs @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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:" diff --git a/TxtSushi/IO.hs b/TxtSushi/IO.hs deleted file mode 100644 --- a/TxtSushi/IO.hs +++ /dev/null @@ -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) diff --git a/TxtSushi/SQLExecution.hs b/TxtSushi/SQLExecution.hs deleted file mode 100644 --- a/TxtSushi/SQLExecution.hs +++ /dev/null @@ -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 diff --git a/TxtSushi/SQLParser.hs b/TxtSushi/SQLParser.hs deleted file mode 100644 --- a/TxtSushi/SQLParser.hs +++ /dev/null @@ -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) diff --git a/TxtSushi/Transform.hs b/TxtSushi/Transform.hs deleted file mode 100644 --- a/TxtSushi/Transform.hs +++ /dev/null @@ -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 - diff --git a/Util/CommandLineArgument.hs b/Util/CommandLineArgument.hs deleted file mode 100644 --- a/Util/CommandLineArgument.hs +++ /dev/null @@ -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) --} diff --git a/Util/IOUtil.hs b/Util/IOUtil.hs deleted file mode 100644 --- a/Util/IOUtil.hs +++ /dev/null @@ -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) diff --git a/Util/ListUtil.hs b/Util/ListUtil.hs deleted file mode 100644 --- a/Util/ListUtil.hs +++ /dev/null @@ -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 diff --git a/_darcs/format b/_darcs/format deleted file mode 100644 --- a/_darcs/format +++ /dev/null @@ -1,2 +0,0 @@ -hashed -darcs-2 diff --git a/_darcs/hashed_inventory b/_darcs/hashed_inventory deleted file mode 100644 --- a/_darcs/hashed_inventory +++ /dev/null @@ -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 diff --git a/_darcs/inventories/0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e b/_darcs/inventories/0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e deleted file mode 100644 Binary files a/_darcs/inventories/0000001260-8f8e2c077c4bae8cc2094386214bd292379b1ee72540673d89e1514e and /dev/null differ diff --git a/_darcs/inventories/0000006394-dd21a7fa69cce91d38242dda31118e5085023e7aecfddff8f8da0cac b/_darcs/inventories/0000006394-dd21a7fa69cce91d38242dda31118e5085023e7aecfddff8f8da0cac deleted file mode 100644 Binary files a/_darcs/inventories/0000006394-dd21a7fa69cce91d38242dda31118e5085023e7aecfddff8f8da0cac and /dev/null differ diff --git a/_darcs/patches/0000000191-2c40a8181d0d6b42236bb2abe2767fc51ffa6d2188cf0021d18edd89ab9d b/_darcs/patches/0000000191-2c40a8181d0d6b42236bb2abe2767fc51ffa6d2188cf0021d18edd89ab9d deleted file mode 100644 Binary files a/_darcs/patches/0000000191-2c40a8181d0d6b42236bb2abe2767fc51ffa6d2188cf0021d18edd89ab9d and /dev/null differ diff --git a/_darcs/patches/0000000191-69a041fd53c8f7e5b11f835e60b49daed29b88b43b0883d94275efaa2c69 b/_darcs/patches/0000000191-69a041fd53c8f7e5b11f835e60b49daed29b88b43b0883d94275efaa2c69 deleted file mode 100644 Binary files a/_darcs/patches/0000000191-69a041fd53c8f7e5b11f835e60b49daed29b88b43b0883d94275efaa2c69 and /dev/null differ diff --git a/_darcs/patches/0000000201-d27210175d1d081a056238cd9769a42c7ff50dede48181fa8f1b903bc379 b/_darcs/patches/0000000201-d27210175d1d081a056238cd9769a42c7ff50dede48181fa8f1b903bc379 deleted file mode 100644 Binary files a/_darcs/patches/0000000201-d27210175d1d081a056238cd9769a42c7ff50dede48181fa8f1b903bc379 and /dev/null differ diff --git a/_darcs/patches/0000000274-fb6ae1f888a0ae95c79a8c88327e34b133890b754cef6ab3a1c9f87f6795 b/_darcs/patches/0000000274-fb6ae1f888a0ae95c79a8c88327e34b133890b754cef6ab3a1c9f87f6795 deleted file mode 100644 Binary files a/_darcs/patches/0000000274-fb6ae1f888a0ae95c79a8c88327e34b133890b754cef6ab3a1c9f87f6795 and /dev/null differ diff --git a/_darcs/patches/0000000378-118496eba00c44a2334983e28a06cfaed256bd373079edef16ec469d3e36 b/_darcs/patches/0000000378-118496eba00c44a2334983e28a06cfaed256bd373079edef16ec469d3e36 deleted file mode 100644 Binary files a/_darcs/patches/0000000378-118496eba00c44a2334983e28a06cfaed256bd373079edef16ec469d3e36 and /dev/null differ diff --git a/_darcs/patches/0000000454-837c722676d15daf644fe71a0071838789d7b496db348af85374cad4650e b/_darcs/patches/0000000454-837c722676d15daf644fe71a0071838789d7b496db348af85374cad4650e deleted file mode 100644 Binary files a/_darcs/patches/0000000454-837c722676d15daf644fe71a0071838789d7b496db348af85374cad4650e and /dev/null differ diff --git a/_darcs/patches/0000000474-3e80349a7a5f8eaabc8813f1144636e87e9b781f5b4013942a6cdc2046db b/_darcs/patches/0000000474-3e80349a7a5f8eaabc8813f1144636e87e9b781f5b4013942a6cdc2046db deleted file mode 100644 Binary files a/_darcs/patches/0000000474-3e80349a7a5f8eaabc8813f1144636e87e9b781f5b4013942a6cdc2046db and /dev/null differ diff --git a/_darcs/patches/0000000504-d7bfdb8aa7370ef5916acda9945f1ad0a2f00320a5f04072ea57058e68ce b/_darcs/patches/0000000504-d7bfdb8aa7370ef5916acda9945f1ad0a2f00320a5f04072ea57058e68ce deleted file mode 100644 Binary files a/_darcs/patches/0000000504-d7bfdb8aa7370ef5916acda9945f1ad0a2f00320a5f04072ea57058e68ce and /dev/null differ diff --git a/_darcs/patches/0000000505-7003ad42b1c6a26ab34ed80b54cfa6fab8f2c81bda2dbcccb6725525ac2d b/_darcs/patches/0000000505-7003ad42b1c6a26ab34ed80b54cfa6fab8f2c81bda2dbcccb6725525ac2d deleted file mode 100644 Binary files a/_darcs/patches/0000000505-7003ad42b1c6a26ab34ed80b54cfa6fab8f2c81bda2dbcccb6725525ac2d and /dev/null differ diff --git a/_darcs/patches/0000000609-f1b0b1a03c3d8421d17dc15a39609949c9e5960e3f7b6ceb8f7292053975 b/_darcs/patches/0000000609-f1b0b1a03c3d8421d17dc15a39609949c9e5960e3f7b6ceb8f7292053975 deleted file mode 100644 Binary files a/_darcs/patches/0000000609-f1b0b1a03c3d8421d17dc15a39609949c9e5960e3f7b6ceb8f7292053975 and /dev/null differ diff --git a/_darcs/patches/0000000628-16a1c0e32bda87c79248cd7435ce6da9f7a0ce7de475ef25132a7423d79c b/_darcs/patches/0000000628-16a1c0e32bda87c79248cd7435ce6da9f7a0ce7de475ef25132a7423d79c deleted file mode 100644 Binary files a/_darcs/patches/0000000628-16a1c0e32bda87c79248cd7435ce6da9f7a0ce7de475ef25132a7423d79c and /dev/null differ diff --git a/_darcs/patches/0000000757-19220ad0f4ad47d4e83a893e999066eccf7579e1b9527b1606806cd4e48e b/_darcs/patches/0000000757-19220ad0f4ad47d4e83a893e999066eccf7579e1b9527b1606806cd4e48e deleted file mode 100644 Binary files a/_darcs/patches/0000000757-19220ad0f4ad47d4e83a893e999066eccf7579e1b9527b1606806cd4e48e and /dev/null differ diff --git a/_darcs/patches/0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d09404 b/_darcs/patches/0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d09404 deleted file mode 100644 Binary files a/_darcs/patches/0000000773-b36b71d0a85a717f6642b9f04da20921fb1e3d4e2044508833e676d09404 and /dev/null differ diff --git a/_darcs/patches/0000000983-b4088fe2ce96d588b9a854e5e200c66e66b107bab5ef3dd0c1b06e52817e b/_darcs/patches/0000000983-b4088fe2ce96d588b9a854e5e200c66e66b107bab5ef3dd0c1b06e52817e deleted file mode 100644 Binary files a/_darcs/patches/0000000983-b4088fe2ce96d588b9a854e5e200c66e66b107bab5ef3dd0c1b06e52817e and /dev/null differ diff --git a/_darcs/patches/0000001149-31511fe20855eacbdbd6a435e1d33e136f5a811802e793e3316dff1b9a41 b/_darcs/patches/0000001149-31511fe20855eacbdbd6a435e1d33e136f5a811802e793e3316dff1b9a41 deleted file mode 100644 Binary files a/_darcs/patches/0000001149-31511fe20855eacbdbd6a435e1d33e136f5a811802e793e3316dff1b9a41 and /dev/null differ diff --git a/_darcs/patches/0000001733-08c8318da1c4bc1e961bb9eba067af69d50dfaebc73818cf327054466c0a b/_darcs/patches/0000001733-08c8318da1c4bc1e961bb9eba067af69d50dfaebc73818cf327054466c0a deleted file mode 100644 Binary files a/_darcs/patches/0000001733-08c8318da1c4bc1e961bb9eba067af69d50dfaebc73818cf327054466c0a and /dev/null differ diff --git a/_darcs/patches/0000001787-e542485f9074ec93d1fa924c68d8bad1d597af6c0fd6bf4a333f6e5ed702 b/_darcs/patches/0000001787-e542485f9074ec93d1fa924c68d8bad1d597af6c0fd6bf4a333f6e5ed702 deleted file mode 100644 Binary files a/_darcs/patches/0000001787-e542485f9074ec93d1fa924c68d8bad1d597af6c0fd6bf4a333f6e5ed702 and /dev/null differ diff --git a/_darcs/patches/0000001970-2037710eb055cda2b6fd3c21e3ff1388bfbad784523153362591a3067741 b/_darcs/patches/0000001970-2037710eb055cda2b6fd3c21e3ff1388bfbad784523153362591a3067741 deleted file mode 100644 Binary files a/_darcs/patches/0000001970-2037710eb055cda2b6fd3c21e3ff1388bfbad784523153362591a3067741 and /dev/null differ diff --git a/_darcs/patches/0000002001-1c05b971133432912d672cab5b5b7a742b3cf7971b6ae8116c6b67b3a13f b/_darcs/patches/0000002001-1c05b971133432912d672cab5b5b7a742b3cf7971b6ae8116c6b67b3a13f deleted file mode 100644 Binary files a/_darcs/patches/0000002001-1c05b971133432912d672cab5b5b7a742b3cf7971b6ae8116c6b67b3a13f and /dev/null differ diff --git a/_darcs/patches/0000002026-882079cdc55867c7febe504e9a79e5232b0ed543139844442cbf937734bb b/_darcs/patches/0000002026-882079cdc55867c7febe504e9a79e5232b0ed543139844442cbf937734bb deleted file mode 100644 Binary files a/_darcs/patches/0000002026-882079cdc55867c7febe504e9a79e5232b0ed543139844442cbf937734bb and /dev/null differ diff --git a/_darcs/patches/0000002333-48fdb810a3d1f4e24e501e30113fc0ce3faed45db34a0a0d01d985dbdbe8 b/_darcs/patches/0000002333-48fdb810a3d1f4e24e501e30113fc0ce3faed45db34a0a0d01d985dbdbe8 deleted file mode 100644 Binary files a/_darcs/patches/0000002333-48fdb810a3d1f4e24e501e30113fc0ce3faed45db34a0a0d01d985dbdbe8 and /dev/null differ diff --git a/_darcs/patches/0000002339-7a3bb3fc3e515f5cd742bb3ab1e575a149fbd01a477ab5630f99112635e5 b/_darcs/patches/0000002339-7a3bb3fc3e515f5cd742bb3ab1e575a149fbd01a477ab5630f99112635e5 deleted file mode 100644 Binary files a/_darcs/patches/0000002339-7a3bb3fc3e515f5cd742bb3ab1e575a149fbd01a477ab5630f99112635e5 and /dev/null differ diff --git a/_darcs/patches/0000002642-864c4d8b2d200fe4b4dc9c36a4bfcd72642cb975ac81634a8ddc8d0d7d10 b/_darcs/patches/0000002642-864c4d8b2d200fe4b4dc9c36a4bfcd72642cb975ac81634a8ddc8d0d7d10 deleted file mode 100644 Binary files a/_darcs/patches/0000002642-864c4d8b2d200fe4b4dc9c36a4bfcd72642cb975ac81634a8ddc8d0d7d10 and /dev/null differ diff --git a/_darcs/patches/0000002674-0dfb35863da7e573bf060c4fdb93a6f352005a256afea55ecfc69f812a59 b/_darcs/patches/0000002674-0dfb35863da7e573bf060c4fdb93a6f352005a256afea55ecfc69f812a59 deleted file mode 100644 Binary files a/_darcs/patches/0000002674-0dfb35863da7e573bf060c4fdb93a6f352005a256afea55ecfc69f812a59 and /dev/null differ diff --git a/_darcs/patches/0000002734-114e244d4026f048f8328ff09f306774b285630374b19867f259253fdc67 b/_darcs/patches/0000002734-114e244d4026f048f8328ff09f306774b285630374b19867f259253fdc67 deleted file mode 100644 Binary files a/_darcs/patches/0000002734-114e244d4026f048f8328ff09f306774b285630374b19867f259253fdc67 and /dev/null differ diff --git a/_darcs/patches/0000003029-267c6668ee3b23a1873b81bf13bf94ad4357cfc056c31412f2eec8ad0025 b/_darcs/patches/0000003029-267c6668ee3b23a1873b81bf13bf94ad4357cfc056c31412f2eec8ad0025 deleted file mode 100644 Binary files a/_darcs/patches/0000003029-267c6668ee3b23a1873b81bf13bf94ad4357cfc056c31412f2eec8ad0025 and /dev/null differ diff --git a/_darcs/patches/0000003945-20edbc0e6ba404e934b2e40c37cf2199d3eb19811bceb5c6e5e1a54dd7d7 b/_darcs/patches/0000003945-20edbc0e6ba404e934b2e40c37cf2199d3eb19811bceb5c6e5e1a54dd7d7 deleted file mode 100644 Binary files a/_darcs/patches/0000003945-20edbc0e6ba404e934b2e40c37cf2199d3eb19811bceb5c6e5e1a54dd7d7 and /dev/null differ diff --git a/_darcs/patches/0000003958-40c17a6c5e486cb4fd2fc0381898ef942a799ee662d7066466090cba7eb0 b/_darcs/patches/0000003958-40c17a6c5e486cb4fd2fc0381898ef942a799ee662d7066466090cba7eb0 deleted file mode 100644 Binary files a/_darcs/patches/0000003958-40c17a6c5e486cb4fd2fc0381898ef942a799ee662d7066466090cba7eb0 and /dev/null differ diff --git a/_darcs/patches/0000004103-1efcde4b404484b6d87566c4a32d6a0eae29af6dbe1b5576a833b35909b7 b/_darcs/patches/0000004103-1efcde4b404484b6d87566c4a32d6a0eae29af6dbe1b5576a833b35909b7 deleted file mode 100644 Binary files a/_darcs/patches/0000004103-1efcde4b404484b6d87566c4a32d6a0eae29af6dbe1b5576a833b35909b7 and /dev/null differ diff --git a/_darcs/patches/0000004761-5308225b40ae211903a8f2f822b3b42bed9f89393ea40e53b18e97ae0358 b/_darcs/patches/0000004761-5308225b40ae211903a8f2f822b3b42bed9f89393ea40e53b18e97ae0358 deleted file mode 100644 Binary files a/_darcs/patches/0000004761-5308225b40ae211903a8f2f822b3b42bed9f89393ea40e53b18e97ae0358 and /dev/null differ diff --git a/_darcs/patches/0000005281-3dc871668663e6efe214646a8bd241142807c859729b591f8d1c082fbb88 b/_darcs/patches/0000005281-3dc871668663e6efe214646a8bd241142807c859729b591f8d1c082fbb88 deleted file mode 100644 Binary files a/_darcs/patches/0000005281-3dc871668663e6efe214646a8bd241142807c859729b591f8d1c082fbb88 and /dev/null differ diff --git a/_darcs/patches/0000006021-64a3588aba279ddb985f7b324489c7964545079137eeebfdbbbc9ec57039 b/_darcs/patches/0000006021-64a3588aba279ddb985f7b324489c7964545079137eeebfdbbbc9ec57039 deleted file mode 100644 Binary files a/_darcs/patches/0000006021-64a3588aba279ddb985f7b324489c7964545079137eeebfdbbbc9ec57039 and /dev/null differ diff --git a/_darcs/patches/0000006540-e909d3a393f7f1bde11301fe78f45c9ca0f9d8dbc819cef0ef9b0ff87961 b/_darcs/patches/0000006540-e909d3a393f7f1bde11301fe78f45c9ca0f9d8dbc819cef0ef9b0ff87961 deleted file mode 100644 Binary files a/_darcs/patches/0000006540-e909d3a393f7f1bde11301fe78f45c9ca0f9d8dbc819cef0ef9b0ff87961 and /dev/null differ diff --git a/_darcs/patches/0000007338-d61110b41ba3dba61ede97ee514dbeea0170d6bf68685f1aefb20d3edbaf b/_darcs/patches/0000007338-d61110b41ba3dba61ede97ee514dbeea0170d6bf68685f1aefb20d3edbaf deleted file mode 100644 Binary files a/_darcs/patches/0000007338-d61110b41ba3dba61ede97ee514dbeea0170d6bf68685f1aefb20d3edbaf and /dev/null differ diff --git a/_darcs/patches/0000007357-6f774098abed7937b6ceff17f852d2fc9103fd67f563c8eaeeffffaa5236 b/_darcs/patches/0000007357-6f774098abed7937b6ceff17f852d2fc9103fd67f563c8eaeeffffaa5236 deleted file mode 100644 Binary files a/_darcs/patches/0000007357-6f774098abed7937b6ceff17f852d2fc9103fd67f563c8eaeeffffaa5236 and /dev/null differ diff --git a/_darcs/patches/0000018238-8b063fa0fab2a4a3aa27fe91a2ef6bc5d72b88ba0aac7e41f94b115806c8 b/_darcs/patches/0000018238-8b063fa0fab2a4a3aa27fe91a2ef6bc5d72b88ba0aac7e41f94b115806c8 deleted file mode 100644 Binary files a/_darcs/patches/0000018238-8b063fa0fab2a4a3aa27fe91a2ef6bc5d72b88ba0aac7e41f94b115806c8 and /dev/null differ diff --git a/_darcs/patches/0000036783-1d29937d76c9599242f1c2d9ce139111ef108d4635119e4d74a686950f6d b/_darcs/patches/0000036783-1d29937d76c9599242f1c2d9ce139111ef108d4635119e4d74a686950f6d deleted file mode 100644 Binary files a/_darcs/patches/0000036783-1d29937d76c9599242f1c2d9ce139111ef108d4635119e4d74a686950f6d and /dev/null differ diff --git a/_darcs/patches/0000070374-475515c8f051c8c3f01a02e1bd957749267881da8f7a853a7b9be4efac61 b/_darcs/patches/0000070374-475515c8f051c8c3f01a02e1bd957749267881da8f7a853a7b9be4efac61 deleted file mode 100644 Binary files a/_darcs/patches/0000070374-475515c8f051c8c3f01a02e1bd957749267881da8f7a853a7b9be4efac61 and /dev/null differ diff --git a/_darcs/patches/pending.tentative b/_darcs/patches/pending.tentative deleted file mode 100644 --- a/_darcs/patches/pending.tentative +++ /dev/null @@ -1,2 +0,0 @@ -{ -} diff --git a/_darcs/prefs/binaries b/_darcs/prefs/binaries deleted file mode 100644 --- a/_darcs/prefs/binaries +++ /dev/null @@ -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$ diff --git a/_darcs/prefs/boring b/_darcs/prefs/boring deleted file mode 100644 --- a/_darcs/prefs/boring +++ /dev/null @@ -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$ diff --git a/_darcs/prefs/defaultrepo b/_darcs/prefs/defaultrepo deleted file mode 100644 --- a/_darcs/prefs/defaultrepo +++ /dev/null @@ -1,1 +0,0 @@ -http://patch-tag.com/r/txt-sushi/pullrepo diff --git a/_darcs/prefs/motd b/_darcs/prefs/motd deleted file mode 100644 --- a/_darcs/prefs/motd +++ /dev/null diff --git a/_darcs/prefs/prefs b/_darcs/prefs/prefs deleted file mode 100644 --- a/_darcs/prefs/prefs +++ /dev/null @@ -1,1 +0,0 @@ -boringfile .boring diff --git a/_darcs/prefs/repos b/_darcs/prefs/repos deleted file mode 100644 --- a/_darcs/prefs/repos +++ /dev/null @@ -1,1 +0,0 @@ -http://patch-tag.com/r/txt-sushi/pullrepo diff --git a/_darcs/prefs/sources b/_darcs/prefs/sources deleted file mode 100644 --- a/_darcs/prefs/sources +++ /dev/null @@ -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 diff --git a/_darcs/pristine.hashed/0000000088-2061bfc1d7e7ec5e518faee92edbbe7e4472e558cbae9ce84fc8 b/_darcs/pristine.hashed/0000000088-2061bfc1d7e7ec5e518faee92edbbe7e4472e558cbae9ce84fc8 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000088-2061bfc1d7e7ec5e518faee92edbbe7e4472e558cbae9ce84fc8 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000111-2eb4b905deb944c0862657c882064532176f86535181e46e7bce b/_darcs/pristine.hashed/0000000111-2eb4b905deb944c0862657c882064532176f86535181e46e7bce deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000111-2eb4b905deb944c0862657c882064532176f86535181e46e7bce and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000200-e7e4b45569ce239f362a5c76d649eaf15813287b9030345c7a74 b/_darcs/pristine.hashed/0000000200-e7e4b45569ce239f362a5c76d649eaf15813287b9030345c7a74 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000200-e7e4b45569ce239f362a5c76d649eaf15813287b9030345c7a74 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000286-f5df68519401593190ddd743563beb6fc0323da0bfe27784109a b/_darcs/pristine.hashed/0000000286-f5df68519401593190ddd743563beb6fc0323da0bfe27784109a deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000286-f5df68519401593190ddd743563beb6fc0323da0bfe27784109a and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000291-9f5e432df6f1bc2d706d98e6d03e3863223f8fef6398a859e712 b/_darcs/pristine.hashed/0000000291-9f5e432df6f1bc2d706d98e6d03e3863223f8fef6398a859e712 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000291-9f5e432df6f1bc2d706d98e6d03e3863223f8fef6398a859e712 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000376-5b92e0d16d8aacbf288cedc6ec477ba4cf43017327a542362992 b/_darcs/pristine.hashed/0000000376-5b92e0d16d8aacbf288cedc6ec477ba4cf43017327a542362992 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000376-5b92e0d16d8aacbf288cedc6ec477ba4cf43017327a542362992 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000445-2956c382ba76682981c52ac0b823a1498c3b985f0f0248c0bbac b/_darcs/pristine.hashed/0000000445-2956c382ba76682981c52ac0b823a1498c3b985f0f0248c0bbac deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000445-2956c382ba76682981c52ac0b823a1498c3b985f0f0248c0bbac and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000522-4aceb8d853e003efc12f16b82875a9d151e9263a62d6a523a5cb b/_darcs/pristine.hashed/0000000522-4aceb8d853e003efc12f16b82875a9d151e9263a62d6a523a5cb deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000522-4aceb8d853e003efc12f16b82875a9d151e9263a62d6a523a5cb and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000523-682613113249839d8ce475b8ac48d760a593eb9cba6c07e7f998 b/_darcs/pristine.hashed/0000000523-682613113249839d8ce475b8ac48d760a593eb9cba6c07e7f998 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000523-682613113249839d8ce475b8ac48d760a593eb9cba6c07e7f998 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000608-50982335dfb9bdaf3468db64cc53839e5a552bc928ac9c153459 b/_darcs/pristine.hashed/0000000608-50982335dfb9bdaf3468db64cc53839e5a552bc928ac9c153459 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000608-50982335dfb9bdaf3468db64cc53839e5a552bc928ac9c153459 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000626-7b94f2ad9b5ddaa9d78c1bbbbc1bf24404122c1c9415239316fd b/_darcs/pristine.hashed/0000000626-7b94f2ad9b5ddaa9d78c1bbbbc1bf24404122c1c9415239316fd deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000626-7b94f2ad9b5ddaa9d78c1bbbbc1bf24404122c1c9415239316fd and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000650-4d5fa370e5a998b4346e9c2df2e81ddf09bc6435c0f7dbca0afd b/_darcs/pristine.hashed/0000000650-4d5fa370e5a998b4346e9c2df2e81ddf09bc6435c0f7dbca0afd deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000650-4d5fa370e5a998b4346e9c2df2e81ddf09bc6435c0f7dbca0afd and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000733-b497d395fe2a8d6f42e771045322ae663ac67d81db8ace0eaba4 b/_darcs/pristine.hashed/0000000733-b497d395fe2a8d6f42e771045322ae663ac67d81db8ace0eaba4 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000733-b497d395fe2a8d6f42e771045322ae663ac67d81db8ace0eaba4 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000853-5c22e0c03f2bd51e17dab53bd12d109965be878b6ec35636aa88 b/_darcs/pristine.hashed/0000000853-5c22e0c03f2bd51e17dab53bd12d109965be878b6ec35636aa88 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000853-5c22e0c03f2bd51e17dab53bd12d109965be878b6ec35636aa88 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000854-ca1995790b7158e896bfd840685e52837e55fb75f21f1910f197 b/_darcs/pristine.hashed/0000000854-ca1995790b7158e896bfd840685e52837e55fb75f21f1910f197 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000854-ca1995790b7158e896bfd840685e52837e55fb75f21f1910f197 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000000929-42e83abfbfc514fbce439a61f955f3e73c2676647266dab06da2 b/_darcs/pristine.hashed/0000000929-42e83abfbfc514fbce439a61f955f3e73c2676647266dab06da2 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000000929-42e83abfbfc514fbce439a61f955f3e73c2676647266dab06da2 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001118-0d6474967277971e0f30b93baf1a90e52db1ceb04de1157261b6 b/_darcs/pristine.hashed/0000001118-0d6474967277971e0f30b93baf1a90e52db1ceb04de1157261b6 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001118-0d6474967277971e0f30b93baf1a90e52db1ceb04de1157261b6 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001207-bc201d58790f04a515cdecf786a94812b0b7644b50b76c7f1eed b/_darcs/pristine.hashed/0000001207-bc201d58790f04a515cdecf786a94812b0b7644b50b76c7f1eed deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001207-bc201d58790f04a515cdecf786a94812b0b7644b50b76c7f1eed and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001225-d85bae845f150051981654adb19422822721931022f5efac3dc1 b/_darcs/pristine.hashed/0000001225-d85bae845f150051981654adb19422822721931022f5efac3dc1 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001225-d85bae845f150051981654adb19422822721931022f5efac3dc1 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001352-f4b63f1a6fe106adc86e8b58af29d4a078755ee01322d887f6e1 b/_darcs/pristine.hashed/0000001352-f4b63f1a6fe106adc86e8b58af29d4a078755ee01322d887f6e1 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001352-f4b63f1a6fe106adc86e8b58af29d4a078755ee01322d887f6e1 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001382-0fe562a03070b1c03130d81917674ad6b950cc0ce9f314731994 b/_darcs/pristine.hashed/0000001382-0fe562a03070b1c03130d81917674ad6b950cc0ce9f314731994 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001382-0fe562a03070b1c03130d81917674ad6b950cc0ce9f314731994 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001500-6297c5727d10ee993de16a5b475efb3c35bb0ba9a301a2f2aa23 b/_darcs/pristine.hashed/0000001500-6297c5727d10ee993de16a5b475efb3c35bb0ba9a301a2f2aa23 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001500-6297c5727d10ee993de16a5b475efb3c35bb0ba9a301a2f2aa23 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f0780 b/_darcs/pristine.hashed/0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f0780 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f0780 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000001710-9ede27ebfdd59187303a5aae1b2cda57b3e2284b295d6d24e850 b/_darcs/pristine.hashed/0000001710-9ede27ebfdd59187303a5aae1b2cda57b3e2284b295d6d24e850 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000001710-9ede27ebfdd59187303a5aae1b2cda57b3e2284b295d6d24e850 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000002042-31f05b2de17e2cafc6e292556cad02125548830edbf55da03032 b/_darcs/pristine.hashed/0000002042-31f05b2de17e2cafc6e292556cad02125548830edbf55da03032 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000002042-31f05b2de17e2cafc6e292556cad02125548830edbf55da03032 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000002342-06e125d86b412c96aeb7f856ff7bdaf7d8e70f455499fbf8d834 b/_darcs/pristine.hashed/0000002342-06e125d86b412c96aeb7f856ff7bdaf7d8e70f455499fbf8d834 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000002342-06e125d86b412c96aeb7f856ff7bdaf7d8e70f455499fbf8d834 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000004451-04d981a18f7e94e1461cb7235d19608ce25b741ed9085fe5b9c9 b/_darcs/pristine.hashed/0000004451-04d981a18f7e94e1461cb7235d19608ce25b741ed9085fe5b9c9 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000004451-04d981a18f7e94e1461cb7235d19608ce25b741ed9085fe5b9c9 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000004624-52cac272f443c622f640299a179e984932582f60479117a477c8 b/_darcs/pristine.hashed/0000004624-52cac272f443c622f640299a179e984932582f60479117a477c8 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000004624-52cac272f443c622f640299a179e984932582f60479117a477c8 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000006425-16c0f4848f8e361361d200395b98d895385e5f90f61a636b7432 b/_darcs/pristine.hashed/0000006425-16c0f4848f8e361361d200395b98d895385e5f90f61a636b7432 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000006425-16c0f4848f8e361361d200395b98d895385e5f90f61a636b7432 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000007422-d76d386b471ecbf7126236116e30d46a193a39f5eee11c93086a b/_darcs/pristine.hashed/0000007422-d76d386b471ecbf7126236116e30d46a193a39f5eee11c93086a deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000007422-d76d386b471ecbf7126236116e30d46a193a39f5eee11c93086a and /dev/null differ diff --git a/_darcs/pristine.hashed/0000007530-baac5ef4de73ccb7c3a3c5ed104932bbc7d99c5c332b16df3b39 b/_darcs/pristine.hashed/0000007530-baac5ef4de73ccb7c3a3c5ed104932bbc7d99c5c332b16df3b39 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000007530-baac5ef4de73ccb7c3a3c5ed104932bbc7d99c5c332b16df3b39 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000012267-af3a69b0dc65220116215bbf886f1c42a112640b3ecce2b454ad b/_darcs/pristine.hashed/0000012267-af3a69b0dc65220116215bbf886f1c42a112640b3ecce2b454ad deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000012267-af3a69b0dc65220116215bbf886f1c42a112640b3ecce2b454ad and /dev/null differ diff --git a/_darcs/pristine.hashed/0000018571-53e87b4f3da210d9ce301522df0cb4217ef69efa54424246ffc3 b/_darcs/pristine.hashed/0000018571-53e87b4f3da210d9ce301522df0cb4217ef69efa54424246ffc3 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000018571-53e87b4f3da210d9ce301522df0cb4217ef69efa54424246ffc3 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000025902-7e39012f7884c9eaae8c5462329524b9cc60eb55b77abd12f411 b/_darcs/pristine.hashed/0000025902-7e39012f7884c9eaae8c5462329524b9cc60eb55b77abd12f411 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000025902-7e39012f7884c9eaae8c5462329524b9cc60eb55b77abd12f411 and /dev/null differ diff --git a/_darcs/pristine.hashed/0000035147-8ceb4b9ee5adedde47b31e975c1d90c73ad27b6b165a1dcd80c7 b/_darcs/pristine.hashed/0000035147-8ceb4b9ee5adedde47b31e975c1d90c73ad27b6b165a1dcd80c7 deleted file mode 100644 Binary files a/_darcs/pristine.hashed/0000035147-8ceb4b9ee5adedde47b31e975c1d90c73ad27b6b165a1dcd80c7 and /dev/null differ diff --git a/_darcs/pristine.hashed/da39a3ee5e6b4b0d3255bfef95601890afd80709 b/_darcs/pristine.hashed/da39a3ee5e6b4b0d3255bfef95601890afd80709 deleted file mode 100644 --- a/_darcs/pristine.hashed/da39a3ee5e6b4b0d3255bfef95601890afd80709 +++ /dev/null diff --git a/_darcs/tentative_hashed_inventory b/_darcs/tentative_hashed_inventory deleted file mode 100644 --- a/_darcs/tentative_hashed_inventory +++ /dev/null @@ -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 diff --git a/_darcs/tentative_pristine b/_darcs/tentative_pristine deleted file mode 100644 --- a/_darcs/tentative_pristine +++ /dev/null @@ -1,1 +0,0 @@ -pristine:0000001506-5eac01f7311f45389d1fc10325ff7b83a4cdd71d1532f04f07800936c5acb260 diff --git a/csvtopretty.hs b/csvtopretty.hs --- a/csvtopretty.hs +++ b/csvtopretty.hs @@ -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 diff --git a/csvtotab.hs b/csvtotab.hs --- a/csvtotab.hs +++ b/csvtotab.hs @@ -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 diff --git a/examples/create-view-metricstats.bash b/examples/create-view-metricstats.bash deleted file mode 100644 --- a/examples/create-view-metricstats.bash +++ /dev/null @@ -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 diff --git a/examples/example1.csv b/examples/example1.csv deleted file mode 100644 --- a/examples/example1.csv +++ /dev/null @@ -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" diff --git a/examples/example2.csv b/examples/example2.csv deleted file mode 100644 --- a/examples/example2.csv +++ /dev/null @@ -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" diff --git a/examples/join-stats-station.bash b/examples/join-stats-station.bash deleted file mode 100644 --- a/examples/join-stats-station.bash +++ /dev/null @@ -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 - diff --git a/examples/kitchen-sink.bash b/examples/kitchen-sink.bash deleted file mode 100644 --- a/examples/kitchen-sink.bash +++ /dev/null @@ -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 - diff --git a/examples/query-imputed-SNPs-regex.bash b/examples/query-imputed-SNPs-regex.bash deleted file mode 100644 --- a/examples/query-imputed-SNPs-regex.bash +++ /dev/null @@ -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 - diff --git a/examples/query-imputed-SNPs.bash b/examples/query-imputed-SNPs.bash deleted file mode 100644 --- a/examples/query-imputed-SNPs.bash +++ /dev/null @@ -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 - diff --git a/examples/query-mgi-markers.bash b/examples/query-mgi-markers.bash deleted file mode 100644 --- a/examples/query-mgi-markers.bash +++ /dev/null @@ -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 - diff --git a/examples/select-station.bash b/examples/select-station.bash deleted file mode 100644 --- a/examples/select-station.bash +++ /dev/null @@ -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 - diff --git a/examples/station.csv b/examples/station.csv deleted file mode 100644 --- a/examples/station.csv +++ /dev/null @@ -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 diff --git a/examples/stats.csv b/examples/stats.csv deleted file mode 100644 --- a/examples/stats.csv +++ /dev/null @@ -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 diff --git a/joincol.hs b/joincol.hs deleted file mode 100644 --- a/joincol.hs +++ /dev/null @@ -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 () diff --git a/namecolumns.hs b/namecolumns.hs new file mode 100644 --- /dev/null +++ b/namecolumns.hs @@ -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 diff --git a/selectcol.hs b/selectcol.hs deleted file mode 100644 --- a/selectcol.hs +++ /dev/null @@ -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 () diff --git a/selectcolname.hs b/selectcolname.hs deleted file mode 100644 --- a/selectcolname.hs +++ /dev/null @@ -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 () diff --git a/sortcol.hs b/sortcol.hs deleted file mode 100644 --- a/sortcol.hs +++ /dev/null @@ -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 () diff --git a/tabtocsv.hs b/tabtocsv.hs --- a/tabtocsv.hs +++ b/tabtocsv.hs @@ -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 diff --git a/tabtopretty.hs b/tabtopretty.hs --- a/tabtopretty.hs +++ b/tabtopretty.hs @@ -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 diff --git a/tssql.hs b/tssql.hs --- a/tssql.hs +++ b/tssql.hs @@ -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 diff --git a/txt-sushi.cabal b/txt-sushi.cabal --- a/txt-sushi.cabal +++ b/txt-sushi.cabal @@ -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 . + 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