txt-sushi 0.4.0 → 0.5.0

raw patch · 25 files changed

+2286/−2146 lines, 25 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Database/TxtSushi/CommandLineArgument.hs +183/−0
• Database/TxtSushi/EvaluatedExpression.hs +135/−0
• Database/TxtSushi/FlatFile.hs +233/−0
• Database/TxtSushi/IO.hs +0/−206
• Database/TxtSushi/IOUtil.hs +41/−0
• Database/TxtSushi/ParseUtil.hs +194/−0
• Database/TxtSushi/Relational.hs +76/−0
• Database/TxtSushi/SQLExecution.hs +531/−726
• Database/TxtSushi/SQLExpression.hs +166/−0
• Database/TxtSushi/SQLFunctionDefinitions.hs +532/−0
• Database/TxtSushi/SQLParser.hs +94/−608
• Database/TxtSushi/Transform.hs +0/−89
• Database/TxtSushi/Util/CommandLineArgument.hs +0/−183
• Database/TxtSushi/Util/IOUtil.hs +0/−41
• Database/TxtSushi/Util/ListUtil.hs +0/−27
• Setup.hs +1/−196
• csvtopretty.hs +2/−2
• csvtotab.hs +2/−2
• namecolumns.hs +2/−2
• tabtocsv.hs +2/−2
• tabtopretty.hs +2/−2
• transposecsv.hs +2/−2
• transposetab.hs +2/−2
• tssql.hs +74/−47
• txt-sushi.cabal +12/−9

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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