diff --git a/Database/TxtSushi/CommandLineArgument.hs b/Database/TxtSushi/CommandLineArgument.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/CommandLineArgument.hs @@ -0,0 +1,183 @@ +module Database.TxtSushi.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 + +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 :: String +space = " " + +etc :: String +etc = "..." + +-- | converts a command line description into a string version that +-- you can show the user +formatCommandLine :: CommandLineDescription -> String +formatCommandLine commandLine = + let formattedOptions = formatOptions (options commandLine) + formattedTailArgs = formatTailArguments commandLine + in + if null formattedOptions || null formattedTailArgs then + formattedOptions ++ formattedTailArgs + else + formattedOptions ++ space ++ formattedTailArgs + +formatTailArguments :: CommandLineDescription -> String +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 :: OptionDescription -> String +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:_) = + case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of + Nothing -> + (Map.empty, argValues) + Just optDesc -> + let (optArgs, afterOptArgs) = extractOption optDesc optDescs (tail argValues) + (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs + in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs) + +extractOption :: + OptionDescription -> + [OptionDescription] -> + [String] -> + ([String], [String]) +extractOption optDesc allOptDescs optArgsEtc = + let optArgExtent = argumentExtent optDesc allOptDescs optArgsEtc + in splitAt optArgExtent optArgsEtc + +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 diff --git a/Database/TxtSushi/EvaluatedExpression.hs b/Database/TxtSushi/EvaluatedExpression.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/EvaluatedExpression.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.TxtSushi.EvaluatedExpression +-- Copyright : (c) Keith Sheppard 2009 +-- License : GPL3 or greater +-- Maintainer : keithshep@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- EvaluatedExpression data type along with supporting functions +-- +----------------------------------------------------------------------------- + +module Database.TxtSushi.EvaluatedExpression ( + EvaluatedExpression(..), + realCompare, + intCompare, + boolCompare, + stringCompare, + coerceString, + maybeCoerceInt, + coerceInt, + maybeCoerceReal, + coerceReal, + maybeReadBool, + maybeCoerceBool, + coerceBool) where + +import Data.Char +import Data.List + +import Database.TxtSushi.ParseUtil + +data EvaluatedExpression = + StringExpression String | + RealExpression Double | + IntExpression Int | + BoolExpression Bool deriving Show + +-- order evaluated expressions using our type coercion rules where possible +instance Ord EvaluatedExpression where + compare expr1@(RealExpression _) expr2 = expr1 `realCompare` expr2 + compare expr1 expr2@(RealExpression _) = expr1 `realCompare` expr2 + + compare expr1@(IntExpression _) expr2 = expr1 `intCompare` expr2 + compare expr1 expr2@(IntExpression _) = expr1 `intCompare` expr2 + + compare expr1@(BoolExpression _) expr2 = expr1 `boolCompare` expr2 + compare expr1 expr2@(BoolExpression _) = expr1 `boolCompare` expr2 + + compare expr1 expr2 = expr1 `stringCompare` expr2 + +realCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering +realCompare expr1 expr2 = + maybeCoerceReal expr1 `myCompare` maybeCoerceReal expr2 + where + myCompare (Just r1) (Just r2) = r1 `compare` r2 + myCompare _ _ = expr1 `stringCompare` expr2 + +intCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering +intCompare expr1 expr2 = + maybeCoerceInt expr1 `myCompare` maybeCoerceInt expr2 + where + myCompare (Just i1) (Just i2) = i1 `compare` i2 + myCompare _ _ = expr1 `realCompare` expr2 + +boolCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering +boolCompare expr1 expr2 = + maybeCoerceBool expr1 `myCompare` maybeCoerceBool expr2 + where + myCompare (Just b1) (Just b2) = b1 `compare` b2 + myCompare _ _ = expr1 `stringCompare` expr2 + +stringCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering +stringCompare expr1 expr2 = coerceString expr1 `compare` coerceString expr2 + +-- base equality off of the Ord definition. pretty simple huh? +instance Eq EvaluatedExpression where + expr1 == expr2 = expr1 `compare` expr2 == EQ + +coerceString :: EvaluatedExpression -> String +coerceString (StringExpression string) = string +coerceString (RealExpression real) = show real +coerceString (IntExpression int) = show int +coerceString (BoolExpression bool) = if bool then "true" else "false" + +maybeCoerceInt :: EvaluatedExpression -> Maybe Int +maybeCoerceInt (StringExpression string) = maybeReadInt string +maybeCoerceInt (RealExpression real) = Just $ floor real -- TOOD: floor OK for negatives too? +maybeCoerceInt (IntExpression int) = Just int +maybeCoerceInt (BoolExpression _) = Nothing + +coerceInt :: EvaluatedExpression -> Int +coerceInt evalExpr = case maybeCoerceInt evalExpr of + Just int -> int + Nothing -> + error $ "could not convert \"" ++ (coerceString evalExpr) ++ + "\" to an integer value" + +maybeCoerceReal :: EvaluatedExpression -> Maybe Double +maybeCoerceReal (StringExpression string) = maybeReadReal string +maybeCoerceReal (RealExpression real) = Just real +maybeCoerceReal (IntExpression int) = Just $ fromIntegral int +maybeCoerceReal (BoolExpression _) = Nothing + +coerceReal :: EvaluatedExpression -> Double +coerceReal evalExpr = case maybeCoerceReal evalExpr of + Just real -> real + Nothing -> + error $ "could not convert \"" ++ (coerceString evalExpr) ++ + "\" to a numeric value" + +maybeReadBool :: String -> Maybe Bool +maybeReadBool boolStr = case map toLower $ trimSpace boolStr of + "true" -> Just True + "false" -> Just False + _ -> Nothing + where + -- trims leading and trailing spaces + trimSpace :: String -> String + trimSpace = f . f + where f = reverse . dropWhile isSpace + +maybeCoerceBool :: EvaluatedExpression -> Maybe Bool +maybeCoerceBool (StringExpression string) = maybeReadBool string +maybeCoerceBool (RealExpression _) = Nothing +maybeCoerceBool (IntExpression _) = Nothing +maybeCoerceBool (BoolExpression bool) = Just bool + +coerceBool :: EvaluatedExpression -> Bool +coerceBool evalExpr = case maybeCoerceBool evalExpr of + Just bool -> bool + Nothing -> + error $ "could not convert \"" ++ (coerceString evalExpr) ++ + "\" to a boolean value" diff --git a/Database/TxtSushi/FlatFile.hs b/Database/TxtSushi/FlatFile.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/FlatFile.hs @@ -0,0 +1,233 @@ +{- | +The 'FlatFile' module is for reading misc. 'FlatFile' formats like CSV or +tab delimited +-} +module Database.TxtSushi.FlatFile ( + formatTableWithWidths, + maxTableColumnWidths, + formatTable, + parseTable, + Format(Format), + csvFormat, + tabDelimitedFormat, + doubleQuote) where + +import Data.Function +import Data.List + +{- | +'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, + rowDelimiters :: [String]} deriving (Show) + +defaultRowDelimiter :: Format -> String +defaultRowDelimiter = head . rowDelimiters + +csvFormat :: Format +csvFormat = Format "\"" "," ["\n", "\r", "\n\r", "\r\n"] + +tabDelimitedFormat :: Format +tabDelimitedFormat = Format "\"" "\t" ["\n", "\r", "\n\r", "\r\n"] + +{- | +get a quote escape sequence for the given 'Format' +-} +doubleQuote :: Format -> String +doubleQuote format = (quote format) ++ (quote format) + +formatTableWithWidths :: String -> [Int] -> [[String]] -> String +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 :: [a] -> Bool +seqList [] = False +seqList (x:xt) + | x `seq` False = undefined + | otherwise = seqList xt + +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) ++ (defaultRowDelimiter 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 -> String -> String +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 any (`isInfixOf` field) (rowDelimiters format) || + (fieldDelimiter format) `isInfixOf` field then + (quote format) ++ field ++ (quote format) + else + field + +{- +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) + +{- | +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 format text = go text + where + -- sorting the delimiters from shortest to longest allows us to + -- guarantee that we don't mistake a multi-char newline as two single + -- char newlines. The code in parseUnquotedField works on this + -- assumption + newFormat = format { + rowDelimiters = sortBy (compare `on` negate . length) (rowDelimiters format)} + + go "" = [] + go txt = + let (nextLine, remainingText) = parseLine newFormat txt + in nextLine : go 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) + + else case findIndex (`isPrefixOf` text) (rowDelimiters format) of + + Nothing -> + -- just another character... toss it in the field and keep going + let (fieldTail, moreFieldsInRow, remainingText) = parseUnquotedField format textTail + in (textHead:fieldTail, moreFieldsInRow, remainingText) + + Just delimIndex -> + -- if we hit a row delimiter: return an empty string and let caller know there + -- are no more fields in this row + let tailOfDelimiter = drop (length (rowDelimiters format !! delimIndex)) text + in ([], False, tailOfDelimiter) diff --git a/Database/TxtSushi/IO.hs b/Database/TxtSushi/IO.hs deleted file mode 100644 --- a/Database/TxtSushi/IO.hs +++ /dev/null @@ -1,206 +0,0 @@ -{- | -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 -csvFormat = Format "\"" "," "\n" - -tabDelimitedFormat :: Format -tabDelimitedFormat = Format "\"" "\t" "\n" - -{- | -get a quote escape sequence for the given 'Format' --} -doubleQuote :: Format -> String -doubleQuote format = (quote format) ++ (quote format) - -formatTableWithWidths :: String -> [Int] -> [[String]] -> String -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 :: [a] -> Bool -seqList [] = False -seqList (x:xt) - | x `seq` False = undefined - | otherwise = seqList xt - -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 -> String -> String -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/IOUtil.hs b/Database/TxtSushi/IOUtil.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/IOUtil.hs @@ -0,0 +1,41 @@ +module Database.TxtSushi.IOUtil ( + bufferStdioToTempFile, + getContentsFromFileOrStdin, + printSingleFileUsage) where + +import Data.List +import Data.Version (Version(..)) +import System.Directory +import System.Environment +import System.IO + +import Paths_txt_sushi + +-- | buffers standard input to a temp file and returns a path to that file +bufferStdioToTempFile :: IO FilePath +bufferStdioToTempFile = do + stdioText <- getContents + tempDir <- getTemporaryDirectory + (tempFilePath, tempFileHandle) <- openTempFile tempDir "stdiobuffer.txt" + hPutStr tempFileHandle stdioText + hClose tempFileHandle + return tempFilePath + +-- | if given "-" this file reads from stdin otherwise it reads from the named +-- file +getContentsFromFileOrStdin :: String -> IO String +getContentsFromFileOrStdin filePath = + if filePath == "-" + then getContents + else readFile filePath + +-- | print a cookie-cutter usage message for the command line utilities +-- that take a single file name or "-" as input +printSingleFileUsage :: IO () +printSingleFileUsage = do + progName <- getProgName + putStrLn $ progName ++ " (" ++ versionStr ++ ")" + putStrLn $ "Usage: " ++ progName ++ " file_name_or_dash" + + where + versionStr = intercalate "." (map show . versionBranch $ version) diff --git a/Database/TxtSushi/ParseUtil.hs b/Database/TxtSushi/ParseUtil.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/ParseUtil.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.TxtSushi.ParseUtil +-- Copyright : (c) Keith Sheppard 2009 +-- License : GPL3 or greater +-- Maintainer : keithshep@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Parse utility functions +-- +----------------------------------------------------------------------------- + +module Database.TxtSushi.ParseUtil ( + parseInt, + maybeReadInt, + maybeReadReal, + parseReal, + withoutTrailing, + withTrailing, + eatSpacesAfter, + quotedText, + escapedQuote, + ifParseThen, + preservingIfParseThen, + ifParseThenElse, + genExcept, + genNotFollowedBy, + maybeParse, + sepByExactly, + sepByAtLeast) where + +import Text.ParserCombinators.Parsec + +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 + +parseReal :: GenParser Char st Double +parseReal = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do + realTxt <- anyParseTxt "real" + return $ read realTxt + where + anyParseTxt = do + txtWithoutExp <- txtWithoutExponent + expPart <- try exponentPart <|> return "" + return $ txtWithoutExp ++ expPart + exponentPart = do + e <- (char 'e' <|> char 'E') + negPart <- (char '-' >> return "-") <|> return "" + numPart <- many1 digit + return $ (e:negPart) ++ numPart + txtWithoutExponent = signedTxt <|> unsignedTxt "real" + unsignedTxt = do + intTxt <- many1 digit + char '.' + fracTxt <- many1 digit + return $ intTxt ++ "." ++ fracTxt + signedTxt = do + char '-' + unsignedDigitTxt <- unsignedTxt + return ('-':unsignedDigitTxt) + +withoutTrailing :: (Show s) => GenParser tok st s -> GenParser tok st a -> GenParser tok st a +withoutTrailing end p = p >>= (\x -> genNotFollowedBy end >> return x) + +withTrailing :: (Monad m) => m a -> m b -> m b +withTrailing end p = p >>= (\x -> end >> return x) + +-- | like the lexeme function, this function eats all spaces after the given +-- parser, but this one works for me and lexeme doesn't +eatSpacesAfter :: GenParser Char st a -> GenParser Char st a +eatSpacesAfter p = p >>= (\x -> spaces >> return x) + +-- | quoted text which allows escaping by doubling the quote char +-- like \"escaped quote char here:\"\"\" +quotedText :: Bool -> Char -> GenParser Char st String +quotedText allowEmpty quoteChar = do + let quote = char quoteChar + manyFunc = if allowEmpty then many else many1 + + quote + textValue <- manyFunc $ (anyChar `genExcept` quote) <|> + try (escapedQuote quoteChar) + quote + spaces + + return textValue + +escapedQuote :: Char -> GenParser Char st Char +escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar + +{- +-- | 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 = + (try leftParser >>= return . Left) <|> (rightParser >>= return . Right) +-} + +-- | 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 = fmap (fmap snd) . preservingIfParseThen ifParse + +-- | if the preservingIfParseThen is basically the same as ifParse except that +-- the if result is preserved in the first part of the tuple +preservingIfParseThen :: GenParser tok st a -> GenParser tok st b -> GenParser tok st (Maybe (a, b)) +preservingIfParseThen ifParse thenPart = do + ifResult <- maybeParse ifParse + case ifResult of + Just x -> thenPart >>= (\y -> return $ Just (x, y)) + 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 + +-- | 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 >>= return . Just) <|> return Nothing + +-- | parse `itemParser`s seperated by exactly `minCount` `sepParser`s +sepByExactly :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] +sepByExactly itemCount itemParser sepParser = + let itemParsers = replicate itemCount 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 0 itemParser sepParser = sepBy itemParser sepParser +sepByAtLeast minCount itemParser sepParser = do + minResults <- sepByExactly minCount itemParser sepParser + tailResults <- + ifParseThenElse sepParser (sepBy itemParser sepParser) (return []) + + return $ minResults ++ tailResults diff --git a/Database/TxtSushi/Relational.hs b/Database/TxtSushi/Relational.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/Relational.hs @@ -0,0 +1,76 @@ +{- | +Simple table transformations +-} +module Database.TxtSushi.Relational ( + joinTables, + crossJoinTables, + joinPresortedTables) where + +import Data.List +import Data.Function + +-- | join together two tables on the given column index pairs +joinTables :: (Ord o) => + (a -> o) + -> [a] + -> (b -> o) + -> [b] + -> [(a, b)] +joinTables joinOrdFunc1 table1 joinOrdFunc2 table2 = + let + sortedTable1 = sortBy (compare `on` joinOrdFunc1) table1 + sortedTable2 = sortBy (compare `on` joinOrdFunc2) table2 + in + joinPresortedTables joinOrdFunc1 sortedTable1 joinOrdFunc2 sortedTable2 + +-- | join together two tables that are presorted on the given column index pairs +joinPresortedTables :: (Ord o) => + (a -> o) + -> [a] + -> (b -> o) + -> [b] + -> [(a, b)] +joinPresortedTables joinOrdFunc1 sortedTable1 joinOrdFunc2 sortedTable2 = + let + tableGroups1 = groupBy rowEq1 sortedTable1 + tableGroups2 = groupBy rowEq2 sortedTable2 + in + joinGroupedTables joinOrdFunc1 tableGroups1 joinOrdFunc2 tableGroups2 + where + rowEq1 x y = (compare `on` joinOrdFunc1) x y == EQ + rowEq2 x y = (compare `on` joinOrdFunc2) x y == EQ + +crossJoinTables :: [a] -> [b] -> [(a, b)] +crossJoinTables [] _ = [] +crossJoinTables _ [] = [] +crossJoinTables (table1Head:table1Tail) table2 = + map (\x -> (table1Head, x)) table2 ++ (crossJoinTables table1Tail table2) + +joinGroupedTables :: (Ord o) => + (a -> o) + -> [[a]] + -> (b -> o) + -> [[b]] + -> [(a, b)] +joinGroupedTables _ [] _ _ = [] +joinGroupedTables _ _ _ [] = [] +joinGroupedTables + joinOrdFunc1 + tableGroups1@(headTableGroup1:tableGroupsTail1) + joinOrdFunc2 + tableGroups2@(headTableGroup2:tableGroupsTail2) = + let + headRow1 = head headTableGroup1 + headRow2 = head headTableGroup2 + in + case joinOrdFunc1 headRow1 `compare` joinOrdFunc2 headRow2 of + -- drop the 1st group if its smaller + LT -> joinGroupedTables joinOrdFunc1 tableGroupsTail1 joinOrdFunc2 tableGroups2 + + -- drop the 2nd group if its smaller + GT -> joinGroupedTables joinOrdFunc1 tableGroups1 joinOrdFunc2 tableGroupsTail2 + + -- the two groups are equal so permute + _ -> + (crossJoinTables headTableGroup1 headTableGroup2) ++ + (joinGroupedTables joinOrdFunc1 tableGroupsTail1 joinOrdFunc2 tableGroupsTail2) diff --git a/Database/TxtSushi/SQLExecution.hs b/Database/TxtSushi/SQLExecution.hs --- a/Database/TxtSushi/SQLExecution.hs +++ b/Database/TxtSushi/SQLExecution.hs @@ -11,729 +11,534 @@ -- ----------------------------------------------------------------------------- -module Database.TxtSushi.SQLExecution ( - select, - databaseTableToTextTable, - textTableToDatabaseTable, - SortConfiguration(..)) where - -import Data.Binary -import Data.Char -import Data.List -import qualified Data.Map as Map -import Text.Regex.Posix - -import Database.TxtSushi.ExternalSort -import Database.TxtSushi.SQLParser -import Database.TxtSushi.Transform -import Database.TxtSushi.Util.ListUtil - --- | We will use the sort configuration to determine whether tables should --- be sorted external or in memory -data SortConfiguration = - UseInMemorySort | - UseExternalSort deriving Show - -sortByCfg :: (Binary b) => SortConfiguration -> (b -> b -> Ordering) -> [b] -> [b] -sortByCfg UseInMemorySort = sortBy -sortByCfg UseExternalSort = externalSortBy - --- | an SQL table data structure --- TODO: need allColumnsColumnIdentifiers and allColumnsTableRows so that --- we can filter and order on columns that are selected out. we also --- should track any column ordering that is in place -data DatabaseTable = DatabaseTable { - -- | the columns in this table - columnIdentifiers :: [ColumnIdentifier], - - -- | the actual table data - tableRows :: [[EvaluatedExpression]]} - -data GroupedTable = GroupedTable { - groupColumnIdentifiers :: [ColumnIdentifier], - tableGroups :: [[[EvaluatedExpression]]]} - -data EvaluatedExpression = - StringExpression String | - RealExpression Double | - IntExpression Int | - BoolExpression Bool deriving Show - --- order evaluated expressions using our type coercion rules where possible -instance Ord EvaluatedExpression where - compare expr1@(RealExpression _) expr2 = expr1 `realCompare` expr2 - compare expr1 expr2@(RealExpression _) = expr1 `realCompare` expr2 - - compare expr1@(IntExpression _) expr2 = expr1 `intCompare` expr2 - compare expr1 expr2@(IntExpression _) = expr1 `intCompare` expr2 - - compare expr1@(BoolExpression _) expr2 = expr1 `boolCompare` expr2 - compare expr1 expr2@(BoolExpression _) = expr1 `boolCompare` expr2 - - compare expr1 expr2 = expr1 `stringCompare` expr2 - -realCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering -realCompare expr1 expr2 = - maybeCoerceReal expr1 `myCompare` maybeCoerceReal expr2 - where - myCompare (Just r1) (Just r2) = r1 `compare` r2 - myCompare _ _ = expr1 `stringCompare` expr2 - -intCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering -intCompare expr1 expr2 = - maybeCoerceInt expr1 `myCompare` maybeCoerceInt expr2 - where - myCompare (Just i1) (Just i2) = i1 `compare` i2 - myCompare _ _ = expr1 `realCompare` expr2 - -boolCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering -boolCompare expr1 expr2 = - maybeCoerceBool expr1 `myCompare` maybeCoerceBool expr2 - where - myCompare (Just b1) (Just b2) = b1 `compare` b2 - myCompare _ _ = expr1 `stringCompare` expr2 - -stringCompare :: EvaluatedExpression -> EvaluatedExpression -> Ordering -stringCompare expr1 expr2 = coerceString expr1 `compare` coerceString expr2 - --- base equality off of the Ord definition. pretty simple huh? -instance Eq EvaluatedExpression where - expr1 == expr2 = expr1 `compare` expr2 == EQ - -instance Binary EvaluatedExpression where - put (StringExpression s) = put (0 :: Word8) >> put s - put (RealExpression r) = put (1 :: Word8) >> put r - put (IntExpression i) = put (2 :: Word8) >> put i - put (BoolExpression b) = put (3 :: Word8) >> put b - - get = do - typeWord <- get :: Get Word8 - case typeWord of - 0 -> get >>= return . StringExpression - 1 -> get >>= return . RealExpression - 2 -> get >>= return . IntExpression - 3 -> get >>= return . BoolExpression - _ -> error $ "unexpected type word value: " ++ show typeWord - -coerceString :: EvaluatedExpression -> String -coerceString (StringExpression string) = string -coerceString (RealExpression real) = show real -coerceString (IntExpression int) = show int -coerceString (BoolExpression bool) = if bool then "true" else "false" - -maybeCoerceInt :: EvaluatedExpression -> Maybe Int -maybeCoerceInt (StringExpression string) = maybeReadInt string -maybeCoerceInt (RealExpression real) = Just $ floor real -- TOOD: floor OK for negatives too? -maybeCoerceInt (IntExpression int) = Just int -maybeCoerceInt (BoolExpression _) = Nothing - -coerceInt :: EvaluatedExpression -> Int -coerceInt evalExpr = case maybeCoerceInt evalExpr of - Just int -> int - Nothing -> - error $ "could not convert \"" ++ (coerceString evalExpr) ++ - "\" to an integer value" - -maybeCoerceReal :: EvaluatedExpression -> Maybe Double -maybeCoerceReal (StringExpression string) = maybeReadReal string -maybeCoerceReal (RealExpression real) = Just real -maybeCoerceReal (IntExpression int) = Just $ fromIntegral int -maybeCoerceReal (BoolExpression _) = Nothing - -coerceReal :: EvaluatedExpression -> Double -coerceReal evalExpr = case maybeCoerceReal evalExpr of - Just real -> real - Nothing -> - error $ "could not convert \"" ++ (coerceString evalExpr) ++ - "\" to a numeric value" - -maybeReadBool :: String -> Maybe Bool -maybeReadBool boolStr = case map toLower $ trimSpace boolStr of - "true" -> Just True - "false" -> Just False - _ -> Nothing - -maybeCoerceBool :: EvaluatedExpression -> Maybe Bool -maybeCoerceBool (StringExpression string) = maybeReadBool string -maybeCoerceBool (RealExpression _) = Nothing -maybeCoerceBool (IntExpression _) = Nothing -maybeCoerceBool (BoolExpression bool) = Just bool - -coerceBool :: EvaluatedExpression -> Bool -coerceBool evalExpr = case maybeCoerceBool evalExpr of - Just bool -> bool - Nothing -> - error $ "could not convert \"" ++ (coerceString evalExpr) ++ - "\" to a boolean value" - --- convert a text table to a database table by using the 1st row as column IDs -textTableToDatabaseTable :: String -> [[String]] -> DatabaseTable -textTableToDatabaseTable tblName (headerNames:tblRows) = - DatabaseTable (map makeColId headerNames) (map (map StringExpression) tblRows) - where - makeColId colName = ColumnIdentifier (Just tblName) colName -textTableToDatabaseTable tblName [] = - error $ "invalid table \"" ++ tblName ++ "\". There is no header row" - -databaseTableToTextTable :: DatabaseTable -> [[String]] -databaseTableToTextTable dbTable = - let - headerRow = map columnId (columnIdentifiers dbTable) - tailRows = map (map coerceString) (tableRows dbTable) - in - headerRow:tailRows - -{- -optimizeClassicJoins :: SelectStatement -> SelectStatement -optimizeClassicJoins selectStmt@(SelectStatement _ (Just fromTbl) (Just whereFilter) _ _) = - let (optFromTbl, optMaybeWhereFilter) = optimizeFromWhere Nothing fromTbl whereFilter - in selectStmt { - maybeFromTable = Just optFromTbl, - maybeWhereFilter = optMaybeWhereFilter} -optimizeClassicJoins selectStmt = selectStmt - -optimizeFromWhere :: Maybe String -> TableExpression -> Maybe Expression -> (TableExpression, Maybe Expression) -optimizeFromWhere maybeParentAlias _ Nothing = - (fromTbl, Just expr) -optimizeFromWhere maybeParentAlias fromTbl@(InnerJoin leftJoinTbl rightJoinTbl _ maybeChildAlias) (Just expr) = - let - maybeAlias = case maybeParentAlias of - Nothing -> maybeChildAlias - Just - -> maybeParentAlias - (optLeftTbl, expr2) = optimizeFromWhere maybeAlias leftJoinTbl expr - (optRightTbl, expr3) = optimizeFromWhere maybeAlias rightJoinTbl expr2 - optFromTbl = fromTbl { - leftJoinTable, - rightJoinTable} - in - (optFromTbl, Just expr3) --} - --- | perform a SQL select with the given select statement on the --- given table map -select :: SortConfiguration -> SelectStatement -> (Map.Map String DatabaseTable) -> DatabaseTable -select sortCfg selectStmt tableMap = - let - fromTbl = case maybeFromTable selectStmt of - Nothing -> DatabaseTable [] [] - Just fromTblExpr -> evalTableExpression sortCfg fromTblExpr tableMap - fromTblWithAliases = - appendAliasColumns (columnSelections selectStmt) fromTbl - filteredTbl = case maybeWhereFilter selectStmt of - Nothing -> fromTblWithAliases - Just expr -> filterRowsBy expr fromTblWithAliases - in - case maybeGroupByHaving selectStmt of - Nothing -> - if selectStatementContainsAggregates selectStmt then - -- for the case where we find aggregate functions but - -- no "GROUP BY" part, that means we should apply the - -- aggregate to the table as a single group - finishWithAggregateSelect - sortCfg - selectStmt - (GroupedTable (columnIdentifiers filteredTbl) [tableRows filteredTbl]) - else - finishWithNormalSelect sortCfg selectStmt filteredTbl - Just groupByPart -> - let - tblGroups = performGroupBy sortCfg groupByPart filteredTbl - in - finishWithAggregateSelect sortCfg selectStmt tblGroups - --- TODO this approach wont let you refer to an alias in the column selection -appendAliasColumns :: [ColumnSelection] -> DatabaseTable -> DatabaseTable -appendAliasColumns [] dbTable = dbTable -appendAliasColumns cols dbTable@(DatabaseTable colIds tblRows) = - let colAliasExprs = extractColumnAliases cols - -- TODO which is the right fold here? - evaluatedColExprsTbl = foldl1' tableConcat (evalAliasCols colAliasExprs) - in - if null colAliasExprs - then dbTable - else dbTable `tableConcat` evaluatedColExprsTbl - where - evalAliasCols :: [(ColumnIdentifier, Expression)] -> [DatabaseTable] - evalAliasCols [] = [] - evalAliasCols ((aliasColId, aliasExpr) : tailAliasExprs) = - DatabaseTable [aliasColId] [[evalExpression aliasExpr colIds row] | row <- tblRows] : - evalAliasCols tailAliasExprs - -extractColumnAliases :: [ColumnSelection] -> [(ColumnIdentifier, Expression)] -extractColumnAliases [] = [] -extractColumnAliases ((ExpressionColumn expr (Just alias)) : colsTail) = - (ColumnIdentifier Nothing alias, expr) : extractColumnAliases colsTail -extractColumnAliases xs = extractColumnAliases $ tail xs - -finishWithNormalSelect :: SortConfiguration -> SelectStatement -> DatabaseTable -> DatabaseTable -finishWithNormalSelect sortCfg selectStmt filteredDbTable = - let - orderedTbl = - orderRowsBy sortCfg (orderByItems selectStmt) filteredDbTable - selectedTbl = - evaluateColumnSelections (columnSelections selectStmt) orderedTbl - in - selectedTbl - -finishWithAggregateSelect :: SortConfiguration -> SelectStatement -> GroupedTable -> DatabaseTable -finishWithAggregateSelect sortCfg selectStmt aggregateTbls = - let - orderedTbls = - orderGroupsBy sortCfg (orderByItems selectStmt) aggregateTbls - selectedTbl = - evaluateAggregateColumnSelections (columnSelections selectStmt) orderedTbls - in - selectedTbl - -performGroupBy :: SortConfiguration -> ([Expression], Maybe Expression) -> DatabaseTable -> GroupedTable -performGroupBy sortCfg (groupByExprs, maybeExpr) dbTable = - let - tblGroups = groupRowsBy sortCfg groupByExprs dbTable - in - case maybeExpr of - Nothing -> tblGroups - Just expr -> filterGroupsBy expr tblGroups - --- | sorts table rows by the given order by items -orderRowsBy :: SortConfiguration -> [OrderByItem] -> DatabaseTable -> DatabaseTable -orderRowsBy _ [] dbTable = dbTable -orderRowsBy sortCfg orderBys dbTable = - let - -- curry in the order and col ID params to make a row comparison function - compareRows = compareRowsOnOrderItems orderBys (columnIdentifiers dbTable) - sortedRows = sortByCfg sortCfg compareRows (tableRows dbTable) - in - dbTable {tableRows = sortedRows} - -orderGroupsBy :: SortConfiguration -> [OrderByItem] -> GroupedTable -> GroupedTable -orderGroupsBy _ [] groupedTable = groupedTable -orderGroupsBy sortCfg orderBys groupedTable = - let - -- curry in the order and col ID params to make a group comparison function - compareGroups = compareGroupsOnOrderItems orderBys (groupColumnIdentifiers groupedTable) - sortedGroups = sortByCfg sortCfg compareGroups (tableGroups groupedTable) - in - groupedTable {tableGroups = sortedGroups} - --- | Compares two rows using the given OrderByItems and column ID's -compareRowsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering -compareRowsOnOrderItems orderBys colIds row1 row2 = - cascadingOrder $ toOrderList orderBys - where - toOrderList [] = [] - toOrderList (orderBy:orderByTail) = - (compareRowsOnOrderItem orderBy colIds row1 row2):(toOrderList orderByTail) - --- | Compares two rows using the given OrderByItem and column ID's -compareRowsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering -compareRowsOnOrderItem orderBy colIds row1 row2 = - let - orderExpr = orderExpression orderBy - rowComp = compareRowsOnExpression orderExpr colIds row1 row2 - in - if orderAscending orderBy then - rowComp - else - reverseOrdering rowComp - -compareGroupsOnOrderItems :: [OrderByItem] -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering -compareGroupsOnOrderItems orderBys colIds group1 group2 = - cascadingOrder $ toOrderList orderBys - where - toOrderList [] = [] - toOrderList (orderBy:orderByTail) = - (compareGroupsOnOrderItem orderBy colIds group1 group2):(toOrderList orderByTail) - -compareGroupsOnOrderItem :: OrderByItem -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering -compareGroupsOnOrderItem orderBy colIds group1 group2 = - let - orderExpr = orderExpression orderBy - grpComp = compareGroupsOnExpression orderExpr colIds group1 group2 - in - if orderAscending orderBy then - grpComp - else - reverseOrdering grpComp - --- | reverses the given ordering. pretty CRAZY huh??? -reverseOrdering :: Ordering -> Ordering -reverseOrdering EQ = EQ -reverseOrdering LT = GT -reverseOrdering GT = LT - --- | Compares two rows using the given expressions -compareRowsOnExpressions :: [Expression] -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering -compareRowsOnExpressions exprs colIds row1 row2 = - cascadingOrder $ toOrderList exprs - where - toOrderList [] = [] - toOrderList (expr:exprTail) = - (compareRowsOnExpression expr colIds row1 row2):(toOrderList exprTail) - --- | Compares two rows using the given expression -compareRowsOnExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> [EvaluatedExpression] -> Ordering -compareRowsOnExpression expr colIds row1 row2 = - let - row1Eval = evalExpression expr colIds row1 - row2Eval = evalExpression expr colIds row2 - in - row1Eval `compare` row2Eval - -compareGroupsOnExpression :: Expression -> [ColumnIdentifier] -> [[EvaluatedExpression]] -> [[EvaluatedExpression]] -> Ordering -compareGroupsOnExpression expr colIds grp1 grp2 = - evalExprOn grp1 `compare` evalExprOn grp2 - where - evalExprOn grp = evalAggregateExpression expr (DatabaseTable colIds grp) - -groupRowsBy :: SortConfiguration -> [Expression] -> DatabaseTable -> GroupedTable -groupRowsBy sortCfg groupByExprs dbTable = - GroupedTable (columnIdentifiers dbTable) rowGroups - where - tblRows = tableRows dbTable - - -- curry in the exprs and col ID params to make a row comparison function - compareRows = compareRowsOnExpressions groupByExprs (columnIdentifiers dbTable) - row1 `rowsEq` row2 = (row1 `compareRows` row2) == EQ - - sortedRows = sortByCfg sortCfg compareRows tblRows - rowGroups = groupBy rowsEq sortedRows - --- | Evaluate the FROM table part, and returns the FROM table. Also returns --- a mapping of new table names from aliases etc. -evalTableExpression :: SortConfiguration -> TableExpression -> (Map.Map String DatabaseTable) -> DatabaseTable -evalTableExpression sortCfg tblExpr tableMap = - case tblExpr of - TableIdentifier tblName maybeTblAlias -> - let - -- find the from table map (error if missing) - noTblError = error $ "failed to find table named " ++ tblName - table = Map.findWithDefault noTblError tblName tableMap - in - maybeRename maybeTblAlias table - - -- TODO inner join should allow joining on expressions too!! - InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias -> - let - leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap - rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap - joinCols = extractJoinCols onConditionExpr - joinIndices = joinColumnIndices leftJoinTbl rightJoinTbl joinCols - joinedTbl = innerJoin joinIndices leftJoinTbl rightJoinTbl - in - maybeRename maybeTblAlias joinedTbl - - SelectExpression selectStmt maybeTblAlias -> - maybeRename maybeTblAlias (select sortCfg selectStmt tableMap) - - -- TODO implement me - CrossJoin leftJoinTblExpr rightJoinTblExpr maybeTblAlias -> - let - leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap - rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap - joinedTbl = crossJoin leftJoinTbl rightJoinTbl - in - maybeRename maybeTblAlias joinedTbl - - where - maybeRename :: (Maybe String) -> DatabaseTable -> DatabaseTable - maybeRename Nothing table = table - maybeRename (Just newName) table = table { - columnIdentifiers = map (\colId -> colId {maybeTableName = Just newName}) (columnIdentifiers table)} - -extractJoinCols :: Expression -> [(ColumnIdentifier, ColumnIdentifier)] -extractJoinCols (FunctionExpression sqlFunc [arg1, arg2]) = - case sqlFunc of - SQLFunction "AND" _ _ -> extractJoinCols arg1 ++ extractJoinCols arg2 - SQLFunction "=" _ _ -> extractJoinColPair arg1 arg2 - - -- Only expecting "AND" or "=" - _ -> onPartFormattingError - where - extractJoinColPair (ColumnExpression col1) (ColumnExpression col2) = [(col1, col2)] - - -- Only expecting "AND" or "=" - extractJoinColPair _ _ = onPartFormattingError - --- Only expecting "AND" or "=" -extractJoinCols _ = onPartFormattingError - -onPartFormattingError :: a -onPartFormattingError = - error $ "The \"ON\" part of a join must only contain column equalities " ++ - "joined together by \"AND\" like: " ++ - "\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\"" - --- | perform an inner join using the given join indices on the given --- tables -innerJoin :: [(Int, Int)] -> DatabaseTable -> DatabaseTable -> DatabaseTable -innerJoin joinIndices leftJoinTbl rightJoinTbl = DatabaseTable { - columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl), - tableRows = joinTables joinIndices (tableRows leftJoinTbl) (tableRows rightJoinTbl)} - --- | perform a cross join using the given join indices on the given --- tables -crossJoin :: DatabaseTable -> DatabaseTable -> DatabaseTable -crossJoin leftJoinTbl rightJoinTbl = DatabaseTable { - columnIdentifiers = (columnIdentifiers leftJoinTbl) ++ (columnIdentifiers rightJoinTbl), - tableRows = crossJoinTables (tableRows leftJoinTbl) (tableRows rightJoinTbl)} - --- | convert the column ID pairs into index pairs -joinColumnIndices :: DatabaseTable -> DatabaseTable -> [(ColumnIdentifier, ColumnIdentifier)] -> [(Int, Int)] -joinColumnIndices leftJoinTbl rightJoinTbl joinCols = - let - leftHeader = columnIdentifiers leftJoinTbl - rightHeader = columnIdentifiers rightJoinTbl - in - map (idPairToIndexPair leftHeader rightHeader) joinCols - --- | convert the column ID pair into an index pair -idPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> (Int, Int) -idPairToIndexPair leftColIds rightColIds joinColPair@(leftColId, rightColId) = - let - maybePairInOrder = maybeIdPairToIndexPair leftColIds rightColIds joinColPair - maybePairSwapped = maybeIdPairToIndexPair leftColIds rightColIds (rightColId, leftColId) - in - case maybePairInOrder of - Just thePairInOrder -> thePairInOrder - Nothing -> - case maybePairSwapped of - Just thePairSwapped -> thePairSwapped - Nothing -> error "failed to find given columns" - -maybeIdPairToIndexPair :: [ColumnIdentifier] -> [ColumnIdentifier] -> (ColumnIdentifier, ColumnIdentifier) -> Maybe (Int, Int) -maybeIdPairToIndexPair leftColIds rightColIds (leftColId, rightColId) = do - leftIndex <- findIndex (== leftColId) leftColIds - rightIndex <- findIndex (== rightColId) rightColIds - return (leftIndex, rightIndex) - -evaluateColumnSelections :: [ColumnSelection] -> DatabaseTable -> DatabaseTable -evaluateColumnSelections colSelections dbTable = - let - selectionTbls = map ($ dbTable) (map evaluateColumnSelection colSelections) - in - foldl1' tableConcat selectionTbls - -tableConcat :: DatabaseTable -> DatabaseTable -> DatabaseTable -tableConcat dbTable1 dbTable2 = - let - concatIds = (columnIdentifiers dbTable1) ++ (columnIdentifiers dbTable2) - concatRows = zipWith (++) (tableRows dbTable1) (tableRows dbTable2) - in - DatabaseTable concatIds concatRows - -evaluateAggregateColumnSelections :: [ColumnSelection] -> GroupedTable -> DatabaseTable -evaluateAggregateColumnSelections colSelections tblGroups = - let - selectionTbls = map ($ tblGroups) (map evaluateAggregateColumnSelection colSelections) - in - foldl1' tableConcat selectionTbls - -evaluateAggregateColumnSelection :: ColumnSelection -> GroupedTable -> DatabaseTable -evaluateAggregateColumnSelection AllColumns _ = - error "* is not allowed for aggregate column selections" -evaluateAggregateColumnSelection (AllColumnsFrom srcTblName) _ = - error $ srcTblName ++ ".* is not allowed for aggregate column selections" -evaluateAggregateColumnSelection (ExpressionColumn expr maybeAlias) groupedTbl = - let - tbls = map makeTbl (tableGroups groupedTbl) - evaluatedExprs = map (evalAggregateExpression expr) tbls - exprColId = case maybeAlias of - Nothing -> expressionIdentifier expr - Just alias -> (expressionIdentifier expr) {columnId = alias} - in - DatabaseTable [exprColId] (transpose [evaluatedExprs]) - where - makeTbl grp = DatabaseTable (groupColumnIdentifiers groupedTbl) grp - -evaluateColumnSelection :: ColumnSelection -> DatabaseTable -> DatabaseTable -evaluateColumnSelection AllColumns dbTable = dbTable -evaluateColumnSelection (AllColumnsFrom srcTblName) dbTable = - let - colIds = columnIdentifiers dbTable - indices = findIndices matchesSrcTblName (map maybeTableName colIds) - selectedColIds = selectIndices indices colIds - selectedColRows = map (selectIndices indices) (tableRows dbTable) - in - DatabaseTable selectedColIds selectedColRows - where - matchesSrcTblName Nothing = False - matchesSrcTblName (Just tblName) = tblName == srcTblName - selectIndices indices xs = [xs !! i | i <- indices] -evaluateColumnSelection (ExpressionColumn expr maybeAlias) dbTable = - let - tblColIds = columnIdentifiers dbTable - exprColId = case maybeAlias of - Nothing -> expressionIdentifier expr - Just alias -> (expressionIdentifier expr) {columnId = alias} - evaluatedExprs = map (evalExpression expr tblColIds) (tableRows dbTable) - in - DatabaseTable [exprColId] (transpose [evaluatedExprs]) - --- | This is a little different that a strict equals compare in that it returns --- true if the query column has a Nothing table and the column name part --- matches the reference column's name. Also not that this makes it --- an asymetric comparison -columnMatches :: ColumnIdentifier -> ColumnIdentifier -> Bool -columnMatches (ColumnIdentifier Nothing queryColIdStr) referenceColumn = - -- In this case we don't care about the table name so - -- just check to make sure that the column names match up - queryColIdStr == columnId referenceColumn - -columnMatches queryColumn referenceColumn = - -- table name is important here so match on the whole object - queryColumn == referenceColumn - --- | filters the database's table rows on the given expression -filterRowsBy :: Expression -> DatabaseTable -> DatabaseTable -filterRowsBy filterExpr table = - table {tableRows = filter myBoolEvalExpr (tableRows table)} - where myBoolEvalExpr row = - coerceBool $ evalExpression filterExpr (columnIdentifiers table) row - -filterGroupsBy :: Expression -> GroupedTable -> GroupedTable -filterGroupsBy expr groupedTbl = - groupedTbl {tableGroups = map tableRows filteredTbls} - where - makeTbl grp = DatabaseTable (groupColumnIdentifiers groupedTbl) grp - filterFunc = coerceBool . evalAggregateExpression expr - filteredTbls = filter filterFunc (map makeTbl (tableGroups groupedTbl)) - --- | evaluate the given expression against a table --- TODO need better error detection and reporting for non-aggregate --- expressions -evalAggregateExpression :: Expression -> DatabaseTable -> EvaluatedExpression -evalAggregateExpression (StringConstantExpression string) _ = StringExpression string -evalAggregateExpression (IntegerConstantExpression int) _ = IntExpression int -evalAggregateExpression (RealConstantExpression real) _ = RealExpression real -evalAggregateExpression (ColumnExpression col) dbTable = - case findIndex (columnMatches col) (columnIdentifiers dbTable) of - Just colIndex -> (head $ tableRows dbTable) !! colIndex - Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col) - -evalAggregateExpression (FunctionExpression sqlFun funArgs) dbTable = - evalSQLFunction sqlFun $ if isAggregate sqlFun then manyArgs else aggregatedArgs - where - aggregatedArgs = map (\e -> evalAggregateExpression e dbTable) funArgs - manyArgs = - let - tblColIds = columnIdentifiers dbTable - tblRows = tableRows dbTable - evaluateExprs expr = map (evalExpression expr tblColIds) tblRows - allArgs = concatMap evaluateExprs funArgs - in - allArgs - --- | evaluate the given expression against a table row -evalExpression :: Expression -> [ColumnIdentifier] -> [EvaluatedExpression] -> EvaluatedExpression -evalExpression (StringConstantExpression string) _ _ = StringExpression string -evalExpression (IntegerConstantExpression int) _ _ = IntExpression int -evalExpression (RealConstantExpression real) _ _ = RealExpression real -evalExpression (ColumnExpression col) columnIds tblRow = - case findIndex (columnMatches col) columnIds of - Just colIndex -> tblRow !! colIndex - Nothing -> error $ "Failed to find column named: " ++ (prettyFormatColumn col) -evalExpression (FunctionExpression sqlFun funArgs) columnIds tblRow = - evalSQLFunction sqlFun (map evalArgExpr funArgs) - where - evalArgExpr expr = evalExpression expr columnIds tblRow - --- TODO this ugly function needs to be modularized -evalSQLFunction :: SQLFunction -> [EvaluatedExpression] -> EvaluatedExpression -evalSQLFunction sqlFun evaluatedArgs - -- Global validation - -- TODO this error should be more helpful than it is - | argCountIsInvalid = - error $ "cannot apply " ++ show (length evaluatedArgs) ++ - " arguments to " ++ functionName sqlFun - - -- String functions - | sqlFun == upperFunction = StringExpression $ map toUpper (coerceString arg1) - | sqlFun == lowerFunction = StringExpression $ map toLower (coerceString arg1) - | sqlFun == trimFunction = StringExpression $ trimSpace (coerceString arg1) - | sqlFun == concatenateFunction = StringExpression $ concat (map coerceString evaluatedArgs) - | sqlFun == substringFromToFunction = - StringExpression $ take (coerceInt arg3) (drop (coerceInt arg2 - 1) (coerceString arg1)) - | sqlFun == substringFromFunction = - StringExpression $ drop (coerceInt arg2 - 1) (coerceString arg1) - | sqlFun == regexMatchFunction = BoolExpression $ (coerceString arg1) =~ (coerceString arg2) - - -- unary functions - | sqlFun == absFunction = evalUnaryAlgebra abs abs - | sqlFun == negateFunction = evalUnaryAlgebra negate negate - - -- algebraic - | sqlFun == multiplyFunction = algebraWithCoercion (*) (*) evaluatedArgs - | sqlFun == divideFunction = RealExpression $ (coerceReal arg1) / (coerceReal arg2) - | sqlFun == plusFunction = algebraWithCoercion (+) (+) evaluatedArgs - | sqlFun == minusFunction = algebraWithCoercion (-) (-) evaluatedArgs - - -- boolean - | sqlFun == isFunction = BoolExpression (arg1 == arg2) - | sqlFun == isNotFunction = BoolExpression (arg1 /= arg2) - | sqlFun == lessThanFunction = BoolExpression (arg1 < arg2) - | sqlFun == lessThanOrEqualToFunction = BoolExpression (arg1 <= arg2) - | sqlFun == greaterThanFunction = BoolExpression (arg1 > arg2) - | sqlFun == greaterThanOrEqualToFunction = BoolExpression (arg1 >= arg2) - | sqlFun == andFunction = BoolExpression $ (coerceBool arg1) && (coerceBool arg2) - | sqlFun == orFunction = BoolExpression $ (coerceBool arg1) || (coerceBool arg2) - | sqlFun == notFunction = BoolExpression $ not (coerceBool arg1) - - -- aggregate - -- TODO AVG(...) holds the whole arg list in memory. reimplement! - | sqlFun == avgFunction = - RealExpression $ - foldl1' (+) (map coerceReal evaluatedArgs) / - (fromIntegral $ length evaluatedArgs) - | sqlFun == countFunction = IntExpression $ length evaluatedArgs - | sqlFun == firstFunction = head evaluatedArgs - | sqlFun == lastFunction = last evaluatedArgs - | sqlFun == maxFunction = maximum evaluatedArgs - | sqlFun == minFunction = minimum evaluatedArgs - | sqlFun == sumFunction = algebraWithCoercion (+) (+) evaluatedArgs - - -- error!! - | otherwise = error $ - "internal error: missing evaluation code for function: " ++ - functionName sqlFun ++ ". please report this error" - - where - arg1 = head evaluatedArgs - arg2 = evaluatedArgs !! 1 - arg3 = evaluatedArgs !! 2 - algebraWithCoercion intFunc realFunc args = - if any useRealAlgebra args then - RealExpression $ foldl1' realFunc (map coerceReal args) - else - IntExpression $ foldl1' intFunc (map coerceInt args) - - useRealAlgebra (RealExpression _) = True - useRealAlgebra expr = case maybeCoerceInt expr of - Nothing -> True - Just _ -> False - - argCountIsInvalid = - let - -- TODO the use of length is bad (unnecessarily traversing - -- the entire arg list and keeping it in memory). Redo this - -- so that we only check length w.r.t. minArgs - argCount = length evaluatedArgs - minArgs = minArgCount sqlFun - argsFixed = argCountIsFixed sqlFun - in - argCount < minArgs || (argCount > minArgs && argsFixed) - - evalUnaryAlgebra intFunc realFunc = - if length evaluatedArgs /= 1 then - error $ - "internal error: found a " ++ show sqlFun ++ - " function with multiple args. please report this error" - else - if useRealAlgebra arg1 then - RealExpression $ realFunc (coerceReal arg1) - else - IntExpression $ intFunc (coerceInt arg1) - --- | trims leading and trailing spaces -trimSpace :: String -> String -trimSpace = f . f - where f = reverse . dropWhile isSpace +{-# LANGUAGE ExistentialQuantification #-} +module Database.TxtSushi.SQLExecution ( + select, + databaseTableToTextTable, + textTableToDatabaseTable, + SortConfiguration(..)) where + +import Control.Applicative +import Data.Binary +import Data.Char +import Data.Function +import Data.List +import qualified Data.Map as M + +import Database.TxtSushi.SQLExpression +import Database.TxtSushi.SQLFunctionDefinitions +import Database.TxtSushi.EvaluatedExpression +import Database.TxtSushi.ExternalSort +import Database.TxtSushi.Relational + +-- | We will use the sort configuration to determine whether tables should +-- be sorted external or in memory +data SortConfiguration = + UseInMemorySort | + UseExternalSort deriving Show + +sortByCfg :: (Binary b) => SortConfiguration -> (b -> b -> Ordering) -> [b] -> [b] +sortByCfg UseInMemorySort = sortBy +sortByCfg UseExternalSort = externalSortBy + +-- convert a text table to a database table by using the 1st row as column IDs +textTableToDatabaseTable :: String -> [[String]] -> BoxedTable +textTableToDatabaseTable tblName [] = noTableHeaderError tblName +textTableToDatabaseTable tblName (headerNames:tblRows) = + renameDbTable tblName $ BoxedTable DatabaseTable { + columnsWithContext = zip (map makeColExpr headerNames) (repeat evalCtxt), + qualifiedColumnsWithContext = M.empty, + evaluationContext = evalCtxt, + tableData = tblRows, + isInScope = idInHeader} + where + makeColExpr colName = ColumnExpression (ColumnIdentifier Nothing colName) colName + + idInHeader (ColumnIdentifier (Just _) _) = False + idInHeader (ColumnIdentifier Nothing colName) = colName `elem` headerNames + + evalCtxt (ColumnExpression (ColumnIdentifier (Just _) _) colStr) _ = + columnNotInScopeError colStr + evalCtxt (ColumnExpression (ColumnIdentifier Nothing colName) _) row = + case elemIndices colName headerNames of + [colIndex] -> SingleElement $ StringExpression (row !! colIndex) + [] -> columnNotInScopeError colName + _ -> ambiguousColumnError colName + evalCtxt expr row = evalWithContext evalCtxt expr row + +databaseTableToTextTable :: BoxedTable -> [[String]] +databaseTableToTextTable (BoxedTable dbTable) = headerRow : tailRows + where + headerRow = map (expressionToString . fst) colsWCtxt + tailRows = map evalRow (tableData dbTable) + + colsWCtxt = columnsWithContext dbTable + + evalRowExpr ctxt colExpr row = + coerceString . collapseGroups colExpr $ ctxt colExpr row + evalRow row = + [evalRowExpr ctxt colExpr row | (colExpr, ctxt) <- colsWCtxt] + +emptyTable :: BoxedTable +emptyTable = + BoxedTable $ DatabaseTable { + columnsWithContext = [], + qualifiedColumnsWithContext = M.empty, + evaluationContext = eval, + tableData = [shouldNeverOccurError] :: [String], + isInScope = const False} + where + eval (ColumnExpression _ colStr) = columnNotInScopeError colStr + eval expr = evalWithContext eval expr + + +-- | perform a SQL select with the given select statement on the +-- given table map +select :: SortConfiguration -> SelectStatement -> (M.Map String BoxedTable) -> BoxedTable +select sortCfg selectStmt tableMap = + let + fromTbl = case maybeFromTable selectStmt of + Nothing -> emptyTable + Just fromTblExpr -> evalTableExpression sortCfg fromTblExpr tableMap + fromTblWithAliases = + addAliases fromTbl (extractColumnAliases $ columnSelections selectStmt) + filteredTbl = maybeFilterTable (maybeWhereFilter selectStmt) fromTblWithAliases + groupedTbl = maybeGroupTable sortCfg selectStmt filteredTbl + in + selectColumns $ sortDbTable (orderByItems selectStmt) groupedTbl + where + selectColumns (BoxedTable unboxedOrderedTbl) = + BoxedTable unboxedOrderedTbl {columnsWithContext = + concatMap (selectionToExpressions unboxedOrderedTbl) (columnSelections selectStmt)} + + sortDbTable [] boxedTbl = boxedTbl + sortDbTable orderBys (BoxedTable table) = + BoxedTable table {tableData = sortOnOrderBys (tableData table)} + where + ordAscs = map orderAscending orderBys + ordExprs = map orderExpression orderBys + + evalCtxt = evaluationContext table + rowOrd row = [evalCtxt expr row | expr <- ordExprs] + sortOnOrderBys = sortByCfg sortCfg (compareWithDirection ordAscs `on` rowOrd) + +maybeGroupTable :: SortConfiguration -> SelectStatement -> BoxedTable -> BoxedTable +maybeGroupTable sortCfg selectStmt table = + case maybeGroupByHaving selectStmt of + Nothing -> + if selectStatementContainsAggregates selectStmt + -- for the case where we find aggregate functions but + -- no "GROUP BY" part, that means we should apply the + -- aggregate to the table as a single group + then singleGroupDbTable table + else table + Just (groupByPart, maybeHaving) -> + let groupedTable = groupDbTable sortCfg groupByPart table + groupedTableWithAliases = + addAliases groupedTable (extractColumnAliases $ columnSelections selectStmt) + in maybeFilterTable maybeHaving groupedTableWithAliases + +maybeFilterTable :: Maybe Expression -> BoxedTable -> BoxedTable +maybeFilterTable Nothing table = table +maybeFilterTable (Just expr) table = filterRowsBy expr table + +extractColumnAliases :: [ColumnSelection] -> [(String, Expression)] +extractColumnAliases [] = [] +extractColumnAliases ((ExpressionColumn expr (Just alias)) : colsTail) = + (alias, expr) : extractColumnAliases colsTail +extractColumnAliases (_:xt) = extractColumnAliases xt + +-- | Evaluate the FROM table part, and returns the FROM table. Also returns +-- a mapping of new table names from aliases etc. +evalTableExpression :: SortConfiguration -> TableExpression -> (M.Map String BoxedTable) -> BoxedTable +evalTableExpression sortCfg tblExpr tableMap = + case tblExpr of + TableIdentifier tblName maybeTblAlias -> + let table = M.findWithDefault (tableNotInScopeError tblName) tblName tableMap + in maybeRename maybeTblAlias table + + -- TODO inner join should allow joining on expressions too!! + InnerJoin leftJoinTblExpr rightJoinTblExpr onConditionExpr maybeTblAlias -> + let + leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap + rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap + joinExprs = extractJoinExprs leftJoinTbl rightJoinTbl onConditionExpr + joinedTbl = innerJoinDbTables sortCfg joinExprs leftJoinTbl rightJoinTbl + in + maybeRename maybeTblAlias joinedTbl + + SelectExpression selectStmt maybeTblAlias -> + maybeRename maybeTblAlias (select sortCfg selectStmt tableMap) + + -- TODO implement me + CrossJoin leftJoinTblExpr rightJoinTblExpr maybeTblAlias -> + let + leftJoinTbl = evalTableExpression sortCfg leftJoinTblExpr tableMap + rightJoinTbl = evalTableExpression sortCfg rightJoinTblExpr tableMap + joinedTbl = crossJoinDbTables leftJoinTbl rightJoinTbl + in + maybeRename maybeTblAlias joinedTbl + +selectionToExpressions :: DatabaseTable a -> ColumnSelection -> [(Expression, EvaluationContext a)] +selectionToExpressions dbTable AllColumns = columnsWithContext dbTable +selectionToExpressions dbTable (AllColumnsFrom srcTblName) = + M.findWithDefault errMsg srcTblName (qualifiedColumnsWithContext dbTable) + where errMsg = tableNotInScopeError srcTblName + +selectionToExpressions dbTable (ExpressionColumnRange bindId (ColumnRange maybeStartId maybeEndId) expr) = + rangeColsWCtxt + where + colsWCtxt = columnsWithContext dbTable + + rangeColsWCtxt = map updateColWCtxt (take rangeLen . drop startIndex $ colsWCtxt) + where + rangeLen = 1 + endIndex - startIndex + endIndex = maybe (length colsWCtxt - 1) indexOfId maybeEndId + startIndex = maybe 0 indexOfId maybeStartId + + exprMatchesId matcherId (ColumnExpression matcheeId _) = + case matcherId of + ColumnIdentifier (Just _) _ -> matcheeId == matcherId + ColumnIdentifier Nothing colName -> columnId matcheeId == colName + exprMatchesId _ _ = False + + indexOfId theId = case findIndices (exprMatchesId theId) colExprs of + [index] -> index + [] -> columnNotInScopeError $ columnToString theId + _ -> ambiguousColumnError $ columnToString theId + where colExprs = map fst colsWCtxt + + updateColWCtxt (colExpr, colCtxt) = + (updateCol colExpr, updateContext colExpr colCtxt) + + updateContext colExpr colCtxt exprToEval@(ColumnExpression _ _) = + if exprMatchesId bindId exprToEval + then colCtxt colExpr + else evaluationContext dbTable exprToEval + updateContext colExpr colCtxt exprToEval@(FunctionExpression _ _ _) = + evalWithContext (updateContext colExpr colCtxt) exprToEval + updateContext _ _ exprToEval = evaluationContext dbTable exprToEval + + updateCol colExpr = + if exprMatchesId bindId expr + then expr {stringRepresentation = stringRepresentation colExpr} + else expr { + stringRepresentation = + columnToString bindId ++ " = " ++ + stringRepresentation colExpr ++ " in " ++ + stringRepresentation expr} + +selectionToExpressions dbTable (ExpressionColumn expr Nothing) = + [(expr, evaluationContext dbTable)] +selectionToExpressions dbTable (ExpressionColumn _ (Just exprAlias)) = + [(ColumnExpression (ColumnIdentifier Nothing exprAlias) exprAlias, evaluationContext dbTable)] + +extractJoinExprs :: BoxedTable -> BoxedTable -> Expression -> [(Expression, Expression)] +extractJoinExprs bTbl1@(BoxedTable tbl1) bTbl2@(BoxedTable tbl2) (FunctionExpression sqlFunc [arg1, arg2] _) = + case sqlFunc of + SQLFunction "=" _ _ _ _ _ -> extractJoinExprPair + SQLFunction "AND" _ _ _ _ _ -> + extractJoinExprs bTbl1 bTbl2 arg1 ++ extractJoinExprs bTbl1 bTbl2 arg2 + + -- Only expecting "AND" or "=" + _ -> onPartFormattingError + where + fromScope tbl expr = anyInScope tbl expr && allInScope tbl expr + + extractJoinExprPair = + if fromScope tbl1 arg1 && fromScope tbl2 arg2 + then [(arg1, arg2)] + else + if fromScope tbl2 arg1 && fromScope tbl1 arg2 + then [(arg2, arg1)] + else joinOnRequiresBothTablesError + +-- Only expecting "AND" or "=" +extractJoinExprs _ _ _ = onPartFormattingError + +data NestedDataGroups e = + SingleElement e | + GroupedData [NestedDataGroups e] deriving (Ord, Eq, Show) + +instance Functor NestedDataGroups where + fmap f (SingleElement e) = SingleElement (f e) + fmap f (GroupedData grps) = GroupedData $ map (fmap f) grps + +instance Applicative NestedDataGroups where + pure = SingleElement + + (SingleElement f) <*> (SingleElement x) = SingleElement (f x) + (SingleElement f) <*> gd@(GroupedData _) = fmap f gd + gd@(GroupedData _) <*> (SingleElement x) = fmap ($ x) gd + (GroupedData fs) <*> (GroupedData xs) = GroupedData $ zipWith (<*>) fs xs + +flattenGroups :: NestedDataGroups e -> [e] +flattenGroups (SingleElement myElem) = [myElem] +flattenGroups (GroupedData grps) = concatMap flattenGroups grps + +collapseGroups :: + Expression + -> NestedDataGroups EvaluatedExpression + -> EvaluatedExpression +collapseGroups expr grps = case group (flattenGroups grps) of + [singleGroup] -> head singleGroup + + -- it's an error if there is more than one grouping + manyGroups -> + let + (elemsToShow, remaining) = splitAt 5 (map head manyGroups) + commaSepElems = intercalate ", " (map coerceString elemsToShow) + exprStr = expressionToString expr + errorMsg = + "Error: error evaluating \"" ++ exprStr ++ + "\". Cannot evaluate a grouped expression unless all " ++ + "of the grouped values match. Found multiple different " ++ + "values including: " ++ commaSepElems + in case remaining of + [] -> error errorMsg + _ -> error $ errorMsg ++ " etc..." + +-- | takes a list of data groups which can have different shapes and returns +-- a single group of lists which obviously must have the same shape +normalizeGroups :: [NestedDataGroups a] -> NestedDataGroups [a] +normalizeGroups grps = + foldl + -- this function will reshape and concatinate as it's folded + (liftA2 (++)) + + -- an empty single element is the starting point for the fold + (SingleElement []) + + -- fmap is from NestedDataGroups and return from the list monad + (map (fmap return) grps) + +type EvaluationContext a = Expression -> a -> NestedDataGroups EvaluatedExpression + +-- | a data type for representing a database table +data DatabaseTable a = DatabaseTable { + + -- | column expressions with their evaluation contexts + columnsWithContext :: [(Expression, EvaluationContext a)], + + -- | columns with context qualified by table name (the map key) + qualifiedColumnsWithContext :: M.Map String [(Expression, EvaluationContext a)], + + -- | the evaluation context for this table + evaluationContext :: EvaluationContext a, + + -- | the data in this table + tableData :: [a], + + -- | is the given identifier in scope for this table + isInScope :: ColumnIdentifier -> Bool} + +allIdentifiers :: Expression -> [ColumnIdentifier] +allIdentifiers (FunctionExpression _ args _) = concatMap allIdentifiers args +allIdentifiers (ColumnExpression col _) = [col] +allIdentifiers _ = [] + +allInScope :: DatabaseTable a -> Expression -> Bool +allInScope tbl expr = all (isInScope tbl) (allIdentifiers expr) + +anyInScope :: DatabaseTable a -> Expression -> Bool +anyInScope tbl expr = any (isInScope tbl) (allIdentifiers expr) + +data BoxedTable = forall a. (Binary a) => + BoxedTable (DatabaseTable a) + +-- | filters the database's table rows on the given expression +filterRowsBy :: Expression -> BoxedTable -> BoxedTable +filterRowsBy filterExpr (BoxedTable table) = + BoxedTable table {tableData = filter myBoolEvalExpr (tableData table)} + where + evalFilterExpr = (evaluationContext table) filterExpr + myBoolEvalExpr = coerceBool . collapseGroups filterExpr . evalFilterExpr + +addAliases :: BoxedTable -> [(String, Expression)] -> BoxedTable +addAliases boxedTbl [] = boxedTbl +addAliases (BoxedTable tbl) aliases = + BoxedTable tbl { + evaluationContext = aliasedContext, + isInScope = aliasedScope} + where + aliasMap = M.fromList aliases + + aliasedScope colId@(ColumnIdentifier (Just _) _) = isInScope tbl colId + aliasedScope colId@(ColumnIdentifier Nothing colName) = + M.member colName aliasMap || isInScope tbl colId + + aliasedContext colExpr@(ColumnExpression (ColumnIdentifier (Just _) _) _) = + evaluationContext tbl colExpr + aliasedContext colExpr@(ColumnExpression (ColumnIdentifier Nothing colName) _) = + case M.lookup colName aliasMap of + Nothing -> evaluationContext tbl colExpr + Just expr -> aliasedContext expr + aliasedContext expr = evalWithContext aliasedContext expr + +maybeRename :: (Maybe String) -> BoxedTable -> BoxedTable +maybeRename Nothing boxedTable = boxedTable +maybeRename (Just newName) boxedTable = renameDbTable newName boxedTable + +renameDbTable :: String -> BoxedTable -> BoxedTable +renameDbTable name (BoxedTable tbl) = + BoxedTable tbl { + qualifiedColumnsWithContext = M.insert name (columnsWithContext tbl) (qualifiedColumnsWithContext tbl), + evaluationContext = renameContext (evaluationContext tbl), + isInScope = isInRenamedScope} + where + isInRenamedScope colId@(ColumnIdentifier Nothing _) = isInScope tbl colId + isInRenamedScope (ColumnIdentifier (Just tblName) colName) + | tblName == name = isInScope tbl (ColumnIdentifier Nothing colName) + | otherwise = False + + renameContext ctxt colExpr@(ColumnExpression (ColumnIdentifier Nothing _) _) = ctxt colExpr + renameContext ctxt (ColumnExpression (ColumnIdentifier (Just tblName) colName) colStr) + | tblName == name = ctxt (ColumnExpression (ColumnIdentifier Nothing colName) colStr) + | otherwise = columnNotInScopeError colStr + renameContext ctxt expr = evalWithContext (renameContext ctxt) expr + +evalWithContext :: EvaluationContext a -> Expression -> a -> NestedDataGroups EvaluatedExpression +evalWithContext ctxt (FunctionExpression sqlFun args _) row = + case (isAggregate sqlFun, args) of + -- if its an aggregate function with a single arg use aggregate evaluation + (True, [_]) -> aggregateEval + + -- otherwise just evaluate it as a single function + _ -> standardEval + where + normEvaldArgs = normalizeGroups [ctxt arg row | arg <- args] + evalGivenFun = applyFunction sqlFun + aggregateEval = + SingleElement $ applyFunction sqlFun (concat (flattenGroups normEvaldArgs)) + standardEval = fmap evalGivenFun normEvaldArgs +evalWithContext _ (StringConstantExpression s _) _ = SingleElement (StringExpression s) +evalWithContext _ (RealConstantExpression r _) _ = SingleElement (RealExpression r) +evalWithContext _ (IntConstantExpression i _) _ = SingleElement (IntExpression i) +evalWithContext _ (BoolConstantExpression b _) _ = SingleElement (BoolExpression b) +evalWithContext _ (ColumnExpression _ _) _ = shouldNeverOccurError + +toGroupContext :: EvaluationContext a -> EvaluationContext [a] +toGroupContext ctxt = grpCtxt + where + grpCtxt funExpr@(FunctionExpression _ _ _) rowGrp = evalWithContext grpCtxt funExpr rowGrp + grpCtxt expr rowGrp = GroupedData $ map (ctxt expr) rowGrp + +groupDbTable :: + SortConfiguration + -> [Expression] + -> BoxedTable + -> BoxedTable +groupDbTable sortCfg grpExprs (BoxedTable tbl) = + BoxedTable tbl { + columnsWithContext = mapSnd toGroupContext (columnsWithContext tbl), + qualifiedColumnsWithContext = M.map (mapSnd toGroupContext) (qualifiedColumnsWithContext tbl), + evaluationContext = toGroupContext $ evaluationContext tbl, + tableData = groupedData} + where + eval = evaluationContext tbl + rowOrd row = [eval expr row | expr <- grpExprs] + sortedData = sortByCfg sortCfg (compare `on` rowOrd) (tableData tbl) + groupedData = groupBy ((==) `on` rowOrd) sortedData + +singleGroupDbTable :: + BoxedTable + -> BoxedTable +singleGroupDbTable (BoxedTable tbl) = + BoxedTable tbl { + columnsWithContext = mapSnd toGroupContext (columnsWithContext tbl), + qualifiedColumnsWithContext = M.map (mapSnd toGroupContext) (qualifiedColumnsWithContext tbl), + evaluationContext = toGroupContext $ evaluationContext tbl, + tableData = [tableData tbl]} + +compareWithDirection :: (Ord a) => [Bool] -> [a] -> [a] -> Ordering +compareWithDirection (asc:ascTail) (x:xt) (y:yt) = case x `compare` y of + LT -> if asc then LT else GT + GT -> if asc then GT else LT + EQ -> compareWithDirection ascTail xt yt +compareWithDirection [] [] [] = EQ +compareWithDirection _ _ _ = error "Internal Error: List sizes should match" + +innerJoinDbTables :: + SortConfiguration + -> [(Expression, Expression)] + -> BoxedTable + -> BoxedTable + -> BoxedTable +innerJoinDbTables sortCfg joinExprs (BoxedTable fstTable) (BoxedTable sndTable) = + BoxedTable $ zipDbTables joinedData fstTable sndTable + where + fstEval = evaluationContext fstTable + fstRowOrd row = [fstEval expr row | expr <- map fst joinExprs] + + sndEval = evaluationContext sndTable + sndRowOrd row = [sndEval expr row | expr <- map snd joinExprs] + + sortedFstData = sortByCfg sortCfg (compare `on` fstRowOrd) (tableData fstTable) + sortedSndData = sortByCfg sortCfg (compare `on` sndRowOrd) (tableData sndTable) + + joinedData = joinPresortedTables fstRowOrd sortedFstData sndRowOrd sortedSndData + +crossJoinDbTables :: + BoxedTable + -> BoxedTable + -> BoxedTable +crossJoinDbTables (BoxedTable fstTable) (BoxedTable sndTable) = + BoxedTable $ zipDbTables joinedData fstTable sndTable + where + joinedData = [(x, y) | x <- tableData fstTable, y <- tableData sndTable] + +zipDbTables :: [(a, b)] -> DatabaseTable a -> DatabaseTable b -> DatabaseTable (a, b) +zipDbTables zippedData fstTable sndTable = DatabaseTable { + columnsWithContext = fstCols ++ sndCols, + qualifiedColumnsWithContext = M.unionWithKey ambiguousTableError fstQualCols sndQualCols, + evaluationContext = evalCtxt, + tableData = zippedData, + isInScope = isInFstOrSndScope} + + where + isInFstScope = isInScope fstTable + isInSndScope = isInScope sndTable + isInFstOrSndScope iden = isInFstScope iden || isInSndScope iden + + toFstCtxt ctxt colId row = ctxt colId (fst row) + toSndCtxt ctxt colId row = ctxt colId (snd row) + + fstCols = mapSnd toFstCtxt (columnsWithContext fstTable) + sndCols = mapSnd toSndCtxt (columnsWithContext sndTable) + + fstQualCols = M.map (mapSnd toFstCtxt) (qualifiedColumnsWithContext fstTable) + sndQualCols = M.map (mapSnd toSndCtxt) (qualifiedColumnsWithContext sndTable) + + evalCtxt colExpr@(ColumnExpression colId colStr) row = + case (isInFstScope colId, isInSndScope colId) of + (True, False) -> evaluationContext fstTable colExpr (fst row) + (False, True) -> evaluationContext sndTable colExpr (snd row) + (True, True) -> ambiguousColumnError colStr + (False, False) -> columnNotInScopeError colStr + evalCtxt expr row = evalWithContext evalCtxt expr row + +mapSnd :: (a -> b) -> [(c, a)] -> [(c, b)] +mapSnd f xs = [(x, f y) | (x, y) <- xs] + +ambiguousTableError, noTableHeaderError, tableNotInScopeError, columnNotInScopeError, ambiguousColumnError :: String -> a +ambiguousTableError tblName = error $ "Error: The table name \"" ++ tblName ++ "\" is ambiguous" +noTableHeaderError tblName = error $ "Error: invalid table \"" ++ tblName ++ "\". There is no header row" +tableNotInScopeError tblName = error $ "Error: failed to find a table named \"" ++ tblName ++ "\" in the current scope" +columnNotInScopeError colName = error $ "Error: failed to find a column named \"" ++ colName ++ "\" in the current scope" +ambiguousColumnError colName = error $ "Error: ambiguous column name (found multiple matches in the current scope): " ++ colName + +onPartFormattingError, joinOnRequiresBothTablesError, shouldNeverOccurError :: a +onPartFormattingError = error $ + "Error: The \"ON\" part of a join must only contain " ++ + "expression equalities joined together by \"AND\" like: " ++ + "\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\"" + +joinOnRequiresBothTablesError = error $ + "Error: the expressions used in the \"ON\" part of a table join must use " ++ + "identifiers from each of the two join tables like: " ++ + "\"tbl1.id1 = table2.id1 AND tbl1.firstname = tbl2.name\"" + +shouldNeverOccurError = + error $ + "Internal Error: This should never occur. " ++ + "A table failed to evaluate its own column ID" diff --git a/Database/TxtSushi/SQLExpression.hs b/Database/TxtSushi/SQLExpression.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/SQLExpression.hs @@ -0,0 +1,166 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.TxtSushi.SQLParser +-- Copyright : (c) Keith Sheppard 2009 +-- License : GPL3 or greater +-- Maintainer : keithshep@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- SQL Expressions +-- +----------------------------------------------------------------------------- + +module Database.TxtSushi.SQLExpression ( + allMaybeTableNames, + SelectStatement(..), + TableExpression(..), + ColumnIdentifier(..), + ColumnSelection(..), + Expression(..), + SQLFunction(..), + OrderByItem(..), + ColumnRange(..), + isAggregate, + selectStatementContainsAggregates, + expressionToString, + columnToString) where + +import Data.Char +import Data.List + +import Database.TxtSushi.EvaluatedExpression + +-------------------------------------------------------------------------------- +-- 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]} + +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} | + SelectExpression { + selectStatement :: SelectStatement, + maybeTableAlias :: Maybe String} + +-- | 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 :: TableExpression -> [String] +allTableNames (TableIdentifier tblName _) = [tblName] +allTableNames (InnerJoin lftTbl rtTbl _ _) = + (allTableNames lftTbl) ++ (allTableNames rtTbl) +allTableNames (CrossJoin lftTbl rtTbl _) = + (allTableNames lftTbl) ++ (allTableNames rtTbl) +allTableNames (SelectExpression selectStmt _) = + allMaybeTableNames $ maybeFromTable selectStmt + +data ColumnSelection = + AllColumns | + AllColumnsFrom {sourceTableName :: String} | + ExpressionColumn { + expression :: Expression, + maybeColumnAlias :: Maybe String} | + ExpressionColumnRange { + binding :: ColumnIdentifier, + range :: ColumnRange, + expression :: Expression} + +data ColumnRange = ColumnRange { + maybeStart :: Maybe ColumnIdentifier, + maybeEnd :: Maybe ColumnIdentifier} + +data ColumnIdentifier = + ColumnIdentifier { + maybeTableName :: Maybe String, + columnId :: String} deriving Eq + +data Expression = + FunctionExpression { + sqlFunction :: SQLFunction, + functionArguments :: [Expression], + stringRepresentation :: String} | + ColumnExpression { + column :: ColumnIdentifier, + stringRepresentation :: String} | + StringConstantExpression { + stringConstant :: String, + stringRepresentation :: String} | + IntConstantExpression { + intConstant :: Int, + stringRepresentation :: String} | + RealConstantExpression { + realConstant :: Double, + stringRepresentation :: String} | + BoolConstantExpression { + boolConstant :: Bool, + stringRepresentation :: String} + +data SQLFunction = SQLFunction { + functionName :: String, + minArgCount :: Int, + argCountIsFixed :: Bool, + functionGrammar :: String, + functionDescription :: String, + applyFunction :: [EvaluatedExpression] -> EvaluatedExpression} + +-- | an aggregate function is one whose min function count is 1 and whose +-- arg count is not fixed +isAggregate :: SQLFunction -> Bool +isAggregate = not . argCountIsFixed + +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) + +expressionToString :: Expression -> String +expressionToString (FunctionExpression _ _ strRep) = strRep +expressionToString (ColumnExpression _ strRep) = strRep +expressionToString (StringConstantExpression _ strRep) = strRep +expressionToString (IntConstantExpression _ strRep) = strRep +expressionToString (RealConstantExpression _ strRep) = strRep +expressionToString (BoolConstantExpression _ strRep) = strRep + +columnToString :: ColumnIdentifier -> String +columnToString (ColumnIdentifier (Just tblName) colId) = tblName ++ "." ++ colId +columnToString (ColumnIdentifier (Nothing) colId) = colId + +data OrderByItem = OrderByItem { + orderExpression :: Expression, + orderAscending :: Bool} diff --git a/Database/TxtSushi/SQLFunctionDefinitions.hs b/Database/TxtSushi/SQLFunctionDefinitions.hs new file mode 100644 --- /dev/null +++ b/Database/TxtSushi/SQLFunctionDefinitions.hs @@ -0,0 +1,532 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.TxtSushi.SQLFunctionDefinitions +-- Copyright : (c) Keith Sheppard 2009 +-- License : GPL3 or greater +-- Maintainer : keithshep@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- SQL Functions +-- +----------------------------------------------------------------------------- + +module Database.TxtSushi.SQLFunctionDefinitions ( + SQLFunction(..), + normalSyntaxFunctions, + infixFunctions, + specialFunctions, + + -- TODO remove these + negateFunction, + countFunction, + substringFromToFunction, + substringFromFunction, + notFunction) where + +import Data.Char +import Data.List +import Data.Maybe +import Text.Regex.Posix + +import Database.TxtSushi.EvaluatedExpression +import Database.TxtSushi.SQLExpression + +-- Functions with "normal" syntax -- +normalSyntaxFunctions :: [SQLFunction] +normalSyntaxFunctions = + [absFunction, upperFunction, lowerFunction, trimFunction, ifThenElseFunction, + asIntFunction, asRealFunction, isNumericFunction, + -- all aggregates except count which accepts a (*) + avgFunction, firstFunction, lastFunction, maxFunction, + minFunction, sumFunction] + +-- non aggregates +isNumericFunction :: SQLFunction +isNumericFunction = SQLFunction { + functionName = "IS_NUMERIC", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = BoolExpression. isJust . maybeCoerceReal . head . checkArgCount isNumericFunction, + functionGrammar = normalGrammar isNumericFunction, + functionDescription = "determines if the argument can be coerced to a numeric " ++ + "type without error (Eg: using AS_REAL, AS_INT, +, etc...)"} + +asIntFunction :: SQLFunction +asIntFunction = SQLFunction { + functionName = "AS_INT", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = IntExpression . coerceInt . head . checkArgCount asIntFunction, + functionGrammar = normalGrammar asIntFunction, + functionDescription = "converts the argument to an integer " ++ + "(failure to convert will cause the program " ++ + "to halt with an error message)"} + +asRealFunction :: SQLFunction +asRealFunction = SQLFunction { + functionName = "AS_REAL", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = RealExpression . coerceReal . head . checkArgCount asRealFunction, + functionGrammar = normalGrammar asRealFunction, + functionDescription = "converts the argument to an real number " ++ + "(failure to convert will cause the program " ++ + "to halt with an error message)"} + +absFunction :: SQLFunction +absFunction = SQLFunction { + functionName = "ABS", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryNumeric absFunction abs abs, + functionGrammar = normalGrammar absFunction, + functionDescription = "absolute value function"} + +upperFunction :: SQLFunction +upperFunction = SQLFunction { + functionName = "UPPER", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryString upperFunction (map toUpper), + functionGrammar = normalGrammar upperFunction, + functionDescription = "converts the given text to upper case"} + +lowerFunction :: SQLFunction +lowerFunction = SQLFunction { + functionName = "LOWER", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryString lowerFunction (map toLower), + functionGrammar = normalGrammar lowerFunction, + functionDescription = "converts the given text to lower case"} + +trimFunction :: SQLFunction +trimFunction = SQLFunction { + functionName = "TRIM", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryString trimFunction trimSpace, + functionGrammar = normalGrammar trimFunction, + functionDescription = "trims whitespace from the beginning and end of the given text"} + +ifThenElseFunction :: SQLFunction +ifThenElseFunction = SQLFunction { + functionName = "IF_THEN_ELSE", + minArgCount = 3, + argCountIsFixed = True, + applyFunction = ifThenElse . checkArgCount ifThenElseFunction, + functionGrammar = normalGrammar ifThenElseFunction, + functionDescription = "if arg1 evaluates as true return arg2, else return arg3"} + where + ifThenElse [ifExpr, thenExpr, elseExpr] = + if coerceBool ifExpr + then thenExpr + else elseExpr + ifThenElse _ = internalError + +-- aggregates +avgFunction :: SQLFunction +avgFunction = SQLFunction { + functionName = "AVG", + minArgCount = 1, + argCountIsFixed = False, + applyFunction = avgFun . checkArgCount avgFunction, + functionGrammar = normalGrammar avgFunction, + functionDescription = "aggregate average function"} + -- TODO this AVG(...) holds the whole arg list in memory. reimplement! + where + avgFun args = RealExpression $ + foldl1' (+) (map coerceReal args) / + (fromIntegral $ length args) + +countFunction :: SQLFunction +countFunction = SQLFunction { + functionName = "COUNT", + minArgCount = 0, + argCountIsFixed = False, + applyFunction = IntExpression . length, + functionGrammar = normalGrammar countFunction, + functionDescription = "aggregate function for calculating group size"} + +firstFunction :: SQLFunction +firstFunction = SQLFunction { + functionName = "FIRST", + minArgCount = 1, + argCountIsFixed = False, + applyFunction = head . checkArgCount firstFunction, + functionGrammar = normalGrammar firstFunction, + functionDescription = "aggregate function returning only the first element of every group"} + +lastFunction :: SQLFunction +lastFunction = SQLFunction { + functionName = "LAST", + minArgCount = 1, + argCountIsFixed = False, + applyFunction = last . checkArgCount lastFunction, + functionGrammar = normalGrammar lastFunction, + functionDescription = "aggregate function returning only the last element of every group"} + +maxFunction :: SQLFunction +maxFunction = SQLFunction { + functionName = "MAX", + minArgCount = 1, + argCountIsFixed = False, + applyFunction = maximum . checkArgCount maxFunction, + functionGrammar = normalGrammar maxFunction, + functionDescription = "aggregate function returning the maximum element of every group"} + +minFunction :: SQLFunction +minFunction = SQLFunction { + functionName = "MIN", + minArgCount = 1, + argCountIsFixed = False, + applyFunction = minimum . checkArgCount minFunction, + functionGrammar = normalGrammar minFunction, + functionDescription = "aggregate function returning the minimum element of every group"} + +sumFunction :: SQLFunction +sumFunction = SQLFunction { + functionName = "SUM", + minArgCount = 0, + argCountIsFixed = False, + applyFunction = foldl stepSum (IntExpression 0), + functionGrammar = normalGrammar sumFunction, + functionDescription = "aggregate function which summs all elements in each group"} + where + stepSum prevSum currArg = + if useRealAlgebra prevSum || useRealAlgebra currArg + then RealExpression $ coerceReal prevSum + coerceReal currArg + else IntExpression $ coerceInt prevSum + coerceInt currArg + +-- Infix functions -- +infixFunctions :: [[SQLFunction]] +infixFunctions = + [[multiplyFunction, divideFunction], + [plusFunction, minusFunction], + [concatenateFunction], + [isFunction, isNotFunction, lessThanFunction, lessThanOrEqualToFunction, + greaterThanFunction, greaterThanOrEqualToFunction, regexMatchFunction], + [andFunction], + [orFunction]] + +-- Algebraic +multiplyFunction :: SQLFunction +multiplyFunction = SQLFunction { + functionName = "*", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryNumeric multiplyFunction (*) (*), + functionGrammar = binaryInfixGrammar multiplyFunction, + functionDescription = "multiplies the left and right expressions"} + +divideFunction :: SQLFunction +divideFunction = SQLFunction { + functionName = "/", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = divFun . checkArgCount divideFunction, + functionGrammar = binaryInfixGrammar divideFunction, + functionDescription = "divides the left expression by the right expression"} + where + divFun [numExpr, denomExpr] = + RealExpression $ (coerceReal numExpr) / (coerceReal denomExpr) + divFun _ = internalError + +plusFunction :: SQLFunction +plusFunction = SQLFunction { + functionName = "+", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryNumeric plusFunction (+) (+), + functionGrammar = binaryInfixGrammar plusFunction, + functionDescription = "adds the left and right expressions"} + +minusFunction :: SQLFunction +minusFunction = SQLFunction { + functionName = "-", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryNumeric minusFunction (-) (-), + functionGrammar = binaryInfixGrammar minusFunction, + functionDescription = "subtracts the right expression from the left expression"} + +-- Boolean +isFunction :: SQLFunction +isFunction = SQLFunction { + functionName = "=", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison isFunction (==), + functionGrammar = binaryInfixGrammar isFunction, + functionDescription = "tests the left and right expressions for equality"} + +isNotFunction :: SQLFunction +isNotFunction = SQLFunction { + functionName = "<>", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison isNotFunction (/=), + functionGrammar = binaryInfixGrammar isNotFunction, + functionDescription = "evaluates as true if the left and right expressions are not equal"} + +lessThanFunction :: SQLFunction +lessThanFunction = SQLFunction { + functionName = "<", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison lessThanFunction (<), + functionGrammar = binaryInfixGrammar lessThanFunction, + functionDescription = "evaluates as true if the left expression is \"less than\" the right expression"} + +lessThanOrEqualToFunction :: SQLFunction +lessThanOrEqualToFunction = SQLFunction { + functionName = "<=", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison lessThanOrEqualToFunction (<=), + functionGrammar = binaryInfixGrammar lessThanOrEqualToFunction, + functionDescription = "evaluates as true if the left expression is \"less than or equal to\" the right expression"} + +greaterThanFunction :: SQLFunction +greaterThanFunction = SQLFunction { + functionName = ">", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison greaterThanFunction (>), + functionGrammar = binaryInfixGrammar greaterThanFunction, + functionDescription = "evaluates as true if the left expression is \"greater than\" the right expression"} + +greaterThanOrEqualToFunction :: SQLFunction +greaterThanOrEqualToFunction = SQLFunction { + functionName = ">=", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryComparison greaterThanOrEqualToFunction (>=), + functionGrammar = binaryInfixGrammar greaterThanOrEqualToFunction, + functionDescription = "evaluates as true if the left expression is \"greater than or equal to\" the right expression"} + +andFunction :: SQLFunction +andFunction = SQLFunction { + functionName = "AND", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryBooleanTest andFunction (&&), + functionGrammar = binaryInfixGrammar andFunction, + functionDescription = "evaluates as true if and only if both the left and right expressions are true"} + +orFunction :: SQLFunction +orFunction = SQLFunction { + functionName = "OR", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = applyBinaryBooleanTest orFunction (||), + functionGrammar = binaryInfixGrammar orFunction, + functionDescription = "evaluates as true if and only if either the left or right expressions are true"} + +concatenateFunction :: SQLFunction +concatenateFunction = SQLFunction { + functionName = "||", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = catExprs . checkArgCount concatenateFunction, + functionGrammar = binaryInfixGrammar concatenateFunction, + functionDescription = "performs string concatenation of the left and right strings"} + where + catExprs [arg1, arg2] = StringExpression $ (coerceString arg1) ++ (coerceString arg2) + catExprs _ = internalError + +regexMatchFunction :: SQLFunction +regexMatchFunction = SQLFunction { + functionName = "=~", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = regexMatch . checkArgCount regexMatchFunction, + functionGrammar = binaryInfixGrammar regexMatchFunction, + functionDescription = "evaluates as true if and only if the text on the left matches the regular expression on the right"} + where + regexMatch [arg1, arg2] = BoolExpression $ (coerceString arg1) =~ (coerceString arg2) + regexMatch _ = internalError + +-- Functions with special syntax -- +specialFunctions :: [SQLFunction] +specialFunctions = [substringFromFunction, + substringFromToFunction, + negateFunction, + notFunction] + +negateFunction :: SQLFunction +negateFunction = SQLFunction { + functionName = "-", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryNumeric negateFunction negate negate, + functionGrammar = "-numeric_expression", + functionDescription = "unary negation"} + +-- | SUBSTRING(extraction_string FROM starting_position [FOR length] +-- [COLLATE collation_name]) +-- TODO implement COLLATE part +substringFromFunction :: SQLFunction +substringFromFunction = SQLFunction { + functionName = "SUBSTRING", + minArgCount = 2, + argCountIsFixed = True, + applyFunction = substringFrom . checkArgCount substringFromFunction, + functionGrammar = "SUBSTRING(string_expression FROM start_index [FOR length_expression])", + functionDescription = "returns substring of string_expression going from " ++ + "start_index using 1-based indexing for a length of length_expression " ++ + " or to the end of string_expression if the FOR part is omitted"} + where + substringFrom [strExpr, fromExpr] = StringExpression $ + drop (coerceInt fromExpr - 1) (coerceString strExpr) + substringFrom _ = internalError + +substringFromToFunction :: SQLFunction +substringFromToFunction = SQLFunction { + functionName = "SUBSTRING", + minArgCount = 3, + argCountIsFixed = True, + applyFunction = substringFromTo . checkArgCount substringFromToFunction, + functionGrammar = "SUBSTRING(string_expression FROM start_index [FOR length_expression])", + functionDescription = "returns substring of string_expression going from " ++ + "start_index using 1-based indexing for a length of length_expression " ++ + " or to the end of string_expression if the FOR part is omitted"} + where + substringFromTo [strExpr, fromExpr, toExpr] = StringExpression $ + take (coerceInt toExpr) (drop (coerceInt fromExpr - 1) (coerceString strExpr)) + substringFromTo _ = internalError + +notFunction :: SQLFunction +notFunction = SQLFunction { + functionName = "NOT", + minArgCount = 1, + argCountIsFixed = True, + applyFunction = applyUnaryBool notFunction not, + functionGrammar = "NOT bool_expression", + functionDescription = "evaluates as true if and only if bool_expression is false"} + +-- some evaluation helper functions + +applyUnaryString :: + SQLFunction + -> (String -> String) + -> [EvaluatedExpression] + -> EvaluatedExpression +applyUnaryString sqlFun f = + StringExpression . f . coerceString . head . checkArgCount sqlFun + +applyBinaryBooleanTest :: + SQLFunction + -> (Bool -> Bool -> Bool) + -> [EvaluatedExpression] + -> EvaluatedExpression +applyBinaryBooleanTest _ f [arg1, arg2] = + BoolExpression $ f (coerceBool arg1) (coerceBool arg2) +applyBinaryBooleanTest sqlFun _ args = badArgCountError sqlFun args + +applyBinaryComparison :: + SQLFunction + -> (t -> t -> Bool) + -> [t] + -> EvaluatedExpression +applyBinaryComparison _ cmp [arg1, arg2] = BoolExpression $ cmp arg1 arg2 +applyBinaryComparison sqlFun _ args = badArgCountError sqlFun args + +applyUnaryNumeric :: + SQLFunction + -> (Int -> Int) + -> (Double -> Double) + -> [EvaluatedExpression] + -> EvaluatedExpression +applyUnaryNumeric _ intFunc realFunc [arg] = + if useRealAlgebra arg then + RealExpression $ realFunc (coerceReal arg) + else + IntExpression $ intFunc (coerceInt arg) +applyUnaryNumeric sqlFun _ _ args = badArgCountError sqlFun args + +applyBinaryNumeric :: + SQLFunction + -> (Int -> Int -> Int) + -> (Double -> Double -> Double) + -> [EvaluatedExpression] + -> EvaluatedExpression +applyBinaryNumeric _ intFunc realFunc [arg1, arg2] = + if useRealAlgebra arg1 || useRealAlgebra arg2 then + RealExpression $ realFunc (coerceReal arg1) (coerceReal arg2) + else + IntExpression $ intFunc (coerceInt arg1) (coerceInt arg2) +applyBinaryNumeric sqlFun _ _ args = badArgCountError sqlFun args + +applyUnaryBool :: + SQLFunction + -> (Bool -> Bool) + -> [EvaluatedExpression] + -> EvaluatedExpression +applyUnaryBool _ f [arg] = BoolExpression $ f (coerceBool arg) +applyUnaryBool sqlFun _ args = badArgCountError sqlFun args + +checkArgCount :: SQLFunction -> [a] -> [a] +checkArgCount sqlFun args = + if argCountOK then args else badArgCountError sqlFun args + where + minArgs = minArgCount sqlFun + + argCountOK = + if argCountIsFixed sqlFun + then lengthEquals args minArgs + else lengthAtLeast args minArgs + where + lengthEquals xs len = go xs 0 + where + go [] cumLen = cumLen == len + go (_:yt) cumLen = if cumLen >= len then False else go yt (cumLen + 1) + + lengthAtLeast xs len = go xs 0 + where + go [] cumLen = cumLen >= len + go (_:yt) cumLen = if cumLen >= len then True else go yt (cumLen + 1) + +badArgCountError :: SQLFunction -> [a] -> b +badArgCountError sqlFun args = + if argCountIsFixed sqlFun then error $ + "Error: bad argument count in " ++ functionName sqlFun ++ + " expected " ++ show (minArgCount sqlFun) ++ + " argument(s) but was given " ++ show received + else error $ + "Error: bad argument count in " ++ functionName sqlFun ++ + " expected at least " ++ show (minArgCount sqlFun) ++ + " argument(s) but was given " ++ show received + where received = length args + +internalError :: a +internalError = error "Internal Error: this should never occur" + +useRealAlgebra :: EvaluatedExpression -> Bool +useRealAlgebra (RealExpression _) = True +useRealAlgebra expr = case maybeCoerceInt expr of + Nothing -> True + Just _ -> False + +-- | trims leading and trailing spaces +trimSpace :: String -> String +trimSpace = f . f + where f = reverse . dropWhile isSpace + +-- | some grammar helper functions +normalGrammar :: SQLFunction -> String +normalGrammar sqlFun = functionName sqlFun ++ "(" ++ argStr ++ ")" + where + argStrPrefix = intercalate ", " minArgs + where minArgs = zipWith (++) (repeat "arg") (map show [1 .. minArgCount sqlFun]) + + argStr = + if argCountIsFixed sqlFun + then argStrPrefix + else if minArgCount sqlFun >= 1 + then argStrPrefix ++ ", ..." + else "..." + +binaryInfixGrammar :: SQLFunction -> String +binaryInfixGrammar sqlFun = "leftExpr " ++ functionName sqlFun ++ " rightExpr" diff --git a/Database/TxtSushi/SQLParser.hs b/Database/TxtSushi/SQLParser.hs --- a/Database/TxtSushi/SQLParser.hs +++ b/Database/TxtSushi/SQLParser.hs @@ -12,233 +12,24 @@ ----------------------------------------------------------------------------- module Database.TxtSushi.SQLParser ( - allMaybeTableNames, parseSelectStatement, + allMaybeTableNames, 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, - absFunction, - 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 + OrderByItem(..)) where import Data.Char import Data.List import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Expr --------------------------------------------------------------------------------- --- 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} | - SelectExpression { - selectStatement :: SelectStatement, - 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 :: TableExpression -> [String] -allTableNames (TableIdentifier tblName _) = [tblName] -allTableNames (InnerJoin lftTbl rtTbl _ _) = - (allTableNames lftTbl) ++ (allTableNames rtTbl) -allTableNames (CrossJoin lftTbl rtTbl _) = - (allTableNames lftTbl) ++ (allTableNames rtTbl) -allTableNames (SelectExpression selectStmt _) = - allMaybeTableNames $ maybeFromTable selectStmt - -data ColumnSelection = - AllColumns | - AllColumnsFrom {sourceTableName :: String} | - ExpressionColumn { - expression :: Expression, - maybeColumnAlias :: Maybe String} - --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 - | otherwise = - error $ "don't know how to format the given SQL function : " ++ - show sqlFunc - -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) +import Database.TxtSushi.ParseUtil +import Database.TxtSushi.SQLExpression +import Database.TxtSushi.SQLFunctionDefinitions -- | Parses a SQL select statement parseSelectStatement :: GenParser Char st SelectStatement @@ -329,10 +120,32 @@ parseColumnSelections :: GenParser Char st [ColumnSelection] parseColumnSelections = sepBy1 parseAnyColType (try commaSeparator) - where parseAnyColType = parseAllCols <|> + where parseAnyColType = parseRangeColumns <|> + parseAllCols <|> (try parseAllColsFromTbl) <|> (try parseColExpression) +parseRangeColumns :: GenParser Char st ColumnSelection +parseRangeColumns = parseRangeInner + where + parseRangeInner = do + parseToken "FOR" + bindingId <- parseColumnId + parseToken "IN" + colRange <- parseColRange + parseToken "YIELD" + expr <- parseExpression + + return $ ExpressionColumnRange bindingId colRange expr + + where + parseColRange = brace $ do + maybeStartCol <- maybeParse parseColumnId + parseToken ".." + maybeEndCol <- maybeParse parseColumnId + + return $ ColumnRange maybeStartCol maybeEndCol + parseAllCols :: GenParser Char st ColumnSelection parseAllCols = parseToken "*" >> return AllColumns @@ -354,7 +167,7 @@ parseColumnId = do firstId <- parseIdentifier - maybeFullyQual <- maybeParse $ (char '.' >> spaces) + maybeFullyQual <- maybeParse $ parseToken "." case maybeFullyQual of -- No '.' means it's a partially qualified column Nothing -> return $ ColumnIdentifier Nothing firstId @@ -451,7 +264,8 @@ parseAnyNonInfixExpression :: GenParser Char st Expression parseAnyNonInfixExpression = - parenthesize parseExpression <|> + parseParenthesizedExpression <|> + parseBoolConstant <|> parseStringConstant <|> try parseRealConstant <|> try parseIntConstant <|> @@ -460,70 +274,29 @@ parseSubstringFunction <|> parseNotFunction <|> parseCountStar <|> - (parseColumnId >>= return . ColumnExpression) + (parseColumnId >>= \colId -> return $ ColumnExpression colId (columnToString colId)) +parseParenthesizedExpression :: GenParser Char st Expression +parseParenthesizedExpression = + parenthesize parseExpression >>= + \e -> return e {stringRepresentation = "(" ++ stringRepresentation e ++ ")"} + +parseBoolConstant :: GenParser Char st Expression +parseBoolConstant = + (parseToken "TRUE" >>= return . BoolConstantExpression True) <|> + (parseToken "FALSE" >>= return . BoolConstantExpression False) + parseStringConstant :: GenParser Char st Expression parseStringConstant = (quotedText True '"' <|> quotedText True '\'') >>= - (return . StringConstantExpression) + \str -> return $ StringConstantExpression str ("'" ++ str ++ "'") -- TODO this quoting is not robust! parseIntConstant :: GenParser Char st Expression -parseIntConstant = parseInt >>= return . IntegerConstantExpression - -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 +parseIntConstant = parseInt >>= \int -> return $ IntConstantExpression int (show int) parseRealConstant :: GenParser Char st Expression parseRealConstant = - parseReal >>= (\real -> return $ RealConstantExpression real) - -parseReal :: GenParser Char st Double -parseReal = eatSpacesAfter . try . (withoutTrailing alphaNum) $ do - realTxt <- anyParseTxt "real" - return $ read realTxt - where - anyParseTxt = do - txtWithoutExp <- txtWithoutExponent - expPart <- try exponentPart <|> return "" - return $ txtWithoutExp ++ expPart - exponentPart = do - e <- (char 'e' <|> char 'E') - negPart <- (char '-' >> return "-") <|> return "" - numPart <- many1 digit - return $ (e:negPart) ++ numPart - txtWithoutExponent = signedTxt <|> unsignedTxt "real" - unsignedTxt = do - intTxt <- many1 digit - char '.' - fracTxt <- many1 digit - return $ intTxt ++ "." ++ fracTxt - signedTxt = do - char '-' - unsignedDigitTxt <- unsignedTxt - return ('-':unsignedDigitTxt) + parseReal >>= \real -> return $ RealConstantExpression real (show real) parseAnyNormalFunction :: GenParser Char st Expression parseAnyNormalFunction = @@ -532,100 +305,15 @@ parseNormalFunction :: SQLFunction -> GenParser Char st Expression parseNormalFunction sqlFunc = - try (parseToken $ functionName sqlFunc) >> parseNormalFunctionArgs sqlFunc - -parseNormalFunctionArgs :: SQLFunction -> GenParser Char st Expression -parseNormalFunctionArgs sqlFunc = do - args <- parenthesize $ argSepBy (minArgCount sqlFunc) parseExpression commaSeparator - return $ FunctionExpression sqlFunc args - where argSepBy = if argCountIsFixed sqlFunc then sepByExactly else sepByAtLeast - --- Functions with "normal" syntax -- -normalSyntaxFunctions :: [SQLFunction] -normalSyntaxFunctions = - [absFunction, upperFunction, lowerFunction, trimFunction, - -- all aggregates except count which accepts a (*) - avgFunction, firstFunction, lastFunction, maxFunction, - minFunction, sumFunction] - --- non aggregates -absFunction :: SQLFunction -absFunction = SQLFunction { - functionName = "ABS", - minArgCount = 1, - argCountIsFixed = True} - -upperFunction :: SQLFunction -upperFunction = SQLFunction { - functionName = "UPPER", - minArgCount = 1, - argCountIsFixed = True} - -lowerFunction :: SQLFunction -lowerFunction = SQLFunction { - functionName = "LOWER", - minArgCount = 1, - argCountIsFixed = True} - -trimFunction :: SQLFunction -trimFunction = SQLFunction { - functionName = "TRIM", - minArgCount = 1, - argCountIsFixed = True} - --- aggregates -avgFunction :: SQLFunction -avgFunction = SQLFunction { - functionName = "AVG", - minArgCount = 1, - argCountIsFixed = False} - -countFunction :: SQLFunction -countFunction = SQLFunction { - functionName = "COUNT", - minArgCount = 1, - argCountIsFixed = False} - -firstFunction :: SQLFunction -firstFunction = SQLFunction { - functionName = "FIRST", - minArgCount = 1, - argCountIsFixed = False} - -lastFunction :: SQLFunction -lastFunction = SQLFunction { - functionName = "LAST", - minArgCount = 1, - argCountIsFixed = False} - -maxFunction :: SQLFunction -maxFunction = SQLFunction { - functionName = "MAX", - minArgCount = 1, - argCountIsFixed = False} - -minFunction :: SQLFunction -minFunction = SQLFunction { - functionName = "MIN", - minArgCount = 1, - argCountIsFixed = False} - -sumFunction :: SQLFunction -sumFunction = SQLFunction { - functionName = "SUM", - minArgCount = 1, - argCountIsFixed = False} + try (parseToken $ functionName sqlFunc) >>= parseNormalFunctionArgs sqlFunc --- Infix functions -- -infixFunctions :: [[SQLFunction]] -infixFunctions = - [[multiplyFunction, divideFunction], - [plusFunction, minusFunction], - [concatenateFunction], - [isFunction, isNotFunction, lessThanFunction, lessThanOrEqualToFunction, - greaterThanFunction, greaterThanOrEqualToFunction, regexMatchFunction], - [andFunction], - [orFunction]] +parseNormalFunctionArgs :: SQLFunction -> String -> GenParser Char st Expression +parseNormalFunctionArgs sqlFunc sqlFuncStr = do + args <- parenthesize $ sepBy parseExpression commaSeparator + return $ FunctionExpression sqlFunc args (sqlFuncStr ++ toArgListString args) + where + toArgListString argExprs = + '(' : intercalate ", " (map expressionToString argExprs) ++ ")" -- | This function parses the operator part of the infix function and returns -- a function that excepts a left expression and right expression to form @@ -638,163 +326,56 @@ opParser = parseToken (functionName infixFunc) >> return buildExpr buildExpr leftSubExpr rightSubExpr = FunctionExpression { sqlFunction = infixFunc, - functionArguments = [leftSubExpr, rightSubExpr]} - --- Algebraic -multiplyFunction :: SQLFunction -multiplyFunction = SQLFunction { - functionName = "*", - minArgCount = 2, - argCountIsFixed = True} - -divideFunction :: SQLFunction -divideFunction = SQLFunction { - functionName = "/", - minArgCount = 2, - argCountIsFixed = True} - -plusFunction :: SQLFunction -plusFunction = SQLFunction { - functionName = "+", - minArgCount = 2, - argCountIsFixed = True} - -minusFunction :: SQLFunction -minusFunction = SQLFunction { - functionName = "-", - minArgCount = 2, - argCountIsFixed = True} - --- Boolean -isFunction :: SQLFunction -isFunction = SQLFunction { - functionName = "=", - minArgCount = 2, - argCountIsFixed = True} - -isNotFunction :: SQLFunction -isNotFunction = SQLFunction { - functionName = "<>", - minArgCount = 2, - argCountIsFixed = True} - -lessThanFunction :: SQLFunction -lessThanFunction = SQLFunction { - functionName = "<", - minArgCount = 2, - argCountIsFixed = True} - -lessThanOrEqualToFunction :: SQLFunction -lessThanOrEqualToFunction = SQLFunction { - functionName = "<=", - minArgCount = 2, - argCountIsFixed = True} - -greaterThanFunction :: SQLFunction -greaterThanFunction = SQLFunction { - functionName = ">", - minArgCount = 2, - argCountIsFixed = True} - -greaterThanOrEqualToFunction :: SQLFunction -greaterThanOrEqualToFunction = SQLFunction { - functionName = ">=", - minArgCount = 2, - argCountIsFixed = True} - -andFunction :: SQLFunction -andFunction = SQLFunction { - functionName = "AND", - minArgCount = 2, - argCountIsFixed = True} - -orFunction :: SQLFunction -orFunction = SQLFunction { - functionName = "OR", - minArgCount = 2, - argCountIsFixed = True} - -concatenateFunction :: SQLFunction -concatenateFunction = SQLFunction { - functionName = "||", - minArgCount = 2, - argCountIsFixed = True} - -regexMatchFunction :: SQLFunction -regexMatchFunction = SQLFunction { - functionName = "=~", - minArgCount = 2, - argCountIsFixed = True} - --- Functions with special syntax -- -specialFunctions :: [SQLFunction] -specialFunctions = [substringFromFunction, - substringFromToFunction, - negateFunction, - notFunction] - --- | SUBSTRING(extraction_string FROM starting_position [FOR length] --- [COLLATE collation_name]) --- TODO implement COLLATE part -substringFromFunction :: SQLFunction -substringFromFunction = SQLFunction { - functionName = "SUBSTRING", - minArgCount = 2, - argCountIsFixed = True} - -substringFromToFunction :: SQLFunction -substringFromToFunction = SQLFunction { - functionName = "SUBSTRING", - minArgCount = 3, - argCountIsFixed = True} + functionArguments = [leftSubExpr, rightSubExpr], + stringRepresentation = + expressionToString leftSubExpr ++ " " ++ + functionName infixFunc ++ " " ++ + expressionToString rightSubExpr} parseSubstringFunction :: GenParser Char st Expression parseSubstringFunction = do - parseToken $ functionName substringFromFunction + funcStr <- parseToken $ functionName substringFromFunction eatSpacesAfter $ char '(' strExpr <- parseExpression - parseToken "FROM" + fromStr <- parseToken "FROM" startExpr <- parseExpression - maybeLength <- ifParseThen (parseToken "FOR") parseExpression + maybeForStrAndLength <- preservingIfParseThen (parseToken "FOR") parseExpression eatSpacesAfter $ char ')' - return $ case maybeLength of - Nothing -> FunctionExpression substringFromFunction [strExpr, startExpr] - Just len -> FunctionExpression substringFromToFunction [strExpr, startExpr, len] - -negateFunction :: SQLFunction -negateFunction = SQLFunction { - functionName = "-", - minArgCount = 1, - argCountIsFixed = True} + let funcStrStart = + funcStr ++ "(" ++ expressionToString strExpr ++ " " ++ + fromStr ++ expressionToString startExpr + + return $ case maybeForStrAndLength of + Nothing -> FunctionExpression + substringFromFunction + [strExpr, startExpr] + (funcStrStart ++ ")") + Just (forStr, lenExpr) -> FunctionExpression + substringFromToFunction + [strExpr, startExpr, lenExpr] + (funcStrStart ++ " " ++ forStr ++ " " ++ expressionToString lenExpr ++ ")") parseNegateFunction :: GenParser Char st Expression parseNegateFunction = do - parseToken "-" + funcStr <- parseToken $ functionName negateFunction expr <- parseAnyNonInfixExpression - return $ FunctionExpression negateFunction [expr] - -notFunction :: SQLFunction -notFunction = SQLFunction { - functionName = "NOT", - minArgCount = 1, - argCountIsFixed = True} + let funcWithExprsStr = funcStr ++ expressionToString expr + return $ FunctionExpression negateFunction [expr] funcWithExprsStr parseNotFunction :: GenParser Char st Expression parseNotFunction = do - parseToken $ functionName notFunction + funcStr <-parseToken $ functionName notFunction expr <- parseAnyNonInfixExpression - return $ FunctionExpression notFunction [expr] + let funcWithExprsStr = funcStr ++ expressionToString expr + return $ FunctionExpression notFunction [expr] funcWithExprsStr parseCountStar :: GenParser Char st Expression parseCountStar = do - try (parseToken $ functionName countFunction) - try parseStar <|> parseNormalFunctionArgs countFunction + funcStr <- try (parseToken $ functionName countFunction) + parenthesize (parseToken "*") - where - parseStar = do - parenthesize $ parseToken "*" - return $ FunctionExpression countFunction [IntegerConstantExpression 0] + return $ FunctionExpression countFunction [IntConstantExpression 0 "*"] (funcStr ++ "(*)") -------------------------------------------------------------------------------- -- Parse utility functions @@ -804,18 +385,7 @@ parseOpChar = oneOf opChars opChars :: [Char] -opChars = "~!@#$%^&*-+=|\\<>/?" - -withoutTrailing :: (Show s) => GenParser tok st s -> GenParser tok st a -> GenParser tok st a -withoutTrailing end p = p >>= (\x -> genNotFollowedBy end >> return x) - -withTrailing :: (Monad m) => m a -> m b -> m b -withTrailing end p = p >>= (\x -> end >> return x) - --- | like the lexeme function, this function eats all spaces after the given --- parser, but this one works for me and lexeme doesn't -eatSpacesAfter :: GenParser Char st a -> GenParser Char st a -eatSpacesAfter p = p >>= (\x -> spaces >> return x) +opChars = "~!@#$%^&*-+=|\\<>/?." -- | find out if the given string ends with an op char endsWithOp :: String -> Bool @@ -841,27 +411,17 @@ 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 :: Bool -> Char -> GenParser Char st String -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 - -escapedQuote :: Char -> GenParser Char st Char -escapedQuote quoteChar = string [quoteChar, quoteChar] >> return quoteChar - commaSeparator :: GenParser Char st Char commaSeparator = eatSpacesAfter $ char ',' +-- | Wraps braces parsers around the given inner parser +brace :: GenParser Char st a -> GenParser Char st a +brace innerParser = do + eatSpacesAfter $ char '[' + innerParseResults <- innerParser + eatSpacesAfter $ char ']' + return innerParseResults + -- | Wraps parentheses parsers around the given inner parser parenthesize :: GenParser Char st a -> GenParser Char st a parenthesize innerParser = do @@ -870,31 +430,6 @@ 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 = - (try leftParser >>= return . Left) <|> (rightParser >>= return . Right) --} - --- | 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 >>= return . Just - 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 :: GenParser Char st String parseReservedWord = let reservedWordParsers = map parseToken reservedWords @@ -906,60 +441,11 @@ map functionName normalSyntaxFunctions ++ map functionName (concat infixFunctions) ++ map functionName specialFunctions ++ - ["BY","CROSS", "FROM", "FOR", "GROUP", "HAVING", "INNER", "JOIN", "ON", "ORDER", "SELECT", "WHERE"] + ["BY","CROSS", "FROM", "FOR", "GROUP", "HAVING", "IN", "INNER", "JOIN", "ON", + "ORDER", "SELECT", "WHERE", "TRUE", "FALSE", "YIELD"] -- | 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 >>= return . Just) <|> return Nothing - --- | parse `itemParser`s seperated by exactly `minCount` `sepParser`s -sepByExactly :: Int -> GenParser tok st a -> GenParser tok st sep -> GenParser tok st [a] -sepByExactly itemCount itemParser sepParser = - let itemParsers = replicate itemCount 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 - tailResults <- - ifParseThenElse sepParser (sepBy itemParser sepParser) (return []) - - return $ minResults ++ tailResults diff --git a/Database/TxtSushi/Transform.hs b/Database/TxtSushi/Transform.hs deleted file mode 100644 --- a/Database/TxtSushi/Transform.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- | -Simple table transformations --} -module Database.TxtSushi.Transform ( - sortColumns, - joinTables, - crossJoinTables, - joinPresortedTables, - rowComparison) where - -import Data.List - --- | sort the given 'table' on the given columns -sortColumns :: (Ord a) => [Int] -> [[a]] -> [[a]] -sortColumns columns table = - sortBy (rowComparison columns) table - --- | compare two rows based on given column balues -rowComparison :: (Ord a) => [Int] -> [a] -> [a] -> Ordering -rowComparison [] _ _ = EQ -rowComparison (columnHead:columnsTail) row1 row2 = - let colComparison = (row1 !! columnHead) `compare` (row2 !! columnHead) - in - case colComparison of - EQ -> rowComparison columnsTail row1 row2 - _ -> colComparison - --- | 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 - -crossJoinTables :: [[a]] -> [[a]] -> [[a]] -crossJoinTables [] _ = [] -crossJoinTables _ [] = [] -crossJoinTables (table1HeadRow:table1Tail) table2 = - let - prependHead = (table1HeadRow ++) - newTable2 = map prependHead table2 - in - newTable2 ++ (crossJoinTables table1Tail table2) - -joinGroupedTables :: (Ord a) => [(Int, Int)] -> [[[a]]] -> [[[a]]] -> [[a]] -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 - _ -> - (crossJoinTables headTableGroup1 headTableGroup2) ++ - (joinGroupedTables joinColumnZipList tableGroupsTail1 tableGroupsTail2) - -asymmetricRowComparison :: (Ord a) => [(Int, Int)] -> [a] -> [a] -> Ordering -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 - _ -> colComparison diff --git a/Database/TxtSushi/Util/CommandLineArgument.hs b/Database/TxtSushi/Util/CommandLineArgument.hs deleted file mode 100644 --- a/Database/TxtSushi/Util/CommandLineArgument.hs +++ /dev/null @@ -1,183 +0,0 @@ -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 - -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 :: String -space = " " - -etc :: String -etc = "..." - --- | converts a command line description into a string version that --- you can show the user -formatCommandLine :: CommandLineDescription -> String -formatCommandLine commandLine = - let formattedOptions = formatOptions (options commandLine) - formattedTailArgs = formatTailArguments commandLine - in - if null formattedOptions || null formattedTailArgs then - formattedOptions ++ formattedTailArgs - else - formattedOptions ++ space ++ formattedTailArgs - -formatTailArguments :: CommandLineDescription -> String -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 :: OptionDescription -> String -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:_) = - case (find (\optDesc -> optionFlag optDesc == argHead) optDescs) of - Nothing -> - (Map.empty, argValues) - Just optDesc -> - let (optArgs, afterOptArgs) = extractOption optDesc optDescs (tail argValues) - (tailArgsMap, afterTailArgs) = extractOptions optDescs afterOptArgs - in (addOptionArgsToMap tailArgsMap optDesc optArgs, afterTailArgs) - -extractOption :: - OptionDescription -> - [OptionDescription] -> - [String] -> - ([String], [String]) -extractOption optDesc allOptDescs optArgsEtc = - let optArgExtent = argumentExtent optDesc allOptDescs optArgsEtc - in splitAt optArgExtent optArgsEtc - -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 diff --git a/Database/TxtSushi/Util/IOUtil.hs b/Database/TxtSushi/Util/IOUtil.hs deleted file mode 100644 --- a/Database/TxtSushi/Util/IOUtil.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Database.TxtSushi.Util.IOUtil ( - bufferStdioToTempFile, - getContentsFromFileOrStdin, - printSingleFileUsage) where - -import Data.List -import Data.Version (Version(..)) -import System.Directory -import System.Environment -import System.IO - -import Paths_txt_sushi - --- | buffers standard input to a temp file and returns a path to that file -bufferStdioToTempFile :: IO FilePath -bufferStdioToTempFile = do - stdioText <- getContents - tempDir <- getTemporaryDirectory - (tempFilePath, tempFileHandle) <- openTempFile tempDir "stdiobuffer.txt" - hPutStr tempFileHandle stdioText - hClose tempFileHandle - return tempFilePath - --- | if given "-" this file reads from stdin otherwise it reads from the named --- file -getContentsFromFileOrStdin :: String -> IO String -getContentsFromFileOrStdin filePath = - if filePath == "-" - then getContents - else readFile filePath - --- | print a cookie-cutter usage message for the command line utilities --- that take a single file name or "-" as input -printSingleFileUsage :: IO () -printSingleFileUsage = do - progName <- getProgName - putStrLn $ progName ++ " (" ++ versionStr ++ ")" - putStrLn $ "Usage: " ++ progName ++ " file_name_or_dash" - - where - versionStr = intercalate "." (map show . versionBranch $ version) diff --git a/Database/TxtSushi/Util/ListUtil.hs b/Database/TxtSushi/Util/ListUtil.hs deleted file mode 100644 --- a/Database/TxtSushi/Util/ListUtil.hs +++ /dev/null @@ -1,27 +0,0 @@ -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 @@ -1,197 +1,2 @@ -import Distribution.PackageDescription(PackageDescription) import Distribution.Simple -import Distribution.Simple.LocalBuildInfo(LocalBuildInfo) - -import Text.ParserCombinators.Parsec - -import Database.TxtSushi.SQLParser - -main = defaultMainWithHooks $ simpleUserHooks {runTests = runTxtSushiTests} - --------------------------------------------------------------------------------- --- Test code --------------------------------------------------------------------------------- - -runTxtSushiTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -runTxtSushiTests _ _ _ _ = do - let - -- test statement 1 - stmt1 = SelectStatement { - columnSelections = [ - ExpressionColumn {expression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}}, - AllColumnsFrom {sourceTableName = "table2"}], - maybeFromTable = Just ( - InnerJoin { - leftJoinTable = TableIdentifier {tableName = "table1", maybeTableAlias = Nothing}, - rightJoinTable = TableIdentifier {tableName = "table2", maybeTableAlias = Nothing}, - onCondition = FunctionExpression { - sqlFunction = SQLFunction {functionName = "=", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}, - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table2", columnId = "col1"}}]}, - maybeTableAlias = Nothing}), - maybeWhereFilter = Nothing, - orderByItems = [], - maybeGroupByHaving = Nothing} - stmt1_1Txt = - "select table1.col1, table2.* " ++ - "from table1 inner join table2 on table1.col1 = table2.col1" - stmt1_2Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1" - - -- test statement 2 - stmt2 = SelectStatement { - columnSelections = [ - ExpressionColumn {expression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}}, - AllColumnsFrom {sourceTableName = "table2"}], - maybeFromTable = Just ( - InnerJoin { - leftJoinTable = TableIdentifier {tableName = "table1", maybeTableAlias = Nothing}, - rightJoinTable = TableIdentifier {tableName = "table2", maybeTableAlias = Nothing}, - onCondition = FunctionExpression { - sqlFunction = SQLFunction {functionName = "=", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}, - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table2", columnId = "col1"}}]}, - maybeTableAlias = Nothing}), - maybeWhereFilter = Just ( - FunctionExpression { - sqlFunction = SQLFunction {functionName = "<>", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - FunctionExpression { - sqlFunction = SQLFunction {functionName = "UPPER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}, - FunctionExpression { - sqlFunction = SQLFunction {functionName = "LOWER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}), - orderByItems = [], - maybeGroupByHaving = Nothing} - stmt2_1Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper(table1.col1)<>lower(table1.col1)" - stmt2_2Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper(table1.col1) <> lower(table1.col1)" - - -- test statement 3 - stmt3 = SelectStatement { - columnSelections = [ - ExpressionColumn {expression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}}, - AllColumnsFrom {sourceTableName = "table2"}], - maybeFromTable = Just ( - InnerJoin { - leftJoinTable = TableIdentifier {tableName = "table1", maybeTableAlias = Nothing}, - rightJoinTable = TableIdentifier {tableName = "table2", maybeTableAlias = Nothing}, - onCondition = FunctionExpression { - sqlFunction = SQLFunction {functionName = "=", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}, - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table2", columnId = "col1"}}]}, - maybeTableAlias = Nothing}), - maybeWhereFilter = Just ( - FunctionExpression { - sqlFunction = SQLFunction {functionName = "<>", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - FunctionExpression { - sqlFunction = SQLFunction {functionName = "UPPER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}, - FunctionExpression { - sqlFunction = SQLFunction {functionName = "LOWER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}), - orderByItems = [OrderByItem { - orderExpression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "firstName"}}, - orderAscending = True}], - maybeGroupByHaving = Nothing} - stmt3_1Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper(table1.col1)<>lower(table1.col1) order by table1.firstName asc" - stmt3_2Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper(table1.col1)<>lower(table1.col1) order by table1.firstName" - stmt3_3Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper (table1.col1) <> lower ( table1.col1 ) order by table1.firstName ascending" - - -- test statement 4 - stmt4 = SelectStatement { - columnSelections = [ - ExpressionColumn {expression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}}, - AllColumnsFrom {sourceTableName = "table2"}], - maybeFromTable = Just ( - InnerJoin { - leftJoinTable = TableIdentifier {tableName = "table1", maybeTableAlias = Nothing}, - rightJoinTable = TableIdentifier {tableName = "table2", maybeTableAlias = Nothing}, - onCondition = FunctionExpression { - sqlFunction = SQLFunction {functionName = "=", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}, - ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table2", columnId = "col1"}}]}, - maybeTableAlias = Nothing}), - maybeWhereFilter = Just ( - FunctionExpression { - sqlFunction = SQLFunction {functionName = "<>", minArgCount = 2, argCountIsFixed = True}, - functionArguments = [ - FunctionExpression { - sqlFunction = SQLFunction {functionName = "UPPER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}, - FunctionExpression { - sqlFunction = SQLFunction {functionName = "LOWER", minArgCount = 1, argCountIsFixed = True}, - functionArguments = [ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "col1"}}]}]}), - orderByItems = [OrderByItem { - orderExpression = ColumnExpression {column = ColumnIdentifier {maybeTableName = Just "table1", columnId = "firstName"}}, - orderAscending = False}], - maybeGroupByHaving = Nothing} - stmt4_1Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper (table1.col1) <> lower ( table1.col1 ) order by table1.firstName descending" - stmt4_2Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper (table1.col1) <> lower ( table1.col1 ) order by table1.firstName DESCENDING" - stmt4_3Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper (table1.col1) <> lower ( table1.col1 ) order by table1.firstName desc" - stmt4_4Txt = - "select table1.col1, table2.* " ++ - "from table1 join table2 on table1.col1 = table2.col1 " ++ - "where upper (table1.col1) <> lower ( table1.col1 ) order by table1.firstName DESC" - - testSqlSelect stmt1 stmt1_1Txt - testSqlSelect stmt1 stmt1_2Txt - - testSqlSelect stmt2 stmt2_1Txt - testSqlSelect stmt2 stmt2_2Txt - - testSqlSelect stmt3 stmt3_1Txt - testSqlSelect stmt3 stmt3_2Txt - testSqlSelect stmt3 stmt3_3Txt - - testSqlSelect stmt4 stmt4_1Txt - testSqlSelect stmt4 stmt4_2Txt - testSqlSelect stmt4 stmt4_3Txt - testSqlSelect stmt4 stmt4_4Txt - -testSqlSelect :: SelectStatement -> String -> IO () -testSqlSelect expectedResult selectStatementText = do - let stmtParseResult = parse (withTrailing eof parseSelectStatement) "" selectStatementText - colNums = take (length selectStatementText) ([1 .. 9] ++ cycle [0 .. 9]) - putStrLn "" - putStrLn "Testing:" - putStrLn $ concat (map show colNums) - putStrLn selectStatementText - case stmtParseResult of - Left errMsg -> error $ show errMsg - Right selectStatement -> - if selectStatement == expectedResult - then - putStrLn "Success" - else - error $ "\n" ++ (show selectStatement) ++ "\nNOT EQUAL TO\n" ++ (show expectedResult) +main = defaultMain diff --git a/csvtopretty.hs b/csvtopretty.hs --- a/csvtopretty.hs +++ b/csvtopretty.hs @@ -2,8 +2,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/csvtotab.hs b/csvtotab.hs --- a/csvtotab.hs +++ b/csvtotab.hs @@ -1,8 +1,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/namecolumns.hs b/namecolumns.hs --- a/namecolumns.hs +++ b/namecolumns.hs @@ -1,8 +1,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/tabtocsv.hs b/tabtocsv.hs --- a/tabtocsv.hs +++ b/tabtocsv.hs @@ -1,8 +1,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/tabtopretty.hs b/tabtopretty.hs --- a/tabtopretty.hs +++ b/tabtopretty.hs @@ -2,8 +2,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/transposecsv.hs b/transposecsv.hs --- a/transposecsv.hs +++ b/transposecsv.hs @@ -2,8 +2,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/transposetab.hs b/transposetab.hs --- a/transposetab.hs +++ b/transposetab.hs @@ -2,8 +2,8 @@ import System.Environment import System.IO -import Database.TxtSushi.IO -import Database.TxtSushi.Util.IOUtil +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil main :: IO () main = do diff --git a/tssql.hs b/tssql.hs --- a/tssql.hs +++ b/tssql.hs @@ -9,20 +9,23 @@ -- Main entry point for the TxtSushi SQL command line -- ----------------------------------------------------------------------------- +import Data.Char import Data.List import Data.Version (Version(..)) -import qualified Data.Map as Map +import qualified Data.Map as M import System.Environment import System.Exit import System.IO import Text.ParserCombinators.Parsec -import Database.TxtSushi.IO +import Database.TxtSushi.CommandLineArgument +import Database.TxtSushi.FlatFile +import Database.TxtSushi.IOUtil +import Database.TxtSushi.ParseUtil import Database.TxtSushi.SQLExecution +import Database.TxtSushi.SQLFunctionDefinitions import Database.TxtSushi.SQLParser -import Database.TxtSushi.Util.CommandLineArgument -import Database.TxtSushi.Util.IOUtil import Paths_txt_sushi @@ -30,9 +33,9 @@ helpOption = OptionDescription { isRequired = False, optionFlag = "-help", - argumentNames = [], + argumentNames = ["function_name"], minArgumentCount = 0, - argumentCountIsFixed = True} + argumentCountIsFixed = False} externalSortOption :: OptionDescription externalSortOption = OptionDescription { @@ -56,7 +59,7 @@ sqlCmdLine :: CommandLineDescription sqlCmdLine = CommandLineDescription { options = allOpts, - minTailArgumentCount = 1, + minTailArgumentCount = 0, tailArgumentNames = ["SQL_select_statement"], tailArgumentCountIsFixed = True} @@ -69,12 +72,12 @@ error $ "The given table name \"" ++ argTblHead ++ "\" does not appear in the SELECT statement" -tableArgsToMap :: [[String]] -> Map.Map String String -tableArgsToMap [] = Map.empty +tableArgsToMap :: [[String]] -> M.Map String String +tableArgsToMap [] = M.empty tableArgsToMap (currTableArgs:tailTableArgs) = case currTableArgs of [fileName, tblName] -> - Map.insert fileName tblName (tableArgsToMap tailTableArgs) + M.insert fileName tblName (tableArgsToMap tailTableArgs) _ -> error $ "the \"" ++ (optionFlag tableDefOption) ++ "\" option should have exactly two arguments" @@ -93,50 +96,74 @@ where versionStr = intercalate "." (map show $ versionBranch version) -argsToSortConfig :: Map.Map OptionDescription a -> SortConfiguration +argsToSortConfig :: M.Map OptionDescription a -> SortConfiguration argsToSortConfig argMap = - if Map.member externalSortOption argMap then UseExternalSort else UseInMemorySort + if M.member externalSortOption argMap then UseExternalSort else UseInMemorySort +-- | the help map is a mapping from function name to a string pair +-- where fst is the grammar and snd is the description +helpMap :: M.Map String (String, String) +helpMap = M.fromList allFuncHelp + where + allFuncHelp = + map funcToHelp $ normalSyntaxFunctions ++ concat infixFunctions ++ specialFunctions + funcToHelp sqlFunc = + (map toUpper . functionName $ sqlFunc, (functionGrammar sqlFunc, functionDescription sqlFunc)) + +printHelpTerms :: IO () +printHelpTerms = putStrLn $ "Functions (can be used with -help option): " ++ intercalate ", " helpTerms + where helpTerms = sort . M.keys $ helpMap + +printTermHelp :: String -> IO () +printTermHelp term = case M.lookup (map toUpper term) helpMap of + Just (grammar, description) -> + putStrLn grammar >> putChar '\t' >> putStrLn description + Nothing -> + putStrLn $ "\"" ++ term ++ "\" is not a known function" + main :: IO () main = do args <- getArgs progName <- getProgName let (argMap, argTail) = extractCommandLineArguments sqlCmdLine args - showHelp = Map.member helpOption argMap || length argTail /= 1 parseOutcome = parse (withTrailing eof parseSelectStatement) "" (head argTail) - if showHelp then printUsage progName else - case parseOutcome of - Left err -> print err - Right selectStmt -> - let - -- create a table file map from the user args - tableArgs = Map.findWithDefault [] tableDefOption argMap - tableArgMap = tableArgsToMap tableArgs - - -- get a default table to file map from the select statement - selectTblNames = allMaybeTableNames (maybeFromTable selectStmt) - defaultTblMap = Map.fromList (zip selectTblNames selectTblNames) - - -- join the two with arg values taking precidence over - -- the default values - finalTblFileMap = tableArgMap `Map.union` defaultTblMap - in - -- turn the files into strings - if validateTableNames (Map.keys tableArgMap) selectTblNames - then do - let contentsMap = Map.map getContentsFromFileOrStdin finalTblFileMap - - unwrappedContents <- unwrapMapList $ Map.toList contentsMap - - let unwrappedContentsMap = Map.fromList unwrappedContents - textTableMap = Map.map (parseTable csvFormat) unwrappedContentsMap - dbTableMap = Map.mapWithKey textTableToDatabaseTable textTableMap - sortCfg = argsToSortConfig argMap - selectedDbTable = select sortCfg selectStmt dbTableMap - selectedTxtTable = databaseTableToTextTable selectedDbTable - - putStr $ formatTable csvFormat selectedTxtTable - else - exitFailure + case M.lookup helpOption argMap of + Just terms -> case concat terms of + [] -> printUsage progName >> printHelpTerms + concatTerms -> printUsage progName >> mapM_ printTermHelp concatTerms + Nothing -> + if length argTail /= 1 then printUsage progName >> printHelpTerms else case parseOutcome of + Left err -> print err + Right selectStmt -> + let + -- create a table file map from the user args + tableArgs = M.findWithDefault [] tableDefOption argMap + tableArgMap = tableArgsToMap tableArgs + + -- get a default table to file map from the select statement + selectTblNames = allMaybeTableNames (maybeFromTable selectStmt) + defaultTblMap = M.fromList (zip selectTblNames selectTblNames) + + -- join the two with arg values taking precidence over + -- the default values + finalTblFileMap = tableArgMap `M.union` defaultTblMap + in + -- turn the files into strings + if validateTableNames (M.keys tableArgMap) selectTblNames + then do + let contentsMap = M.map getContentsFromFileOrStdin finalTblFileMap + + unwrappedContents <- unwrapMapList $ M.toList contentsMap + + let unwrappedContentsMap = M.fromList unwrappedContents + textTableMap = M.map (parseTable csvFormat) unwrappedContentsMap + dbTableMap = M.mapWithKey textTableToDatabaseTable textTableMap + sortCfg = argsToSortConfig argMap + selectedDbTable = select sortCfg selectStmt dbTableMap + selectedTxtTable = databaseTableToTextTable selectedDbTable + + putStr $ formatTable csvFormat selectedTxtTable + else + exitFailure diff --git a/txt-sushi.cabal b/txt-sushi.cabal --- a/txt-sushi.cabal +++ b/txt-sushi.cabal @@ -1,6 +1,6 @@ Name: txt-sushi -Version: 0.4.0 -Synopsis: Spreadsheets are databases! +Version: 0.5.0 +Synopsis: The SQL link in your *NIX chain Description: TxtSushi is a collection of command line utilities for processing comma-separated and tab-delimited files (AKA flat files, spreadsheets). @@ -16,7 +16,7 @@ Homepage: http://keithsheppard.name/txt-sushi Bug-Reports: http://code.google.com/p/txt-sushi/issues/list Build-Type: Simple -Category: Database, Utils, Text +Category: Database, Console Cabal-Version: >= 1.6 Source-Repository head @@ -26,7 +26,7 @@ Source-Repository this type: darcs location: http://patch-tag.com/r/keithshep/txt-sushi/pullrepo - tag: 0.4.0 + tag: 0.5.0 Executable tssql Main-Is: tssql.hs @@ -65,14 +65,17 @@ Library Exposed-Modules: + Database.TxtSushi.CommandLineArgument + Database.TxtSushi.EvaluatedExpression Database.TxtSushi.ExternalSort - Database.TxtSushi.IO + Database.TxtSushi.FlatFile + Database.TxtSushi.IOUtil + Database.TxtSushi.ParseUtil + Database.TxtSushi.Relational Database.TxtSushi.SQLExecution + Database.TxtSushi.SQLExpression + Database.TxtSushi.SQLFunctionDefinitions Database.TxtSushi.SQLParser - Database.TxtSushi.Transform - Database.TxtSushi.Util.CommandLineArgument - Database.TxtSushi.Util.IOUtil - Database.TxtSushi.Util.ListUtil Build-Depends: base >= 3 && < 5,binary,bytestring,containers,directory,parsec,regex-posix GHC-Options: -O2 -Wall