diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Jake Wheat +Copyright (c) 2013, 2014, 2015, Jake Wheat All rights reserved. diff --git a/Language/SQL/SimpleSQL/Combinators.lhs b/Language/SQL/SimpleSQL/Combinators.lhs --- a/Language/SQL/SimpleSQL/Combinators.lhs +++ b/Language/SQL/SimpleSQL/Combinators.lhs @@ -17,9 +17,8 @@ > import Control.Applicative ((<$>), (<*>), (<**>), pure, Applicative) > import Text.Parsec (option,many) -> import Text.Parsec.Prim (Parsec) +> import Text.Parsec.String (GenParser) -> type Parser s = Parsec String s a possible issue with the option suffix is that it enforces left associativity when chaining it recursively. Have to review @@ -29,7 +28,7 @@ This function style is not good, and should be replaced with chain and which has a different type -> optionSuffix :: (a -> Parser s a) -> a -> Parser s a +> optionSuffix :: (a -> GenParser t s a) -> a -> GenParser t s a > optionSuffix p a = option a (p a) @@ -39,7 +38,7 @@ TODO: make sure the precedence higher than <|> and lower than the other operators so it can be used nicely -> () :: Parser s a -> Parser s (a -> a) -> Parser s a +> () :: GenParser t s a -> GenParser t s (a -> a) -> GenParser t s a > p q = p <**> option id q @@ -80,7 +79,7 @@ a second or more suffix parser contingent on the first suffix parser succeeding. -> () :: Parser s (a -> a) -> Parser s (a -> a) -> Parser s (a -> a) +> () :: GenParser t s (a -> a) -> GenParser t s (a -> a) -> GenParser t s (a -> a) > () pa pb = (.) `c` pa <*> option id pb > -- todo: fix this mess > where c = (<$>) . flip @@ -88,7 +87,7 @@ 0 to many repeated applications of suffix parser -> () :: Parser s a -> Parser s (a -> a) -> Parser s a +> () :: GenParser t s a -> GenParser t s (a -> a) -> GenParser t s a > p q = foldr ($) <$> p <*> (reverse <$> many q) diff --git a/Language/SQL/SimpleSQL/Dialect.lhs b/Language/SQL/SimpleSQL/Dialect.lhs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Dialect.lhs @@ -0,0 +1,54 @@ + + +Data types to represent different dialect options + +> {-# LANGUAGE DeriveDataTypeable #-} +> module Language.SQL.SimpleSQL.Dialect +> (SyntaxFlavour(..) +> ,Dialect(..) +> ,ansi2011 +> ,mysql +> ,postgres +> ,oracle +> ,sqlserver +> ) where + +> import Data.Data + + +hack for now, later will expand to flags on a feature by feature basis + +> data SyntaxFlavour = ANSI2011 +> | MySQL +> | Postgres +> | Oracle +> | SQLServer +> deriving (Eq,Show,Read,Data,Typeable) + +> -- | Used to set the dialect used for parsing and pretty printing, +> -- very unfinished at the moment. +> data Dialect = Dialect {diSyntaxFlavour :: SyntaxFlavour +> ,allowOdbc :: Bool} +> deriving (Eq,Show,Read,Data,Typeable) + +> -- | ansi sql 2011 dialect +> ansi2011 :: Dialect +> ansi2011 = Dialect ANSI2011 False + +> -- | mysql dialect +> mysql :: Dialect +> mysql = Dialect MySQL False + +> -- | postgresql dialect +> postgres :: Dialect +> postgres = Dialect Postgres False + +> -- | oracle dialect +> oracle :: Dialect +> oracle = Dialect Oracle False + +> -- | microsoft sql server dialect +> sqlserver :: Dialect +> sqlserver = Dialect SQLServer False + + diff --git a/Language/SQL/SimpleSQL/Lex.lhs b/Language/SQL/SimpleSQL/Lex.lhs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Lex.lhs @@ -0,0 +1,717 @@ + +The parser uses a separate lexer for two reasons: + +1. sql syntax is very awkward to parse, the separate lexer makes it +easier to handle this in most places (in some places it makes it +harder or impossible, the fix is to switch to something better than +parsec) + +2. using a separate lexer gives a huge speed boost because it reduces +backtracking. (We could get this by making the parsing code a lot more +complex also.) + +3. we can test the lexer relatively exhaustively, then even when we +don't do nearly as comprehensive testing on the syntax level, we still +have a relatively high assurance of the low level of bugs. This is +much more difficult to get parity with when testing the syntax parser +directly without the separately testing lexing stage. + +> -- | Lexer for SQL. +> {-# LANGUAGE TupleSections #-} +> module Language.SQL.SimpleSQL.Lex +> (Token(..) +> ,lexSQL +> ,prettyToken +> ,prettyTokens +> ,ParseError(..) +> ,Dialect(..) +> ,tokenListWillPrintAndLex +> ) where + +> import Language.SQL.SimpleSQL.Dialect + +> import Text.Parsec (option,string,manyTill,anyChar +> ,try,string,many1,oneOf,digit,(<|>),choice,char,eof +> ,many,runParser,lookAhead,satisfy +> ,setPosition,getPosition +> ,setSourceColumn,setSourceLine +> ,sourceName, setSourceName +> ,sourceLine, sourceColumn +> ,notFollowedBy) +> import Language.SQL.SimpleSQL.Combinators +> import Language.SQL.SimpleSQL.Errors +> import Control.Applicative hiding ((<|>), many) +> import Data.Char +> import Control.Monad +> import Prelude hiding (takeWhile) +> import Text.Parsec.String (Parser) +> import Data.Maybe + + +> -- | Represents a lexed token +> data Token +> -- | A symbol (in ansi dialect) is one of the following +> -- +> -- * multi char symbols <> \<= \>= != || +> -- * single char symbols: * + - < > ^ / % ~ & | ? ( ) [ ] , ; ( ) +> -- +> = Symbol String +> +> -- | This is an identifier or keyword. The first field is +> -- the quotes used, or nothing if no quotes were used. The quotes +> -- can be " or u& or something dialect specific like [] +> | Identifier (Maybe (String,String)) String +> +> -- | This is a prefixed variable symbol, such as :var, @var or #var +> -- (only :var is used in ansi dialect) +> | PrefixedVariable Char String +> +> -- | This is a positional arg identifier e.g. $1 +> | PositionalArg Int +> +> -- | This is a string literal. The first two fields are the -- +> -- start and end quotes, which are usually both ', but can be +> -- the character set (one of nNbBxX, or u&, U&), or a dialect +> -- specific string quoting (such as $$ in postgres) +> | SqlString String String String +> +> -- | A number literal (integral or otherwise), stored in original format +> -- unchanged +> | SqlNumber String +> +> -- | Whitespace, one or more of space, tab or newline. +> | Whitespace String +> +> -- | A commented line using --, contains every character starting with the +> -- \'--\' and including the terminating newline character if there is one +> -- - this will be missing if the last line in the source is a line comment +> -- with no trailing newline +> | LineComment String +> +> -- | A block comment, \/* stuff *\/, includes the comment delimiters +> | BlockComment String +> +> deriving (Eq,Show) + + + +> -- | Pretty printing, if you lex a bunch of tokens, then pretty +> -- print them, should should get back exactly the same string +> prettyToken :: Dialect -> Token -> String +> prettyToken _ (Symbol s) = s +> prettyToken _ (Identifier Nothing t) = t +> prettyToken _ (Identifier (Just (q1,q2)) t) = q1 ++ t ++ q2 +> prettyToken _ (PrefixedVariable c p) = c:p +> prettyToken _ (PositionalArg p) = '$':show p +> prettyToken _ (SqlString s e t) = s ++ t ++ e +> prettyToken _ (SqlNumber r) = r +> prettyToken _ (Whitespace t) = t +> prettyToken _ (LineComment l) = l +> prettyToken _ (BlockComment c) = c + +> prettyTokens :: Dialect -> [Token] -> String +> prettyTokens d ts = concat $ map (prettyToken d) ts + +TODO: try to make all parsers applicative only + +> -- | Lex some SQL to a list of tokens. +> lexSQL :: Dialect +> -- ^ dialect of SQL to use +> -> FilePath +> -- ^ filename to use in error messages +> -> Maybe (Int,Int) +> -- ^ line number and column number of the first character +> -- in the source to use in error messages +> -> String +> -- ^ the SQL source to lex +> -> Either ParseError [((String,Int,Int),Token)] +> lexSQL dialect fn' p src = +> let (l',c') = fromMaybe (1,1) p +> in either (Left . convParseError src) Right +> $ runParser (setPos (fn',l',c') *> many (sqlToken dialect) <* eof) () fn' src +> where +> setPos (fn,l,c) = do +> fmap (flip setSourceName fn +> . flip setSourceLine l +> . flip setSourceColumn c) getPosition +> >>= setPosition + +> -- | parser for a sql token +> sqlToken :: Dialect -> Parser ((String,Int,Int),Token) +> sqlToken d = do +> p' <- getPosition +> let p = (sourceName p',sourceLine p', sourceColumn p') + +The order of parsers is important: strings and quoted identifiers can +start out looking like normal identifiers, so we try to parse these +first and use a little bit of try. Line and block comments start like +symbols, so we try these before symbol. Numbers can start with a . so +this is also tried before symbol (a .1 will be parsed as a number, but +. otherwise will be parsed as a symbol). + +> (p,) <$> choice [sqlString d +> ,identifier d +> ,lineComment d +> ,blockComment d +> ,sqlNumber d +> ,positionalArg d +> ,dontParseEndBlockComment d +> ,prefixedVariable d +> ,symbol d +> ,sqlWhitespace d] + +Parses identifiers: + +simple_identifier_23 +u&"unicode quoted identifier" +"quoted identifier" +"quoted identifier "" with double quote char" +`mysql quoted identifier` + +> identifier :: Dialect -> Parser Token +> identifier d = +> choice +> [quotedIden +> ,unicodeQuotedIden +> ,regularIden +> ,guard (diSyntaxFlavour d == MySQL) >> mySqlQuotedIden +> ,guard (diSyntaxFlavour d == SQLServer) >> sqlServerQuotedIden +> ] +> where +> regularIden = Identifier Nothing <$> identifierString +> quotedIden = Identifier (Just ("\"","\"")) <$> qidenPart +> mySqlQuotedIden = Identifier (Just ("`","`")) +> <$> (char '`' *> takeWhile1 (/='`') <* char '`') +> sqlServerQuotedIden = Identifier (Just ("[","]")) +> <$> (char '[' *> takeWhile1 (`notElem` "[]") <* char ']') +> -- try is used here to avoid a conflict with identifiers +> -- and quoted strings which also start with a 'u' +> unicodeQuotedIden = Identifier +> <$> (f <$> try (oneOf "uU" <* string "&")) +> <*> qidenPart +> where f x = Just (x: "&\"", "\"") +> qidenPart = char '"' *> qidenSuffix "" +> qidenSuffix t = do +> s <- takeTill (=='"') +> void $ char '"' +> -- deal with "" as literal double quote character +> choice [do +> void $ char '"' +> qidenSuffix $ concat [t,s,"\"\""] +> ,return $ concat [t,s]] + + +This parses a valid identifier without quotes. + +> identifierString :: Parser String +> identifierString = +> startsWith (\c -> c == '_' || isAlpha c) isIdentifierChar + +this can be moved to the dialect at some point + +> isIdentifierChar :: Char -> Bool +> isIdentifierChar c = c == '_' || isAlphaNum c + +use try because : and @ can be part of other things also + +> prefixedVariable :: Dialect -> Parser Token +> prefixedVariable d = try $ choice +> [PrefixedVariable <$> char ':' <*> identifierString +> ,guard (diSyntaxFlavour d == SQLServer) >> +> PrefixedVariable <$> char '@' <*> identifierString +> ,guard (diSyntaxFlavour d == SQLServer) >> +> PrefixedVariable <$> char '#' <*> identifierString +> ] + +> positionalArg :: Dialect -> Parser Token +> positionalArg d = +> guard (diSyntaxFlavour d == Postgres) >> +> -- use try to avoid ambiguities with other syntax which starts with dollar +> PositionalArg <$> try (char '$' *> (read <$> many1 digit)) + + +Parse a SQL string. Examples: + +'basic string' +'string with '' a quote' +n'international text' +b'binary string' +x'hexidecimal string' + + +> sqlString :: Dialect -> Parser Token +> sqlString d = dollarString <|> csString <|> normalString +> where +> dollarString = do +> guard $ diSyntaxFlavour d == Postgres +> -- use try because of ambiguity with symbols and with +> -- positional arg +> delim <- (\x -> concat ["$",x,"$"]) +> <$> try (char '$' *> option "" identifierString <* char '$') +> SqlString delim delim <$> manyTill anyChar (try $ string delim) +> normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix False "") +> normalStringSuffix allowBackslash t = do +> s <- takeTill $ if allowBackslash +> then (`elem` "'\\") +> else (== '\'') +> -- deal with '' or \' as literal quote character +> choice [do +> ctu <- choice ["''" <$ try (string "''") +> ,"\\'" <$ string "\\'" +> ,"\\" <$ char '\\'] +> normalStringSuffix allowBackslash $ concat [t,s,ctu] +> ,concat [t,s] <$ char '\''] +> -- try is used to to avoid conflicts with +> -- identifiers which can start with n,b,x,u +> -- once we read the quote type and the starting ' +> -- then we commit to a string +> -- it's possible that this will reject some valid syntax +> -- but only pathalogical stuff, and I think the improved +> -- error messages and user predictability make it a good +> -- pragmatic choice +> csString +> | diSyntaxFlavour d == Postgres = +> choice [SqlString <$> try (string "e'" <|> string "E'") +> <*> return "'" <*> normalStringSuffix True "" +> ,csString'] +> | otherwise = csString' +> csString' = SqlString +> <$> try cs +> <*> return "'" +> <*> normalStringSuffix False "" +> csPrefixes = "nNbBxX" +> cs = choice $ (map (\x -> string ([x] ++ "'")) csPrefixes) +> ++ [string "u&'" +> ,string "U&'"] + +numbers + +digits +digits.[digits][e[+-]digits] +[digits].digits[e[+-]digits] +digitse[+-]digits + +where digits is one or more decimal digits (0 through 9). At least one +digit must be before or after the decimal point, if one is used. At +least one digit must follow the exponent marker (e), if one is +present. There cannot be any spaces or other characters embedded in +the constant. Note that any leading plus or minus sign is not actually +considered part of the constant; it is an operator applied to the +constant. + +> sqlNumber :: Dialect -> Parser Token +> sqlNumber d = +> SqlNumber <$> completeNumber +> -- this is for definitely avoiding possibly ambiguous source +> <* choice [-- special case to allow e.g. 1..2 +> guard (diSyntaxFlavour d == Postgres) +> *> (void $ lookAhead $ try $ string "..") +> <|> void (notFollowedBy (oneOf "eE.")) +> ,notFollowedBy (oneOf "eE.") +> ] +> where +> completeNumber = +> (int (pp dot pp int) +> -- try is used in case we read a dot +> -- and it isn't part of a number +> -- if there are any following digits, then we commit +> -- to it being a number and not something else +> <|> try ((++) <$> dot <*> int)) +> pp expon + +> int = many1 digit +> -- make sure we don't parse two adjacent dots in a number +> -- special case for postgresql, we backtrack if we see two adjacent dots +> -- to parse 1..2, but in other dialects we commit to the failure +> dot = let p = string "." <* notFollowedBy (char '.') +> in if (diSyntaxFlavour d == Postgres) +> then try p +> else p +> expon = (:) <$> oneOf "eE" <*> sInt +> sInt = (++) <$> option "" (string "+" <|> string "-") <*> int +> pp = (<$$> (++)) + +Symbols + +A symbol is an operator, or one of the misc symbols which include: +. .. := : :: ( ) ? ; , { } (for odbc) + +The postgresql operator syntax allows a huge range of operators +compared with ansi and other dialects + +> symbol :: Dialect -> Parser Token +> symbol d = Symbol <$> choice (concat +> [dots +> ,if (diSyntaxFlavour d == Postgres) +> then postgresExtraSymbols +> else [] +> ,miscSymbol +> ,if allowOdbc d then odbcSymbol else [] +> ,if (diSyntaxFlavour d == Postgres) +> then generalizedPostgresqlOperator +> else basicAnsiOps +> ]) +> where +> dots = [many1 (char '.')] +> odbcSymbol = [string "{", string "}"] +> postgresExtraSymbols = +> [try (string ":=") +> -- parse :: and : and avoid allowing ::: or more +> ,try (string "::" <* notFollowedBy (char ':')) +> ,try (string ":" <* notFollowedBy (char ':'))] +> miscSymbol = map (string . (:[])) $ +> case diSyntaxFlavour d of +> SQLServer -> ",;():?" +> Postgres -> "[],;()" +> _ -> "[],;():?" + +try is used because most of the first characters of the two character +symbols can also be part of a single character symbol + +> basicAnsiOps = map (try . string) [">=","<=","!=","<>"] +> ++ map (string . (:[])) "+-^*/%~&<>=" +> ++ pipes +> pipes = -- what about using many1 (char '|'), then it will +> -- fail in the parser? Not sure exactly how +> -- standalone the lexer should be +> [char '|' *> +> choice ["||" <$ char '|' <* notFollowedBy (char '|') +> ,return "|"]] + +postgresql generalized operators + +this includes the custom operators that postgres supports, +plus all the standard operators which could be custom operators +according to their grammar + +rules + +An operator name is a sequence of up to NAMEDATALEN-1 (63 by default) characters from the following list: + ++ - * / < > = ~ ! @ # % ^ & | ` ? + +There are a few restrictions on operator names, however: +-- and /* cannot appear anywhere in an operator name, since they will be taken as the start of a comment. + +A multiple-character operator name cannot end in + or -, unless the name also contains at least one of these characters: + +~ ! @ # % ^ & | ` ? + +which allows the last character of a multi character symbol to be + or +- + +> generalizedPostgresqlOperator :: [Parser String] +> generalizedPostgresqlOperator = [singlePlusMinus,opMoreChars] +> where +> allOpSymbols = "+-*/<>=~!@#%^&|`?" +> -- these are the symbols when if part of a multi character +> -- operator permit the operator to end with a + or - symbol +> exceptionOpSymbols = "~!@#%^&|`?" + +> -- special case for parsing a single + or - symbol +> singlePlusMinus = try $ do +> c <- oneOf "+-" +> notFollowedBy $ oneOf allOpSymbols +> return [c] + +> -- this is used when we are parsing a potentially multi symbol +> -- operator and we have alread seen one of the 'exception chars' +> -- and so we can end with a + or - +> moreOpCharsException = do +> c <- oneOf (filter (`notElem` "-/*") allOpSymbols) +> -- make sure we don't parse a comment starting token +> -- as part of an operator +> <|> try (char '/' <* notFollowedBy (char '*')) +> <|> try (char '-' <* notFollowedBy (char '-')) +> -- and make sure we don't parse a block comment end +> -- as part of another symbol +> <|> try (char '*' <* notFollowedBy (char '/')) +> (c:) <$> option [] moreOpCharsException + +> opMoreChars = choice +> [-- parse an exception char, now we can finish with a + - +> (:) +> <$> oneOf exceptionOpSymbols +> <*> option [] moreOpCharsException +> ,(:) +> <$> (-- parse +, make sure it isn't the last symbol +> try (char '+' <* lookAhead (oneOf allOpSymbols)) +> <|> -- parse -, make sure it isn't the last symbol +> -- or the start of a -- comment +> try (char '-' +> <* notFollowedBy (char '-') +> <* lookAhead (oneOf allOpSymbols)) +> <|> -- parse / check it isn't the start of a /* comment +> try (char '/' <* notFollowedBy (char '*')) +> <|> -- make sure we don't parse */ as part of a symbol +> try (char '*' <* notFollowedBy (char '/')) +> <|> -- any other ansi operator symbol +> oneOf "<>=") +> <*> option [] opMoreChars +> ] + +> sqlWhitespace :: Dialect -> Parser Token +> sqlWhitespace _ = Whitespace <$> many1 (satisfy isSpace) + +> lineComment :: Dialect -> Parser Token +> lineComment _ = +> (\s -> LineComment $ concat ["--",s]) <$> +> -- try is used here in case we see a - symbol +> -- once we read two -- then we commit to the comment token +> (try (string "--") *> ( +> -- todo: there must be a better way to do this +> conc <$> manyTill anyChar (lookAhead lineCommentEnd) <*> lineCommentEnd)) +> where +> conc a Nothing = a +> conc a (Just b) = a ++ b +> lineCommentEnd = +> Just "\n" <$ char '\n' +> <|> Nothing <$ eof + +Try is used in the block comment for the two symbol bits because we +want to backtrack if we read the first symbol but the second symbol +isn't there. + +> blockComment :: Dialect -> Parser Token +> blockComment _ = +> (\s -> BlockComment $ concat ["/*",s]) <$> +> (try (string "/*") *> commentSuffix 0) +> where +> commentSuffix :: Int -> Parser String +> commentSuffix n = do +> -- read until a possible end comment or nested comment +> x <- takeWhile (\e -> e /= '/' && e /= '*') +> choice [-- close comment: if the nesting is 0, done +> -- otherwise recurse on commentSuffix +> try (string "*/") *> let t = concat [x,"*/"] +> in if n == 0 +> then return t +> else (\s -> concat [t,s]) <$> commentSuffix (n - 1) +> -- nested comment, recurse +> ,try (string "/*") *> ((\s -> concat [x,"/*",s]) <$> commentSuffix (n + 1)) +> -- not an end comment or nested comment, continue +> ,(\c s -> x ++ [c] ++ s) <$> anyChar <*> commentSuffix n] + + +This is to improve user experience: provide an error if we see */ +outside a comment. This could potentially break postgres ops with */ +in them (which is a stupid thing to do). In other cases, the user +should write * / instead (I can't think of any cases when this would +be valid syntax though). + +> dontParseEndBlockComment :: Dialect -> Parser Token +> dontParseEndBlockComment _ = +> -- don't use try, then it should commit to the error +> try (string "*/") *> fail "comment end without comment start" + + +Some helper combinators + +> startsWith :: (Char -> Bool) -> (Char -> Bool) -> Parser String +> startsWith p ps = do +> c <- satisfy p +> choice [(:) c <$> (takeWhile1 ps) +> ,return [c]] + +> takeWhile1 :: (Char -> Bool) -> Parser String +> takeWhile1 p = many1 (satisfy p) + +> takeWhile :: (Char -> Bool) -> Parser String +> takeWhile p = many (satisfy p) + +> takeTill :: (Char -> Bool) -> Parser String +> takeTill p = manyTill anyChar (peekSatisfy p) + +> peekSatisfy :: (Char -> Bool) -> Parser () +> peekSatisfy p = void $ lookAhead (satisfy p) + +This utility function will accurately report if the two tokens are +pretty printed, if they should lex back to the same two tokens. This +function is used in testing (and can be used in other places), and +must not be implemented by actually trying to print both tokens and +then lex them back from a single string (because then we would have +the risk of thinking two tokens cannot be together when there is bug +in the lexer, which the testing is supposed to find). + +maybe do some quick checking to make sure this function only gives +true negatives: check pairs which return false actually fail to lex or +give different symbols in return: could use quickcheck for this + +a good sanity test for this function is to change it to always return +true, then check that the automated tests return the same number of +successes. I don't think it succeeds this test at the moment + +> -- | Utility function to tell you if a list of tokens +> -- will pretty print then lex back to the same set of tokens. +> -- Used internally, might be useful for generating SQL via lexical tokens. +> tokenListWillPrintAndLex :: Dialect -> [Token] -> Bool +> tokenListWillPrintAndLex _ [] = True +> tokenListWillPrintAndLex _ [_] = True +> tokenListWillPrintAndLex d (a:b:xs) = +> tokensWillPrintAndLex d a b && tokenListWillPrintAndLex d (b:xs) + +> tokensWillPrintAndLex :: Dialect -> Token -> Token -> Bool +> tokensWillPrintAndLex d a b + +a : followed by an identifier character will look like a host param +followed by = or : makes a different symbol + +> | Symbol ":" <- a +> , checkFirstBChar (\x -> isIdentifierChar x || x `elem` ":=") = False + +two symbols next to eachother will fail if the symbols can combine and +(possibly just the prefix) look like a different symbol + +> | Dialect {diSyntaxFlavour = Postgres} <- d +> , Symbol a' <- a +> , Symbol b' <- b +> , b' `notElem` ["+", "-"] || or (map (`elem` a') "~!@#%^&|`?") = False + +check two adjacent symbols in non postgres where the combination +possibilities are much more limited. This is ansi behaviour, it might +be different when the other dialects are done properly + +> | Symbol a' <- a +> , Symbol b' <- b +> , (a',b') `elem` [("<",">") +> ,("<","=") +> ,(">","=") +> ,("!","=") +> ,("|","|") +> ,("||","|") +> ,("|","||") +> ,("||","||") +> ,("<",">=") +> ] = False + +two whitespaces will be combined + +> | Whitespace {} <- a +> , Whitespace {} <- b = False + +line comment without a newline at the end will eat the next token + +> | LineComment {} <- a +> , checkLastAChar (/='\n') = False + +check the last character of the first token and the first character of +the second token forming a comment start or end symbol + +> | let f '-' '-' = True +> f '/' '*' = True +> f '*' '/' = True +> f _ _ = False +> in checkBorderChars f = False + +a symbol will absorb a following . +TODO: not 100% on this always being bad + +> | Symbol {} <- a +> , checkFirstBChar (=='.') = False + +cannot follow a symbol ending in : with another token starting with : + +> | let f ':' ':' = True +> f _ _ = False +> in checkBorderChars f = False + +unquoted identifier followed by an identifier letter + +> | Identifier Nothing _ <- a +> , checkFirstBChar isIdentifierChar = False + +a quoted identifier using ", followed by a " will fail + +> | Identifier (Just (_,"\"")) _ <- a +> , checkFirstBChar (=='"') = False + +prefixed variable followed by an identifier char will be absorbed + +> | PrefixedVariable {} <- a +> , checkFirstBChar isIdentifierChar = False + +a positional arg will absorb a following digit + +> | PositionalArg {} <- a +> , checkFirstBChar isDigit = False + +a string ending with ' followed by a token starting with ' will be absorbed + +> | SqlString _ "'" _ <- a +> , checkFirstBChar (=='\'') = False + +a number followed by a . will fail or be absorbed + +> | SqlNumber {} <- a +> , checkFirstBChar (=='.') = False + +a number followed by an e or E will fail or be absorbed + +> | SqlNumber {} <- a +> , checkFirstBChar (\x -> x =='e' || x == 'E') = False + +two numbers next to eachother will fail or be absorbed + +> | SqlNumber {} <- a +> , SqlNumber {} <- b = False + + +> | otherwise = True + +> where +> prettya = prettyToken d a +> prettyb = prettyToken d b +> -- helper function to run a predicate on the +> -- last character of the first token and the first +> -- character of the second token +> checkBorderChars f +> | (_:_) <- prettya +> , (fb:_) <- prettyb +> , la <- last prettya +> = f la fb +> checkBorderChars _ = False +> checkFirstBChar f = case prettyb of +> (b':_) -> f b' +> _ -> False +> checkLastAChar f = case prettya of +> (_:_) -> f $ last prettya +> _ -> False + + + + +TODO: + +make the tokenswill print more dialect accurate. Maybe add symbol + chars and identifier chars to the dialect definition and use them from + here + +start adding negative / different parse dialect tests + +add token tables and tests for oracle, sql server +review existing tables + +look for refactoring opportunities, especially the token +generation tables in the tests + +do some user documentation on lexing, and lexing/dialects + +start thinking about a more separated design for the dialect handling + +lexing tests are starting to take a really long time, so split the +tests so it is much easier to run all the tests except the lexing +tests which only need to be run when working on the lexer (which +should be relatively uncommon), or doing a commit or finishing off a +series of commits, + +start writing the error message tests: + generate/write a large number of syntax errors + create a table with the source and the error message + try to compare some different versions of code to compare the + quality of the error messages by hand + + get this checked in so improvements and regressions in the error + message quality can be tracked a little more easily (although it will + still be manual) + +try again to add annotation to the ast diff --git a/Language/SQL/SimpleSQL/Parse.lhs b/Language/SQL/SimpleSQL/Parse.lhs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Parse.lhs @@ -0,0 +1,2579 @@ + += TOC: + +notes +Public api +Names - parsing identifiers +Typenames +Scalar expressions + simple literals + star, param + parens expression, row constructor and scalar subquery + case, cast, exists, unique, array/ multiset constructor + typed literal, app, special function, aggregate, window function + suffixes: in, between, quantified comparison, match predicate, array + subscript, escape, collate + operators + scalar expression top level + helpers +query expressions + select lists + from clause + other table expression clauses: + where, group by, having, order by, offset and fetch + common table expressions + query expression + set operations +lexers +utilities + += Notes about the code + +The lexers appear at the bottom of the file. There tries to be a clear +separation between the lexers and the other parser which only use the +lexers, this isn't 100% complete at the moment and needs fixing. + +== Left factoring + +The parsing code is aggressively left factored, and try is avoided as +much as possible. Try is avoided because: + + * when it is overused it makes the code hard to follow + * when it is overused it makes the parsing code harder to debug + * it makes the parser error messages much worse + +The code could be made a bit simpler with a few extra 'trys', but this +isn't done because of the impact on the parser error +messages. Apparently it can also help the speed but this hasn't been +looked into. + +== Parser error messages + +A lot of care has been given to generating good parser error messages +for invalid syntax. There are a few utils below which partially help +in this area. + +There is a set of crafted bad expressions in ErrorMessages.lhs, these +are used to guage the quality of the error messages and monitor +regressions by hand. The use of is limited as much as possible: +each instance should justify itself by improving an actual error +message. + +There is also a plan to write a really simple expression parser which +doesn't do precedence and associativity, and the fix these with a pass +over the ast. I don't think there is any other way to sanely handle +the common prefixes between many infix and postfix multiple keyword +operators, and some other ambiguities also. This should help a lot in +generating good error messages also. + +Both the left factoring and error message work are greatly complicated +by the large number of shared prefixes of the various elements in SQL +syntax. + +== Main left factoring issues + +There are three big areas which are tricky to left factor: + + * typenames + * scalar expressions which can start with an identifier + * infix and suffix operators + +=== typenames + +There are a number of variations of typename syntax. The standard +deals with this by switching on the name of the type which is parsed +first. This code doesn't do this currently, but might in the +future. Taking the approach in the standard grammar will limit the +extensibility of the parser and might affect the ease of adapting to +support other sql dialects. + +=== identifier scalar expressions + +There are a lot of scalar expression nodes which start with +identifiers, and can't be distinguished the tokens after the initial +identifier are parsed. Using try to implement these variations is very +simple but makes the code much harder to debug and makes the parser +error messages really bad. + +Here is a list of these nodes: + + * identifiers + * function application + * aggregate application + * window application + * typed literal: typename 'literal string' + * interval literal which is like the typed literal with some extras + +There is further ambiguity e.g. with typed literals with precision, +functions, aggregates, etc. - these are an identifier, followed by +parens comma separated scalar expressions or something similar, and it +is only later that we can find a token which tells us which flavour it +is. + +There is also a set of nodes which start with an identifier/keyword +but can commit since no other syntax can start the same way: + + * case + * cast + * exists, unique subquery + * array constructor + * multiset constructor + * all the special syntax functions: extract, position, substring, + convert, translate, overlay, trim, etc. + +The interval literal mentioned above is treated in this group at the +moment: if we see 'interval' we parse it either as a full interval +literal or a typed literal only. + +Some items in this list might have to be fixed in the future, e.g. to +support standard 'substring(a from 3 for 5)' as well as regular +function substring syntax 'substring(a,3,5) at the same time. + +The work in left factoring all this is mostly done, but there is still +a substantial bit to complete and this is by far the most difficult +bit. At the moment, the work around is to use try, the downsides of +which is the poor parsing error messages. + +=== infix and suffix operators + +== permissiveness + +The parser is very permissive in many ways. This departs from the +standard which is able to eliminate a number of possibilities just in +the grammar, which this parser allows. This is done for a number of +reasons: + + * it makes the parser simple - less variations + * it should allow for dialects and extensibility more easily in the + future (e.g. new infix binary operators with custom precedence) + * many things which are effectively checked in the grammar in the + standard, can be checked using a typechecker or other simple static + analysis + +To use this code as a front end for a sql engine, or as a sql validity +checker, you will need to do a lot of checks on the ast. A +typechecker/static checker plus annotation to support being a compiler +front end is planned but not likely to happen too soon. + +Some of the areas this affects: + +typenames: the variation of the type name should switch on the actual +name given according to the standard, but this code only does this for +the special case of interval type names. E.g. you can write 'int +collate C' or 'int(15,2)' and this will parse as a character type name +or a precision scale type name instead of being rejected. + +scalar expressions: every variation on scalar expressions uses the same +parser/syntax. This means we don't try to stop non boolean valued +expressions in boolean valued contexts in the parser. Another area +this affects is that we allow general scalar expressions in group by, +whereas the standard only allows column names with optional collation. + +These are all areas which are specified (roughly speaking) in the +syntax rather than the semantics in the standard, and we are not +fixing them in the syntax but leaving them till the semantic checking +(which doesn't exist in this code at this time). + +> {-# LANGUAGE TupleSections #-} +> -- | This is the module with the parser functions. +> module Language.SQL.SimpleSQL.Parse +> (parseQueryExpr +> ,parseScalarExpr +> ,parseStatement +> ,parseStatements +> ,ParseError(..)) where + +> import Control.Monad.Identity (Identity) +> import Control.Monad (guard, void) +> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>), (<**>), pure) +> import Data.Char (toLower, isDigit) +> import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition +> ,option,between,sepBy,sepBy1 +> ,try,many,many1,(<|>),choice,eof +> ,optionMaybe,optional,runParser +> ,chainl1, chainr1,()) +> -- import Text.Parsec.String (Parser) +> import Text.Parsec.Perm (permute,(<$?>), (<|?>)) +> import Text.Parsec.Prim (getState, token) +> import Text.Parsec.Pos (newPos) +> import qualified Text.Parsec.Expr as E +> import Data.List (intercalate,sort,groupBy) +> import Data.Function (on) +> import Language.SQL.SimpleSQL.Syntax +> import Language.SQL.SimpleSQL.Combinators +> import Language.SQL.SimpleSQL.Errors +> import Language.SQL.SimpleSQL.Dialect +> import qualified Language.SQL.SimpleSQL.Lex as L +> import Data.Maybe +> import Text.Parsec.String (GenParser) + += Public API + +> -- | Parses a query expr, trailing semicolon optional. +> parseQueryExpr :: Dialect +> -- ^ dialect of SQL to use +> -> FilePath +> -- ^ filename to use in error messages +> -> Maybe (Int,Int) +> -- ^ line number and column number of the first character +> -- in the source to use in error messages +> -> String +> -- ^ the SQL source to parse +> -> Either ParseError QueryExpr +> parseQueryExpr = wrapParse topLevelQueryExpr + +> -- | Parses a statement, trailing semicolon optional. +> parseStatement :: Dialect +> -- ^ dialect of SQL to use +> -> FilePath +> -- ^ filename to use in error messages +> -> Maybe (Int,Int) +> -- ^ line number and column number of the first character +> -- in the source to use in error messages +> -> String +> -- ^ the SQL source to parse +> -> Either ParseError Statement +> parseStatement = wrapParse topLevelStatement + + +> -- | Parses a list of statements, with semi colons between +> -- them. The final semicolon is optional. +> parseStatements :: Dialect +> -- ^ dialect of SQL to use +> -> FilePath +> -- ^ filename to use in error messages +> -> Maybe (Int,Int) +> -- ^ line number and column number of the first character +> -- in the source to use in error messages +> -> String +> -- ^ the SQL source to parse +> -> Either ParseError [Statement] +> parseStatements = wrapParse statements + +> -- | Parses a scalar expression. +> parseScalarExpr :: Dialect +> -- ^ dialect of SQL to use +> -> FilePath +> -- ^ filename to use in error messages +> -> Maybe (Int,Int) +> -- ^ line number and column number of the first character +> -- in the source to use in error messages +> -> String +> -- ^ the SQL source to parse +> -> Either ParseError ScalarExpr +> parseScalarExpr = wrapParse scalarExpr + +This helper function takes the parser given and: + +sets the position when parsing +automatically skips leading whitespace +checks the parser parses all the input using eof +converts the error return to the nice wrapper + +> wrapParse :: Parser a +> -> Dialect +> -> FilePath +> -> Maybe (Int,Int) +> -> String +> -> Either ParseError a +> wrapParse parser d f p src = do +> let (l,c) = fromMaybe (1,1) p +> lx <- L.lexSQL d f (Just (l,c)) src +> either (Left . convParseError src) Right +> $ runParser (setPos p *> parser <* eof) +> d f $ filter keep lx +> where +> setPos Nothing = pure () +> setPos (Just (l,c)) = fmap up getPosition >>= setPosition +> where up = flip setSourceColumn c . flip setSourceLine l +> keep (_,L.Whitespace {}) = False +> keep (_,L.LineComment {}) = False +> keep (_,L.BlockComment {}) = False +> keep _ = True + + +------------------------------------------------ + += Names + +Names represent identifiers and a few other things. The parser here +handles regular identifiers, dotten chain identifiers, quoted +identifiers and unicode quoted identifiers. + +Dots: dots in identifier chains are parsed here and represented in the +Iden constructor usually. If parts of the chains are non identifier +scalar expressions, then this is represented by a BinOp "." +instead. Dotten chain identifiers which appear in other contexts (such +as function names, table names, are represented as [Name] only. + +Identifier grammar: + +unquoted: +underscore <|> letter : many (underscore <|> alphanum + +example +_example123 + +quoted: + +double quote, many (non quote character or two double quotes +together), double quote + +"example quoted" +"example with "" quote" + +unicode quoted is the same as quoted in this parser, except it starts +with U& or u& + +u&"example quoted" + +> name :: Parser Name +> name = do +> d <- getState +> uncurry Name <$> identifierTok (blacklist d) + +todo: replace (:[]) with a named function all over + +> names :: Parser [Name] +> names = reverse <$> (((:[]) <$> name) anotherName) +> -- can't use a simple chain here since we +> -- want to wrap the . + name in a try +> -- this will change when this is left factored +> where +> anotherName :: Parser ([Name] -> [Name]) +> anotherName = try ((:) <$> (symbol "." *> name)) + += Type Names + +Typenames are used in casts, and also in the typed literal syntax, +which is a typename followed by a string literal. + +Here are the grammar notes: + +== simple type name + +just an identifier chain or a multi word identifier (this is a fixed +list of possibilities, e.g. as 'character varying', see below in the +parser code for the exact list). + + ::= + | multiword-type-identifier + +== Precision type name + + ::= + +e.g. char(5) + +note: above and below every where a simple type name can appear, this +means a single identifier/quoted or a dotted chain, or a multi word +identifier + +== Precision scale type name + + ::= + +e.g. decimal(15,2) + +== Lob type name + +this is a variation on the precision type name with some extra info on +the units: + + ::= + [ ] [ ] + + ::= K | M | G + ::= CHARACTERS | CODE_UNITS | OCTETS + +(if both multiplier and char length units are missing, then this will +parse as a precision type name) + +e.g. +clob(5M octets) + +== char type name + +this is a simple type with optional precision which allows the +character set or the collation to appear as a suffix: + + ::= + + [ ] + [ CHARACTER SET ] + [ COLLATE ] + +e.g. + +char(5) character set my_charset collate my_collation + += Time typename + +this is typename with optional precision and either 'with time zone' +or 'without time zone' suffix, e.g.: + + ::= + [ ] + + ::= WITH TIME ZONE | WITHOUT TIME ZONE + WITH TIME ZONE | WITHOUT TIME ZONE + += row type name + + ::= + ROW [ { }... ] + + ::= + +e.g. +row(a int, b char(5)) + += interval type name + + ::= INTERVAL [TO ] + + ::= + [ [ ] ] + += array type name + + ::= ARRAY [ ] + += multiset type name + + ::= MULTISET + +A type name will parse into the 'smallest' constructor it will fit in +syntactically, e.g. a clob(5) will parse to a precision type name, not +a lob type name. + +Unfortunately, to improve the error messages, there is a lot of (left) +factoring in this function, and it is a little dense. + +> typeName :: Parser TypeName +> typeName = +> (rowTypeName <|> intervalTypeName <|> otherTypeName) +> tnSuffix +> where +> rowTypeName = +> RowTypeName <$> (keyword_ "row" *> parens (commaSep1 rowField)) +> rowField = (,) <$> name <*> typeName +> ---------------------------- +> intervalTypeName = +> keyword_ "interval" *> +> (uncurry IntervalTypeName <$> intervalQualifier) +> ---------------------------- +> otherTypeName = +> nameOfType <**> +> (typeNameWithParens +> <|> pure Nothing <**> (timeTypeName <|> charTypeName) +> <|> pure TypeName) +> nameOfType = reservedTypeNames <|> names +> charTypeName = charSet <**> (option [] tcollate <$$$$> CharTypeName) +> <|> pure [] <**> (tcollate <$$$$> CharTypeName) +> typeNameWithParens = +> (openParen *> unsignedInteger) +> <**> (closeParen *> precMaybeSuffix +> <|> (precScaleTypeName <|> precLengthTypeName) <* closeParen) +> precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName) +> <|> pure (flip PrecTypeName) +> precScaleTypeName = (comma *> unsignedInteger) <$$$> PrecScaleTypeName +> precLengthTypeName = +> Just <$> lobPrecSuffix +> <**> (optionMaybe lobUnits <$$$$> PrecLengthTypeName) +> <|> pure Nothing <**> ((Just <$> lobUnits) <$$$$> PrecLengthTypeName) +> timeTypeName = tz <$$$> TimeTypeName +> ---------------------------- +> lobPrecSuffix = PrecK <$ keyword_ "k" +> <|> PrecM <$ keyword_ "m" +> <|> PrecG <$ keyword_ "g" +> <|> PrecT <$ keyword_ "t" +> <|> PrecP <$ keyword_ "p" +> lobUnits = PrecCharacters <$ keyword_ "characters" +> -- char and byte are the oracle spelling +> -- todo: move these to oracle dialect +> <|> PrecCharacters <$ keyword_ "char" +> <|> PrecOctets <$ keyword_ "octets" +> <|> PrecOctets <$ keyword_ "byte" +> tz = True <$ keywords_ ["with", "time","zone"] +> <|> False <$ keywords_ ["without", "time","zone"] +> charSet = keywords_ ["character", "set"] *> names +> tcollate = keyword_ "collate" *> names +> ---------------------------- +> tnSuffix = multiset <|> array +> multiset = MultisetTypeName <$ keyword_ "multiset" +> array = keyword_ "array" *> +> (optionMaybe (brackets unsignedInteger) <$$> ArrayTypeName) +> ---------------------------- +> -- this parser handles the fixed set of multi word +> -- type names, plus all the type names which are +> -- reserved words +> reservedTypeNames = (:[]) . Name Nothing . unwords <$> makeKeywordTree +> ["double precision" +> ,"character varying" +> ,"char varying" +> ,"character large object" +> ,"char large object" +> ,"national character" +> ,"national char" +> ,"national character varying" +> ,"national char varying" +> ,"national character large object" +> ,"nchar large object" +> ,"nchar varying" +> ,"bit varying" +> ,"binary large object" +> ,"binary varying" +> -- reserved keyword typenames: +> ,"array" +> ,"bigint" +> ,"binary" +> ,"blob" +> ,"boolean" +> ,"char" +> ,"character" +> ,"clob" +> ,"date" +> ,"dec" +> ,"decimal" +> ,"double" +> ,"float" +> ,"int" +> ,"integer" +> ,"nchar" +> ,"nclob" +> ,"numeric" +> ,"real" +> ,"smallint" +> ,"time" +> ,"timestamp" +> ,"varchar" +> ,"varbinary" +> ] + += Scalar expressions + +== simple literals + +See the stringToken lexer below for notes on string literal syntax. + +> stringLit :: Parser ScalarExpr +> stringLit = (\(s,e,t) -> StringLit s e t) <$> stringTokExtend + +> numberLit :: Parser ScalarExpr +> numberLit = NumLit <$> sqlNumberTok False + +> simpleLiteral :: Parser ScalarExpr +> simpleLiteral = numberLit <|> stringLit + +== star, param, host param + +=== star + +used in select *, select x.*, and agg(*) variations, and some other +places as well. The parser doesn't attempt to check that the star is +in a valid context, it parses it OK in any scalar expression context. + +> star :: Parser ScalarExpr +> star = Star <$ symbol "*" + +== parameter + +unnamed parameter or named parameter +use in e.g. select * from t where a = ? +select x from t where x > :param + +> parameter :: Parser ScalarExpr +> parameter = choice +> [Parameter <$ questionMark +> ,HostParameter +> <$> hostParamTok +> <*> optionMaybe (keyword "indicator" *> hostParamTok)] + +== positional arg + +> positionalArg :: Parser ScalarExpr +> positionalArg = PositionalArg <$> positionalArgTok + +== parens + +scalar expression parens, row ctor and scalar subquery + +> parensExpr :: Parser ScalarExpr +> parensExpr = parens $ choice +> [SubQueryExpr SqSq <$> queryExpr +> ,ctor <$> commaSep1 scalarExpr] +> where +> ctor [a] = Parens a +> ctor as = SpecialOp [Name Nothing "rowctor"] as + +== case, cast, exists, unique, array/multiset constructor, interval + +All of these start with a fixed keyword which is reserved, so no other +syntax can start with the same keyword. + +=== case expression + +> caseExpr :: Parser ScalarExpr +> caseExpr = +> Case <$> (keyword_ "case" *> optionMaybe scalarExpr) +> <*> many1 whenClause +> <*> optionMaybe elseClause +> <* keyword_ "end" +> where +> whenClause = (,) <$> (keyword_ "when" *> commaSep1 scalarExpr) +> <*> (keyword_ "then" *> scalarExpr) +> elseClause = keyword_ "else" *> scalarExpr + +=== cast + +cast: cast(expr as type) + +> cast :: Parser ScalarExpr +> cast = keyword_ "cast" *> +> parens (Cast <$> scalarExpr +> <*> (keyword_ "as" *> typeName)) + +=== exists, unique + +subquery expression: +[exists|unique] (queryexpr) + +> subquery :: Parser ScalarExpr +> subquery = SubQueryExpr <$> sqkw <*> parens queryExpr +> where +> sqkw = SqExists <$ keyword_ "exists" <|> SqUnique <$ keyword_ "unique" + +=== array/multiset constructor + +> arrayCtor :: Parser ScalarExpr +> arrayCtor = keyword_ "array" >> +> choice +> [ArrayCtor <$> parens queryExpr +> ,Array (Iden [Name Nothing "array"]) <$> brackets (commaSep scalarExpr)] + +As far as I can tell, table(query expr) is just syntax sugar for +multiset(query expr). It must be there for compatibility or something. + +> multisetCtor :: Parser ScalarExpr +> multisetCtor = +> choice +> [keyword_ "multiset" >> +> choice +> [MultisetQueryCtor <$> parens queryExpr +> ,MultisetCtor <$> brackets (commaSep scalarExpr)] +> ,keyword_ "table" >> +> MultisetQueryCtor <$> parens queryExpr] + +> nextValueFor :: Parser ScalarExpr +> nextValueFor = keywords_ ["next","value","for"] >> +> NextValueFor <$> names + +=== interval + +interval literals are a special case and we follow the grammar less +permissively here + +parse SQL interval literals, something like +interval '5' day (3) +or +interval '5' month + +if the literal looks like this: +interval 'something' + +then it is parsed as a regular typed literal. It must have a +interval-datetime-field suffix to parse as an intervallit + +It uses try because of a conflict with interval type names: todo, fix +this. also fix the monad -> applicative + +> intervalLit :: Parser ScalarExpr +> intervalLit = try (keyword_ "interval" >> do +> s <- optionMaybe $ choice [Plus <$ symbol_ "+" +> ,Minus <$ symbol_ "-"] +> lit <- singleQuotesOnlyStringTok +> q <- optionMaybe intervalQualifier +> mkIt s lit q) +> where +> mkIt Nothing val Nothing = pure $ TypedLit (TypeName [Name Nothing "interval"]) val +> mkIt s val (Just (a,b)) = pure $ IntervalLit s val a b +> mkIt (Just {}) _val Nothing = fail "cannot use sign without interval qualifier" + +== typed literal, app, special, aggregate, window, iden + +All of these start with identifiers (some of the special functions +start with reserved keywords). + +they are all variations on suffixes on the basic identifier parser + +The windows is a suffix on the app parser + +=== iden prefix term + +all the scalar expressions which start with an identifier + +(todo: really put all of them here instead of just some of them) + +> idenExpr :: Parser ScalarExpr +> idenExpr = +> -- todo: work out how to left factor this +> try (TypedLit <$> typeName <*> singleQuotesOnlyStringTok) +> <|> multisetSetFunction +> <|> (try keywordFunction <**> app) +> <|> (names <**> option Iden app) +> where +> -- this is a special case because set is a reserved keyword +> -- and the names parser won't parse it +> multisetSetFunction = +> App [Name Nothing "set"] . (:[]) <$> +> (try (keyword_ "set" *> openParen) +> *> scalarExpr <* closeParen) +> keywordFunction = +> let makeKeywordFunction x = if map toLower x `elem` keywordFunctionNames +> then return [Name Nothing x] +> else fail "" +> in unquotedIdentifierTok [] Nothing >>= makeKeywordFunction +> -- todo: this list should be in the dialects +> -- we should have tests to check these work +> -- we should have tests to check if they are used elsewhere, you +> -- get a keyword failure +> -- these are the names of functions which are also keywords +> -- so this identifier can only be used unquoted for a function application +> -- and nowhere else +> -- not sure if this list is 100% correct +> -- todo: make a corresponding list of reserved keywords which can be +> -- parsed as an identifier +> keywordFunctionNames = ["abs" +> ,"all" +> ,"any" +> ,"array_agg" +> ,"avg" +> ,"ceil" +> ,"ceiling" +> ,"char_length" +> ,"character_length" +> ,"coalesce" +> ,"collect" +> ,"contains" +> ,"convert" +> ,"corr" +> ,"covar_pop" +> ,"covar_samp" +> ,"count" +> ,"cume_dist" +> ,"grouping" +> ,"intersection" +> ,"ln" +> ,"max" +> ,"mod" +> ,"percent_rank" +> ,"percentile_cont" +> ,"percentile_disc" +> ,"power" +> ,"rank" +> ,"regr_avgx" +> ,"regr_avgy" +> ,"regr_count" +> ,"regr_intercept" +> ,"regr_r2" +> ,"regr_slope" +> ,"regr_sxx" +> ,"regr_sxy" +> ,"regr_syy" +> ,"row" +> ,"row_number" +> ,"some" +> ,"stddev_pop" +> ,"stddev_samp" +> ,"sum" +> ,"upper" +> ,"var_pop" +> ,"var_samp" +> ,"width_bucket" +> -- window functions added here too +> ,"row_number" +> ,"rank" +> ,"dense_rank" +> ,"percent_rank" +> ,"cume_dist" +> ,"ntile" +> ,"lead" +> ,"lag" +> ,"first_value" +> ,"last_value" +> ,"nth_value" +> ] + + +=== special + +These are keyword operators which don't look like normal prefix, +postfix or infix binary operators. They mostly look like function +application but with keywords in the argument list instead of commas +to separate the arguments. + +the special op keywords +parse an operator which is +operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) + +> data SpecialOpKFirstArg = SOKNone +> | SOKOptional +> | SOKMandatory + +> specialOpK :: String -- name of the operator +> -> SpecialOpKFirstArg -- has a first arg without a keyword +> -> [(String,Bool)] -- the other args with their keywords +> -- and whether they are optional +> -> Parser ScalarExpr +> specialOpK opName firstArg kws = +> keyword_ opName >> do +> void openParen +> let pfa = do +> e <- scalarExpr +> -- check we haven't parsed the first +> -- keyword as an identifier +> case (e,kws) of +> (Iden [Name Nothing i], (k,_):_) +> | map toLower i == k -> +> fail $ "cannot use keyword here: " ++ i +> _ -> return () +> pure e +> fa <- case firstArg of +> SOKNone -> pure Nothing +> SOKOptional -> optionMaybe (try pfa) +> SOKMandatory -> Just <$> pfa +> as <- mapM parseArg kws +> void closeParen +> pure $ SpecialOpK [Name Nothing opName] fa $ catMaybes as +> where +> parseArg (nm,mand) = +> let p = keyword_ nm >> scalarExpr +> in fmap (nm,) <$> if mand +> then Just <$> p +> else optionMaybe (try p) + +The actual operators: + +EXTRACT( date_part FROM expression ) + +POSITION( string1 IN string2 ) + +SUBSTRING(extraction_string FROM starting_position [FOR length] +[COLLATE collation_name]) + +CONVERT(char_value USING conversion_char_name) + +TRANSLATE(char_value USING translation_name) + +OVERLAY(string PLACING embedded_string FROM start +[FOR length]) + +TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ] +target_string +[COLLATE collation_name] ) + +> specialOpKs :: Parser ScalarExpr +> specialOpKs = choice $ map try +> [extract, position, substring, convert, translate, overlay, trim] + +> extract :: Parser ScalarExpr +> extract = specialOpK "extract" SOKMandatory [("from", True)] + +> position :: Parser ScalarExpr +> position = specialOpK "position" SOKMandatory [("in", True)] + +strictly speaking, the substring must have at least one of from and +for, but the parser doens't enforce this + +> substring :: Parser ScalarExpr +> substring = specialOpK "substring" SOKMandatory +> [("from", False),("for", False)] + +> convert :: Parser ScalarExpr +> convert = specialOpK "convert" SOKMandatory [("using", True)] + + +> translate :: Parser ScalarExpr +> translate = specialOpK "translate" SOKMandatory [("using", True)] + +> overlay :: Parser ScalarExpr +> overlay = specialOpK "overlay" SOKMandatory +> [("placing", True),("from", True),("for", False)] + +trim is too different because of the optional char, so a custom parser +the both ' ' is filled in as the default if either parts are missing +in the source + +> trim :: Parser ScalarExpr +> trim = +> keyword "trim" >> +> parens (mkTrim +> <$> option "both" sides +> <*> option " " singleQuotesOnlyStringTok +> <*> (keyword_ "from" *> scalarExpr)) +> where +> sides = choice ["leading" <$ keyword_ "leading" +> ,"trailing" <$ keyword_ "trailing" +> ,"both" <$ keyword_ "both"] +> mkTrim fa ch fr = +> SpecialOpK [Name Nothing "trim"] Nothing +> $ catMaybes [Just (fa,StringLit "'" "'" ch) +> ,Just ("from", fr)] + +=== app, aggregate, window + +This parses all these variations: +normal function application with just a csv of scalar exprs +aggregate variations (distinct, order by in parens, filter and where + suffixes) +window apps (fn/agg followed by over) + +This code is also a little dense like the typename code because of +left factoring, later they will even have to be partially combined +together. + +> app :: Parser ([Name] -> ScalarExpr) +> app = +> openParen *> choice +> [duplicates +> <**> (commaSep1 scalarExpr +> <**> (((option [] orderBy) <* closeParen) +> <**> (optionMaybe afilter <$$$$$> AggregateApp))) +> -- separate cases with no all or distinct which must have at +> -- least one scalar expr +> ,commaSep1 scalarExpr +> <**> choice +> [closeParen *> choice +> [window +> ,withinGroup +> ,(Just <$> afilter) <$$$> aggAppWithoutDupeOrd +> ,pure (flip App)] +> ,orderBy <* closeParen +> <**> (optionMaybe afilter <$$$$> aggAppWithoutDupe)] +> -- no scalarExprs: duplicates and order by not allowed +> ,([] <$ closeParen) <**> option (flip App) (window <|> withinGroup) +> ] +> where +> aggAppWithoutDupeOrd n es f = AggregateApp n SQDefault es [] f +> aggAppWithoutDupe n = AggregateApp n SQDefault + +> afilter :: Parser ScalarExpr +> afilter = keyword_ "filter" *> parens (keyword_ "where" *> scalarExpr) + +> withinGroup :: Parser ([ScalarExpr] -> [Name] -> ScalarExpr) +> withinGroup = +> (keywords_ ["within", "group"] *> parens orderBy) <$$$> AggregateAppGroup + +==== window + +parse a window call as a suffix of a regular function call +this looks like this: +functionname(args) over ([partition by ids] [order by orderitems]) + +No support for explicit frames yet. + +TODO: add window support for other aggregate variations, needs some +changes to the syntax also + +> window :: Parser ([ScalarExpr] -> [Name] -> ScalarExpr) +> window = +> keyword_ "over" *> openParen *> option [] partitionBy +> <**> (option [] orderBy +> <**> (((optionMaybe frameClause) <* closeParen) <$$$$$> WindowApp)) +> where +> partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr +> frameClause = +> frameRowsRange -- TODO: this 'and' could be an issue +> <**> (choice [(keyword_ "between" *> frameLimit True) +> <**> ((keyword_ "and" *> frameLimit True) +> <$$$> FrameBetween) +> -- maybe this should still use a b expression +> -- for consistency +> ,frameLimit False <**> pure (flip FrameFrom)]) +> frameRowsRange = FrameRows <$ keyword_ "rows" +> <|> FrameRange <$ keyword_ "range" +> frameLimit useB = +> choice +> [Current <$ keywords_ ["current", "row"] +> -- todo: create an automatic left factor for stuff like this +> ,keyword_ "unbounded" *> +> choice [UnboundedPreceding <$ keyword_ "preceding" +> ,UnboundedFollowing <$ keyword_ "following"] +> ,(if useB then scalarExprB else scalarExpr) +> <**> (Preceding <$ keyword_ "preceding" +> <|> Following <$ keyword_ "following") +> ] + +== suffixes + +These are all generic suffixes on any scalar expr + +=== in + +in: two variations: +a in (expr0, expr1, ...) +a in (queryexpr) + +> inSuffix :: Parser (ScalarExpr -> ScalarExpr) +> inSuffix = +> mkIn <$> inty +> <*> parens (choice +> [InQueryExpr <$> queryExpr +> ,InList <$> commaSep1 scalarExpr]) +> where +> inty = choice [True <$ keyword_ "in" +> ,False <$ keywords_ ["not","in"]] +> mkIn i v = \e -> In i e v + +=== between + +between: +expr between expr and expr + +There is a complication when parsing between - when parsing the second +expression it is ambiguous when you hit an 'and' whether it is a +binary operator or part of the between. This code follows what +postgres does, which might be standard across SQL implementations, +which is that you can't have a binary and operator in the middle +expression in a between unless it is wrapped in parens. The 'bExpr +parsing' is used to create alternative scalar expression parser which +is identical to the normal one expect it doesn't recognise the binary +and operator. This is the call to scalarExprB. + +> betweenSuffix :: Parser (ScalarExpr -> ScalarExpr) +> betweenSuffix = +> makeOp <$> Name Nothing <$> opName +> <*> scalarExprB +> <*> (keyword_ "and" *> scalarExprB) +> where +> opName = choice +> ["between" <$ keyword_ "between" +> ,"not between" <$ try (keywords_ ["not","between"])] +> makeOp n b c = \a -> SpecialOp [n] [a,b,c] + +=== quantified comparison + +a = any (select * from t) + +> quantifiedComparisonSuffix :: Parser (ScalarExpr -> ScalarExpr) +> quantifiedComparisonSuffix = do +> c <- comp +> cq <- compQuan +> q <- parens queryExpr +> pure $ \v -> QuantifiedComparison v [c] cq q +> where +> comp = Name Nothing <$> choice (map symbol +> ["=", "<>", "<=", "<", ">", ">="]) +> compQuan = choice +> [CPAny <$ keyword_ "any" +> ,CPSome <$ keyword_ "some" +> ,CPAll <$ keyword_ "all"] + +=== match + +a match (select a from t) + +> matchPredicateSuffix :: Parser (ScalarExpr -> ScalarExpr) +> matchPredicateSuffix = do +> keyword_ "match" +> u <- option False (True <$ keyword_ "unique") +> q <- parens queryExpr +> pure $ \v -> Match v u q + +=== array subscript + +> arraySuffix :: Parser (ScalarExpr -> ScalarExpr) +> arraySuffix = do +> es <- brackets (commaSep scalarExpr) +> pure $ \v -> Array v es + +=== escape + +It is going to be really difficult to support an arbitrary character +for the escape now there is a separate lexer ... + +TODO: this needs fixing. Escape is only part of other nodes, and not a +separate suffix. + +> {-escapeSuffix :: Parser (ScalarExpr -> ScalarExpr) +> escapeSuffix = do +> ctor <- choice +> [Escape <$ keyword_ "escape" +> ,UEscape <$ keyword_ "uescape"] +> c <- escapeChar +> pure $ \v -> ctor v c +> where +> escapeChar :: Parser Char +> escapeChar = (identifierTok [] Nothing <|> symbolTok Nothing) >>= oneOnly +> oneOnly :: String -> Parser Char +> oneOnly c = case c of +> [c'] -> return c' +> _ -> fail "escape char must be single char" +> -} + +=== collate + +> collateSuffix:: Parser (ScalarExpr -> ScalarExpr) +> collateSuffix = do +> keyword_ "collate" +> i <- names +> pure $ \v -> Collate v i + +== odbc syntax + +the parser supports three kinds of odbc syntax, two of which are +scalar expressions (the other is a variation on joins) + + +> odbcExpr :: Parser ScalarExpr +> odbcExpr = between (symbol "{") (symbol "}") +> (odbcTimeLit <|> odbcFunc) +> where +> odbcTimeLit = +> OdbcLiteral <$> choice [OLDate <$ keyword "d" +> ,OLTime <$ keyword "t" +> ,OLTimestamp <$ keyword "ts"] +> <*> singleQuotesOnlyStringTok +> -- todo: this parser is too general, the expr part +> -- should be only a function call (from a whitelist of functions) +> -- or the extract operator +> odbcFunc = OdbcFunc <$> (keyword "fn" *> scalarExpr) + +== operators + +The 'regular' operators in this parsing and in the abstract syntax are +unary prefix, unary postfix and binary infix operators. The operators +can be symbols (a + b), single keywords (a and b) or multiple keywords +(a is similar to b). + +TODO: carefully review the precedences and associativities. + +TODO: to fix the parsing completely, I think will need to parse +without precedence and associativity and fix up afterwards, since SQL +syntax is way too messy. It might be possible to avoid this if we +wanted to avoid extensibility and to not be concerned with parse error +messages, but both of these are too important. + +> opTable :: Bool -> [[E.Operator [Token] ParseState Identity ScalarExpr]] +> opTable bExpr = +> [-- parse match and quantified comparisons as postfix ops +> -- todo: left factor the quantified comparison with regular +> -- binary comparison, somehow +> [E.Postfix $ try quantifiedComparisonSuffix +> ,E.Postfix matchPredicateSuffix +> ] + +> ,[binarySym "." E.AssocLeft] + +> ,[postfix' arraySuffix +> ,postfix' collateSuffix] + +> ,[prefixSym "+", prefixSym "-"] + +> ,[binarySym "^" E.AssocLeft] + +> ,[binarySym "*" E.AssocLeft +> ,binarySym "/" E.AssocLeft +> ,binarySym "%" E.AssocLeft] + +> ,[binarySym "+" E.AssocLeft +> ,binarySym "-" E.AssocLeft] + +> ,[binarySym "||" E.AssocRight +> ,prefixSym "~" +> ,binarySym "&" E.AssocRight +> ,binarySym "|" E.AssocRight] + +> ,[binaryKeyword "overlaps" E.AssocNone] + +> ,[binaryKeyword "like" E.AssocNone +> -- have to use try with inSuffix because of a conflict +> -- with 'in' in position function, and not between +> -- between also has a try in it to deal with 'not' +> -- ambiguity +> ,E.Postfix $ try inSuffix +> ,E.Postfix betweenSuffix] +> -- todo: figure out where to put the try? +> ++ [binaryKeywords $ makeKeywordTree +> ["not like" +> ,"is similar to" +> ,"is not similar to"]] +> ++ [multisetBinOp] + +> ,[binarySym "<" E.AssocNone +> ,binarySym ">" E.AssocNone +> ,binarySym ">=" E.AssocNone +> ,binarySym "<=" E.AssocNone +> ,binarySym "!=" E.AssocRight +> ,binarySym "<>" E.AssocRight +> ,binarySym "=" E.AssocRight] + +> ,[postfixKeywords $ makeKeywordTree +> ["is null" +> ,"is not null" +> ,"is true" +> ,"is not true" +> ,"is false" +> ,"is not false" +> ,"is unknown" +> ,"is not unknown"]] +> ++ [binaryKeywords $ makeKeywordTree +> ["is distinct from" +> ,"is not distinct from"]] + +> ,[prefixKeyword "not"] + +> ,if bExpr then [] else [binaryKeyword "and" E.AssocLeft] + +> ,[binaryKeyword "or" E.AssocLeft] + +> ] +> where +> binarySym nm assoc = binary (symbol_ nm) nm assoc +> binaryKeyword nm assoc = binary (keyword_ nm) nm assoc +> binaryKeywords p = +> E.Infix (do +> o <- try p +> pure (\a b -> BinOp a [Name Nothing $ unwords o] b)) +> E.AssocNone +> postfixKeywords p = +> postfix' $ do +> o <- try p +> pure $ PostfixOp [Name Nothing $ unwords o] +> binary p nm assoc = +> E.Infix (p >> pure (\a b -> BinOp a [Name Nothing nm] b)) assoc +> multisetBinOp = E.Infix (do +> keyword_ "multiset" +> o <- choice [Union <$ keyword_ "union" +> ,Intersect <$ keyword_ "intersect" +> ,Except <$ keyword_ "except"] +> d <- option SQDefault duplicates +> pure (\a b -> MultisetBinOp a o d b)) +> E.AssocLeft +> prefixKeyword nm = prefix (keyword_ nm) nm +> prefixSym nm = prefix (symbol_ nm) nm +> prefix p nm = prefix' (p >> pure (PrefixOp [Name Nothing nm])) +> -- hack from here +> -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported +> -- not implemented properly yet +> -- I don't think this will be enough for all cases +> -- at least it works for 'not not a' +> -- ok: "x is not true is not true" +> -- no work: "x is not true is not null" +> prefix' p = E.Prefix . chainl1 p $ pure (.) +> postfix' p = E.Postfix . chainl1 p $ pure (flip (.)) + +== scalar expression top level + +This parses most of the scalar exprs.The order of the parsers and use +of try is carefully done to make everything work. It is a little +fragile and could at least do with some heavy explanation. Update: the +'try's have migrated into the individual parsers, they still need +documenting/fixing. + +> scalarExpr :: Parser ScalarExpr +> scalarExpr = E.buildExpressionParser (opTable False) term + +> term :: Parser ScalarExpr +> term = choice [simpleLiteral +> ,parameter +> ,positionalArg +> ,star +> ,parensExpr +> ,caseExpr +> ,cast +> ,arrayCtor +> ,multisetCtor +> ,nextValueFor +> ,subquery +> ,intervalLit +> ,specialOpKs +> ,idenExpr +> ,odbcExpr] +> "scalar expression" + +expose the b expression for window frame clause range between + +> scalarExprB :: Parser ScalarExpr +> scalarExprB = E.buildExpressionParser (opTable True) term + +== helper parsers + +This is used in interval literals and in interval type names. + +> intervalQualifier :: Parser (IntervalTypeField,Maybe IntervalTypeField) +> intervalQualifier = +> (,) <$> intervalField +> <*> optionMaybe (keyword_ "to" *> intervalField) +> where +> intervalField = +> Itf +> <$> datetimeField +> <*> optionMaybe +> (parens ((,) <$> unsignedInteger +> <*> optionMaybe (comma *> unsignedInteger))) + +TODO: use datetime field in extract also +use a data type for the datetime field? + +> datetimeField :: Parser String +> datetimeField = choice (map keyword ["year","month","day" +> ,"hour","minute","second"]) +> "datetime field" + +This is used in multiset operations (scalar expr), selects (query expr) +and set operations (query expr). + +> duplicates :: Parser SetQuantifier +> duplicates = +> choice [All <$ keyword_ "all" +> ,Distinct <$ keyword "distinct"] + +------------------------------------------------- + += query expressions + +== select lists + +> selectItem :: Parser (ScalarExpr,Maybe Name) +> selectItem = (,) <$> scalarExpr <*> optionMaybe als +> where als = optional (keyword_ "as") *> name + +> selectList :: Parser [(ScalarExpr,Maybe Name)] +> selectList = commaSep1 selectItem + +== from + +Here is the rough grammar for joins + +tref +(cross | [natural] ([inner] | (left | right | full) [outer])) join +tref +[on expr | using (...)] + +TODO: either use explicit 'operator precedence' parsers or build +expression parser for the 'tref operators' such as joins, lateral, +aliases. + +> from :: Parser [TableRef] +> from = keyword_ "from" *> commaSep1 tref +> where +> -- TODO: use P (a->) for the join tref suffix +> -- chainl or buildexpressionparser +> tref = nonJoinTref >>= optionSuffix joinTrefSuffix +> nonJoinTref = choice +> [parens $ choice +> [TRQueryExpr <$> queryExpr +> ,TRParens <$> tref] +> ,TRLateral <$> (keyword_ "lateral" +> *> nonJoinTref) +> ,do +> n <- names +> choice [TRFunction n +> <$> parens (commaSep scalarExpr) +> ,pure $ TRSimple n] +> -- todo: I think you can only have outer joins inside the oj, +> -- not sure. +> ,TROdbc <$> (symbol "{" *> keyword_ "oj" *> tref <* symbol "}") +> ] aliasSuffix +> aliasSuffix = fromAlias <$$> TRAlias +> joinTrefSuffix t = +> (TRJoin t <$> option False (True <$ keyword_ "natural") +> <*> joinType +> <*> nonJoinTref +> <*> optionMaybe joinCondition) +> >>= optionSuffix joinTrefSuffix + +TODO: factor the join stuff to produce better error messages (and make +it more readable) + +> joinType :: Parser JoinType +> joinType = choice +> [JCross <$ keyword_ "cross" <* keyword_ "join" +> ,JInner <$ keyword_ "inner" <* keyword_ "join" +> ,JLeft <$ keyword_ "left" +> <* optional (keyword_ "outer") +> <* keyword_ "join" +> ,JRight <$ keyword_ "right" +> <* optional (keyword_ "outer") +> <* keyword_ "join" +> ,JFull <$ keyword_ "full" +> <* optional (keyword_ "outer") +> <* keyword_ "join" +> ,JInner <$ keyword_ "join"] + +> joinCondition :: Parser JoinCondition +> joinCondition = choice +> [keyword_ "on" >> JoinOn <$> scalarExpr +> ,keyword_ "using" >> JoinUsing <$> parens (commaSep1 name)] + +> fromAlias :: Parser Alias +> fromAlias = Alias <$> tableAlias <*> columnAliases +> where +> tableAlias = optional (keyword_ "as") *> name +> columnAliases = optionMaybe $ parens $ commaSep1 name + +== simple other parts + +Parsers for where, group by, having, order by and limit, which are +pretty trivial. + +> whereClause :: Parser ScalarExpr +> whereClause = keyword_ "where" *> scalarExpr + +> groupByClause :: Parser [GroupingExpr] +> groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression +> where +> groupingExpression = choice +> [keyword_ "cube" >> +> Cube <$> parens (commaSep groupingExpression) +> ,keyword_ "rollup" >> +> Rollup <$> parens (commaSep groupingExpression) +> ,GroupingParens <$> parens (commaSep groupingExpression) +> ,keywords_ ["grouping", "sets"] >> +> GroupingSets <$> parens (commaSep groupingExpression) +> ,SimpleGroup <$> scalarExpr +> ] + +> having :: Parser ScalarExpr +> having = keyword_ "having" *> scalarExpr + +> orderBy :: Parser [SortSpec] +> orderBy = keywords_ ["order","by"] *> commaSep1 ob +> where +> ob = SortSpec +> <$> scalarExpr +> <*> option DirDefault (choice [Asc <$ keyword_ "asc" +> ,Desc <$ keyword_ "desc"]) +> <*> option NullsOrderDefault +> -- todo: left factor better +> (keyword_ "nulls" >> +> choice [NullsFirst <$ keyword "first" +> ,NullsLast <$ keyword "last"]) + +allows offset and fetch in either order ++ postgresql offset without row(s) and limit instead of fetch also + +> offsetFetch :: Parser (Maybe ScalarExpr, Maybe ScalarExpr) +> offsetFetch = permute ((,) <$?> (Nothing, Just <$> offset) +> <|?> (Nothing, Just <$> fetch)) + +> offset :: Parser ScalarExpr +> offset = keyword_ "offset" *> scalarExpr +> <* option () (choice [keyword_ "rows" +> ,keyword_ "row"]) + +> fetch :: Parser ScalarExpr +> fetch = fetchFirst <|> limit +> where +> fetchFirst = guardDialect [ANSI2011] +> *> fs *> scalarExpr <* ro +> fs = makeKeywordTree ["fetch first", "fetch next"] +> ro = makeKeywordTree ["rows only", "row only"] +> -- todo: not in ansi sql dialect +> limit = guardDialect [MySQL] *> +> keyword_ "limit" *> scalarExpr + +== common table expressions + +> with :: Parser QueryExpr +> with = keyword_ "with" >> +> With <$> option False (True <$ keyword_ "recursive") +> <*> commaSep1 withQuery <*> queryExpr +> where +> withQuery = (,) <$> (fromAlias <* keyword_ "as") +> <*> parens queryExpr + +== query expression + +This parser parses any query expression variant: normal select, cte, +and union, etc.. + +> queryExpr :: Parser QueryExpr +> queryExpr = choice +> [with +> ,chainr1 (choice [values,table, select]) setOp] +> where +> select = keyword_ "select" >> +> mkSelect +> <$> option SQDefault duplicates +> <*> selectList +> <*> optionMaybe tableExpression +> mkSelect d sl Nothing = +> makeSelect{qeSetQuantifier = d, qeSelectList = sl} +> mkSelect d sl (Just (TableExpression f w g h od ofs fe)) = +> Select d sl f w g h od ofs fe +> values = keyword_ "values" +> >> Values <$> commaSep (parens (commaSep scalarExpr)) +> table = keyword_ "table" >> Table <$> names + +local data type to help with parsing the bit after the select list, +called 'table expression' in the ansi sql grammar. Maybe this should +be in the public syntax? + +> data TableExpression +> = TableExpression +> {_teFrom :: [TableRef] +> ,_teWhere :: Maybe ScalarExpr +> ,_teGroupBy :: [GroupingExpr] +> ,_teHaving :: Maybe ScalarExpr +> ,_teOrderBy :: [SortSpec] +> ,_teOffset :: Maybe ScalarExpr +> ,_teFetchFirst :: Maybe ScalarExpr} + +> tableExpression :: Parser TableExpression +> tableExpression = mkTe <$> from +> <*> optionMaybe whereClause +> <*> option [] groupByClause +> <*> optionMaybe having +> <*> option [] orderBy +> <*> offsetFetch +> where +> mkTe f w g h od (ofs,fe) = +> TableExpression f w g h od ofs fe + +> setOp :: Parser (QueryExpr -> QueryExpr -> QueryExpr) +> setOp = cq +> <$> setOpK +> <*> option SQDefault duplicates +> <*> corr +> where +> cq o d c q0 q1 = QueryExprSetOp q0 o d c q1 +> setOpK = choice [Union <$ keyword_ "union" +> ,Intersect <$ keyword_ "intersect" +> ,Except <$ keyword_ "except"] +> "set operator" +> corr = option Respectively (Corresponding <$ keyword_ "corresponding") + + +wrapper for query expr which ignores optional trailing semicolon. + +TODO: change style + +> topLevelQueryExpr :: Parser QueryExpr +> topLevelQueryExpr = queryExpr (id <$ semi) + +> topLevelStatement :: Parser Statement +> topLevelStatement = statement (id <$ semi) + +------------------------- + += Statements + +> statement :: Parser Statement +> statement = choice +> [keyword_ "create" *> choice [createSchema +> ,createTable +> ,createView +> ,createDomain +> ,createSequence +> ,createRole +> ,createAssertion] +> ,keyword_ "alter" *> choice [alterTable +> ,alterDomain +> ,alterSequence] +> ,keyword_ "drop" *> choice [dropSchema +> ,dropTable +> ,dropView +> ,dropDomain +> ,dropSequence +> ,dropRole +> ,dropAssertion] +> ,delete +> ,truncateSt +> ,insert +> ,update +> ,startTransaction +> ,savepoint +> ,releaseSavepoint +> ,commit +> ,rollback +> ,grant +> ,revoke +> ,SelectStatement <$> queryExpr +> ] + +> createSchema :: Parser Statement +> createSchema = keyword_ "schema" >> +> CreateSchema <$> names + +> createTable :: Parser Statement +> createTable = keyword_ "table" >> +> CreateTable +> <$> names +> -- todo: is this order mandatory or is it a perm? +> <*> parens (commaSep1 (uncurry TableConstraintDef <$> tableConstraintDef +> <|> TableColumnDef <$> columnDef)) + +> columnDef :: Parser ColumnDef +> columnDef = ColumnDef <$> name <*> typeName +> <*> optionMaybe defaultClause +> <*> option [] (many1 colConstraintDef) +> where +> defaultClause = choice [ +> keyword_ "default" >> +> DefaultClause <$> scalarExpr +> -- todo: left factor +> ,try (keywords_ ["generated","always","as"] >> +> GenerationClause <$> parens scalarExpr) +> ,keyword_ "generated" >> +> IdentityColumnSpec +> <$> (GeneratedAlways <$ keyword_ "always" +> <|> GeneratedByDefault <$ keywords_ ["by", "default"]) +> <*> (keywords_ ["as", "identity"] *> +> option [] (parens sequenceGeneratorOptions)) +> ] + +> tableConstraintDef :: Parser (Maybe [Name], TableConstraint) +> tableConstraintDef = +> (,) +> <$> (optionMaybe (keyword_ "constraint" *> names)) +> <*> (unique <|> primaryKey <|> check <|> references) +> where +> unique = keyword_ "unique" >> +> TableUniqueConstraint <$> parens (commaSep1 name) +> primaryKey = keywords_ ["primary", "key"] >> +> TablePrimaryKeyConstraint <$> parens (commaSep1 name) +> check = keyword_ "check" >> TableCheckConstraint <$> parens scalarExpr +> references = keywords_ ["foreign", "key"] >> +> (\cs ft ftcs m (u,d) -> TableReferencesConstraint cs ft ftcs m u d) +> <$> parens (commaSep1 name) +> <*> (keyword_ "references" *> names) +> <*> optionMaybe (parens $ commaSep1 name) +> <*> refMatch +> <*> refActions + +> refMatch :: Parser ReferenceMatch +> refMatch = option DefaultReferenceMatch +> (keyword_ "match" *> +> choice [MatchFull <$ keyword_ "full" +> ,MatchPartial <$ keyword_ "partial" +> ,MatchSimple <$ keyword_ "simple"]) +> refActions :: Parser (ReferentialAction,ReferentialAction) +> refActions = permute ((,) <$?> (DefaultReferentialAction, onUpdate) +> <|?> (DefaultReferentialAction, onDelete)) +> where +> -- todo: left factor? +> onUpdate = try (keywords_ ["on", "update"]) *> referentialAction +> onDelete = try (keywords_ ["on", "delete"]) *> referentialAction +> referentialAction = choice [ +> RefCascade <$ keyword_ "cascade" +> -- todo: left factor? +> ,RefSetNull <$ try (keywords_ ["set", "null"]) +> ,RefSetDefault <$ try (keywords_ ["set", "default"]) +> ,RefRestrict <$ keyword_ "restrict" +> ,RefNoAction <$ keywords_ ["no", "action"]] + +> colConstraintDef :: Parser ColConstraintDef +> colConstraintDef = +> ColConstraintDef +> <$> (optionMaybe (keyword_ "constraint" *> names)) +> <*> (notNull <|> unique <|> primaryKey <|> check <|> references) +> where +> notNull = ColNotNullConstraint <$ keywords_ ["not", "null"] +> unique = ColUniqueConstraint <$ keyword_ "unique" +> primaryKey = ColPrimaryKeyConstraint <$ keywords_ ["primary", "key"] +> check = keyword_ "check" >> ColCheckConstraint <$> parens scalarExpr +> references = keyword_ "references" >> +> (\t c m (ou,od) -> ColReferencesConstraint t c m ou od) +> <$> names +> <*> optionMaybe (parens name) +> <*> refMatch +> <*> refActions + +slightly hacky parser for signed integers + +> signedInteger :: Parser Integer +> signedInteger = +> (*) <$> option 1 (1 <$ symbol "+" <|> (-1) <$ symbol "-") +> <*> unsignedInteger + +> sequenceGeneratorOptions :: Parser [SequenceGeneratorOption] +> sequenceGeneratorOptions = +> -- todo: could try to combine exclusive options +> -- such as cycle and nocycle +> -- sort out options which are sometimes not allowed +> -- as datatype, and restart with +> permute ((\a b c d e f g h j k -> catMaybes [a,b,c,d,e,f,g,h,j,k]) +> <$?> nj startWith +> <|?> nj dataType +> <|?> nj restart +> <|?> nj incrementBy +> <|?> nj maxValue +> <|?> nj noMaxValue +> <|?> nj minValue +> <|?> nj noMinValue +> <|?> nj scycle +> <|?> nj noCycle +> ) +> where +> nj p = (Nothing,Just <$> p) +> startWith = keywords_ ["start", "with"] >> +> SGOStartWith <$> signedInteger +> dataType = keyword_ "as" >> +> SGODataType <$> typeName +> restart = keyword_ "restart" >> +> SGORestart <$> optionMaybe (keyword_ "with" *> signedInteger) +> incrementBy = keywords_ ["increment", "by"] >> +> SGOIncrementBy <$> signedInteger +> maxValue = keyword_ "maxvalue" >> +> SGOMaxValue <$> signedInteger +> noMaxValue = SGONoMaxValue <$ try (keywords_ ["no","maxvalue"]) +> minValue = keyword_ "minvalue" >> +> SGOMinValue <$> signedInteger +> noMinValue = SGONoMinValue <$ try (keywords_ ["no","minvalue"]) +> scycle = SGOCycle <$ keyword_ "cycle" +> noCycle = SGONoCycle <$ try (keywords_ ["no","cycle"]) + + +> alterTable :: Parser Statement +> alterTable = keyword_ "table" >> +> -- the choices have been ordered so that it works +> AlterTable <$> names <*> choice [addConstraint +> ,dropConstraint +> ,addColumnDef +> ,alterColumn +> ,dropColumn +> ] +> where +> addColumnDef = try (keyword_ "add" +> *> optional (keyword_ "column")) >> +> AddColumnDef <$> columnDef +> alterColumn = keyword_ "alter" >> optional (keyword_ "column") >> +> name <**> choice [setDefault +> ,dropDefault +> ,setNotNull +> ,dropNotNull +> ,setDataType] +> setDefault :: Parser (Name -> AlterTableAction) +> -- todo: left factor +> setDefault = try (keywords_ ["set","default"]) >> +> scalarExpr <$$> AlterColumnSetDefault +> dropDefault = AlterColumnDropDefault <$ try (keywords_ ["drop","default"]) +> setNotNull = AlterColumnSetNotNull <$ try (keywords_ ["set","not","null"]) +> dropNotNull = AlterColumnDropNotNull <$ try (keywords_ ["drop","not","null"]) +> setDataType = try (keywords_ ["set","data","type"]) >> +> typeName <$$> AlterColumnSetDataType +> dropColumn = try (keyword_ "drop" *> optional (keyword_ "column")) >> +> DropColumn <$> name <*> dropBehaviour +> -- todo: left factor, this try is especially bad +> addConstraint = try (keyword_ "add" >> +> uncurry AddTableConstraintDef <$> tableConstraintDef) +> dropConstraint = try (keywords_ ["drop","constraint"]) >> +> DropTableConstraintDef <$> names <*> dropBehaviour + + +> dropSchema :: Parser Statement +> dropSchema = keyword_ "schema" >> +> DropSchema <$> names <*> dropBehaviour + +> dropTable :: Parser Statement +> dropTable = keyword_ "table" >> +> DropTable <$> names <*> dropBehaviour + +> createView :: Parser Statement +> createView = +> CreateView +> <$> (option False (True <$ keyword_ "recursive") <* keyword_ "view") +> <*> names +> <*> optionMaybe (parens (commaSep1 name)) +> <*> (keyword_ "as" *> queryExpr) +> <*> optionMaybe (choice [ +> -- todo: left factor +> DefaultCheckOption <$ try (keywords_ ["with", "check", "option"]) +> ,CascadedCheckOption <$ try (keywords_ ["with", "cascaded", "check", "option"]) +> ,LocalCheckOption <$ try (keywords_ ["with", "local", "check", "option"]) +> ]) + +> dropView :: Parser Statement +> dropView = keyword_ "view" >> +> DropView <$> names <*> dropBehaviour + +> createDomain :: Parser Statement +> createDomain = keyword_ "domain" >> +> CreateDomain +> <$> names +> <*> (optional (keyword_ "as") *> typeName) +> <*> optionMaybe (keyword_ "default" *> scalarExpr) +> <*> many con +> where +> con = (,) <$> optionMaybe (keyword_ "constraint" *> names) +> <*> (keyword_ "check" *> parens scalarExpr) + +> alterDomain :: Parser Statement +> alterDomain = keyword_ "domain" >> +> AlterDomain +> <$> names +> <*> (setDefault <|> constraint +> <|> (keyword_ "drop" *> (dropDefault <|> dropConstraint))) +> where +> setDefault = keywords_ ["set", "default"] >> ADSetDefault <$> scalarExpr +> constraint = keyword_ "add" >> +> ADAddConstraint +> <$> optionMaybe (keyword_ "constraint" *> names) +> <*> (keyword_ "check" *> parens scalarExpr) +> dropDefault = ADDropDefault <$ keyword_ "default" +> dropConstraint = keyword_ "constraint" >> ADDropConstraint <$> names + +> dropDomain :: Parser Statement +> dropDomain = keyword_ "domain" >> +> DropDomain <$> names <*> dropBehaviour + +> createSequence :: Parser Statement +> createSequence = keyword_ "sequence" >> +> CreateSequence +> <$> names +> <*> sequenceGeneratorOptions + +> alterSequence :: Parser Statement +> alterSequence = keyword_ "sequence" >> +> AlterSequence +> <$> names +> <*> sequenceGeneratorOptions + +> dropSequence :: Parser Statement +> dropSequence = keyword_ "sequence" >> +> DropSequence <$> names <*> dropBehaviour + +> createAssertion :: Parser Statement +> createAssertion = keyword_ "assertion" >> +> CreateAssertion +> <$> names +> <*> (keyword_ "check" *> parens scalarExpr) + + +> dropAssertion :: Parser Statement +> dropAssertion = keyword_ "assertion" >> +> DropAssertion <$> names <*> dropBehaviour + +----------------- + += dml + +> delete :: Parser Statement +> delete = keywords_ ["delete","from"] >> +> Delete +> <$> names +> <*> optionMaybe (optional (keyword_ "as") *> name) +> <*> optionMaybe (keyword_ "where" *> scalarExpr) + +> truncateSt :: Parser Statement +> truncateSt = keywords_ ["truncate", "table"] >> +> Truncate +> <$> names +> <*> option DefaultIdentityRestart +> (ContinueIdentity <$ keywords_ ["continue","identity"] +> <|> RestartIdentity <$ keywords_ ["restart","identity"]) + +> insert :: Parser Statement +> insert = keywords_ ["insert", "into"] >> +> Insert +> <$> names +> <*> optionMaybe (parens $ commaSep1 name) +> <*> (DefaultInsertValues <$ keywords_ ["default", "values"] +> <|> InsertQuery <$> queryExpr) + +> update :: Parser Statement +> update = keywords_ ["update"] >> +> Update +> <$> names +> <*> optionMaybe (optional (keyword_ "as") *> name) +> <*> (keyword_ "set" *> commaSep1 setClause) +> <*> optionMaybe (keyword_ "where" *> scalarExpr) +> where +> setClause = multipleSet <|> singleSet +> multipleSet = SetMultiple +> <$> parens (commaSep1 names) +> <*> (symbol "=" *> parens (commaSep1 scalarExpr)) +> singleSet = Set +> <$> names +> <*> (symbol "=" *> scalarExpr) + +> dropBehaviour :: Parser DropBehaviour +> dropBehaviour = +> option DefaultDropBehaviour +> (Restrict <$ keyword_ "restrict" +> <|> Cascade <$ keyword_ "cascade") + +----------------------------- + += transaction management + +> startTransaction :: Parser Statement +> startTransaction = StartTransaction <$ keywords_ ["start","transaction"] + +> savepoint :: Parser Statement +> savepoint = keyword_ "savepoint" >> +> Savepoint <$> name + +> releaseSavepoint :: Parser Statement +> releaseSavepoint = keywords_ ["release","savepoint"] >> +> ReleaseSavepoint <$> name + +> commit :: Parser Statement +> commit = Commit <$ keyword_ "commit" <* optional (keyword_ "work") + +> rollback :: Parser Statement +> rollback = keyword_ "rollback" >> optional (keyword_ "work") >> +> Rollback <$> optionMaybe (keywords_ ["to", "savepoint"] *> name) + + +------------------------------ + += Access control + +TODO: fix try at the 'on' + +> grant :: Parser Statement +> grant = keyword_ "grant" >> (try priv <|> role) +> where +> priv = GrantPrivilege +> <$> commaSep privilegeAction +> <*> (keyword_ "on" *> privilegeObject) +> <*> (keyword_ "to" *> commaSep name) +> <*> option WithoutGrantOption +> (WithGrantOption <$ keywords_ ["with","grant","option"]) +> role = GrantRole +> <$> commaSep name +> <*> (keyword_ "to" *> commaSep name) +> <*> option WithoutAdminOption +> (WithAdminOption <$ keywords_ ["with","admin","option"]) + +> createRole :: Parser Statement +> createRole = keyword_ "role" >> +> CreateRole <$> name + +> dropRole :: Parser Statement +> dropRole = keyword_ "role" >> +> DropRole <$> name + +TODO: fix try at the 'on' + +> revoke :: Parser Statement +> revoke = keyword_ "revoke" >> (try priv <|> role) +> where +> priv = RevokePrivilege +> <$> option NoGrantOptionFor +> (GrantOptionFor <$ keywords_ ["grant","option","for"]) +> <*> commaSep privilegeAction +> <*> (keyword_ "on" *> privilegeObject) +> <*> (keyword_ "from" *> commaSep name) +> <*> dropBehaviour +> role = RevokeRole +> <$> option NoAdminOptionFor +> (AdminOptionFor <$ keywords_ ["admin","option", "for"]) +> <*> commaSep name +> <*> (keyword_ "from" *> commaSep name) +> <*> dropBehaviour + +> privilegeAction :: Parser PrivilegeAction +> privilegeAction = choice +> [PrivAll <$ keywords_ ["all","privileges"] +> ,keyword_ "select" >> +> PrivSelect <$> option [] (parens $ commaSep name) +> ,PrivDelete <$ keyword_ "delete" +> ,PrivUsage <$ keyword_ "usage" +> ,PrivTrigger <$ keyword_ "trigger" +> ,PrivExecute <$ keyword_ "execute" +> ,keyword_ "insert" >> +> PrivInsert <$> option [] (parens $ commaSep name) +> ,keyword_ "update" >> +> PrivUpdate <$> option [] (parens $ commaSep name) +> ,keyword_ "references" >> +> PrivReferences <$> option [] (parens $ commaSep name) +> ] + +> privilegeObject :: Parser PrivilegeObject +> privilegeObject = choice +> [keyword_ "domain" >> PrivDomain <$> names +> ,keyword_ "type" >> PrivType <$> names +> ,keyword_ "sequence" >> PrivSequence <$> names +> ,keywords_ ["specific","function"] >> PrivFunction <$> names +> ,optional (keyword_ "table") >> PrivTable <$> names +> ] + + +---------------------------- + +wrapper to parse a series of statements. They must be separated by +semicolon, but for the last statement, the trailing semicolon is +optional. + +TODO: change style + +> statements :: Parser [Statement] +> statements = (:[]) <$> statement +> >>= optionSuffix ((semi *>) . pure) +> >>= optionSuffix (\p -> (p++) <$> statements) + +---------------------------------------------- + += multi keyword helper + +This helper is to help parsing multiple options of multiple keywords +with similar prefixes, e.g. parsing 'is null' and 'is not null'. + +use to left factor/ improve: +typed literal and general identifiers +not like, not in, not between operators +help with factoring keyword functions and other app-likes +the join keyword sequences +fetch first/next +row/rows only + +There is probably a simpler way of doing this but I am a bit +thick. + +> makeKeywordTree :: [String] -> Parser [String] +> makeKeywordTree sets = +> parseTrees (sort $ map words sets) +> where +> parseTrees :: [[String]] -> Parser [String] +> parseTrees ws = do +> let gs :: [[[String]]] +> gs = groupBy ((==) `on` safeHead) ws +> choice $ map parseGroup gs +> parseGroup :: [[String]] -> Parser [String] +> parseGroup l@((k:_):_) = do +> keyword_ k +> let tls = catMaybes $ map safeTail l +> pr = (k:) <$> parseTrees tls +> if (or $ map null tls) +> then pr <|> pure [k] +> else pr +> parseGroup _ = guard False >> error "impossible" +> safeHead (x:_) = Just x +> safeHead [] = Nothing +> safeTail (_:x) = Just x +> safeTail [] = Nothing + +------------------------------------------------ + += lexing + +TODO: push checks into here: +keyword blacklists +unsigned integer match +symbol matching +keyword matching + +> stringTok :: Parser (String,String,String) +> stringTok = mytoken (\tok -> +> case tok of +> L.SqlString s e t -> Just (s,e,t) +> _ -> Nothing) + +> singleQuotesOnlyStringTok :: Parser String +> singleQuotesOnlyStringTok = mytoken (\tok -> +> case tok of +> L.SqlString "'" "'" t -> Just t +> _ -> Nothing) + +This is to support SQL strings where you can write +'part of a string' ' another part' +and it will parse as a single string + +It is only allowed when all the strings are quoted with ' atm. + +> stringTokExtend :: Parser (String,String,String) +> stringTokExtend = do +> (s,e,x) <- stringTok +> choice [ +> do +> guard (s == "'" && e == "'") +> (s',e',y) <- stringTokExtend +> guard (s' == "'" && e' == "'") +> return $ (s,e,x ++ y) +> ,return (s,e,x) +> ] + +> hostParamTok :: Parser String +> hostParamTok = mytoken (\tok -> +> case tok of +> L.PrefixedVariable c p -> Just (c:p) +> _ -> Nothing) + +> positionalArgTok :: Parser Int +> positionalArgTok = mytoken (\tok -> +> case tok of +> L.PositionalArg p -> Just p +> _ -> Nothing) + + +> sqlNumberTok :: Bool -> Parser String +> sqlNumberTok intOnly = mytoken (\tok -> +> case tok of +> L.SqlNumber p | not intOnly || all isDigit p -> Just p +> _ -> Nothing) + + +> symbolTok :: Maybe String -> Parser String +> symbolTok sym = mytoken (\tok -> +> case (sym,tok) of +> (Nothing, L.Symbol p) -> Just p +> (Just s, L.Symbol p) | s == p -> Just p +> _ -> Nothing) + +> identifierTok :: [String] -> Parser (Maybe (String,String), String) +> identifierTok blackList = mytoken (\tok -> +> case tok of +> L.Identifier q p | map toLower p `notElem` blackList -> Just (q,p) +> _ -> Nothing) + +> unquotedIdentifierTok :: [String] -> Maybe String -> Parser String +> unquotedIdentifierTok blackList kw = mytoken (\tok -> +> case (kw,tok) of +> (Nothing, L.Identifier Nothing p) | map toLower p `notElem` blackList -> Just p +> (Just k, L.Identifier Nothing p) | k == map toLower p -> Just p +> _ -> Nothing) + +> mytoken :: (L.Token -> Maybe a) -> Parser a +> mytoken test = token showToken posToken testToken +> where +> showToken (_,tok) = show tok +> posToken ((a,b,c),_) = newPos a b c +> testToken (_,tok) = test tok + +> unsignedInteger :: Parser Integer +> unsignedInteger = read <$> sqlNumberTok True "natural number" + +todo: work out the symbol parsing better + +> symbol :: String -> Parser String +> symbol s = symbolTok (Just s) s + +> singleCharSymbol :: Char -> Parser Char +> singleCharSymbol c = c <$ symbol [c] + +> questionMark :: Parser Char +> questionMark = singleCharSymbol '?' "question mark" + +> openParen :: Parser Char +> openParen = singleCharSymbol '(' + +> closeParen :: Parser Char +> closeParen = singleCharSymbol ')' + +> openBracket :: Parser Char +> openBracket = singleCharSymbol '[' + +> closeBracket :: Parser Char +> closeBracket = singleCharSymbol ']' + + +> comma :: Parser Char +> comma = singleCharSymbol ',' + +> semi :: Parser Char +> semi = singleCharSymbol ';' + += helper functions + +> keyword :: String -> Parser String +> keyword k = unquotedIdentifierTok [] (Just k) k + +helper function to improve error messages + +> keywords_ :: [String] -> Parser () +> keywords_ ks = mapM_ keyword_ ks intercalate " " ks + + +> parens :: Parser a -> Parser a +> parens = between openParen closeParen + +> brackets :: Parser a -> Parser a +> brackets = between openBracket closeBracket + +> commaSep :: Parser a -> Parser [a] +> commaSep = (`sepBy` comma) + +> keyword_ :: String -> Parser () +> keyword_ = void . keyword + +> symbol_ :: String -> Parser () +> symbol_ = void . symbol + +> commaSep1 :: Parser a -> Parser [a] +> commaSep1 = (`sepBy1` comma) + +> blacklist :: Dialect -> [String] +> blacklist = reservedWord + +These blacklisted names are mostly needed when we parse something with +an optional alias, e.g. select a a from t. If we write select a from +t, we have to make sure the from isn't parsed as an alias. I'm not +sure what other places strictly need the blacklist, and in theory it +could be tuned differently for each place the identifierString/ +identifier parsers are used to only blacklist the bare +minimum. Something like this might be needed for dialect support, even +if it is pretty silly to use a keyword as an unquoted identifier when +there is a effing quoting syntax as well. + +The standard has a weird mix of reserved keywords and unreserved +keywords (I'm not sure what exactly being an unreserved keyword +means). + +can't work out if aggregate functions are supposed to be reserved or +not, leave them unreserved for now + +> reservedWord :: Dialect -> [String] +> reservedWord d | diSyntaxFlavour d == ANSI2011 = +> ["abs" +> --,"all" +> ,"allocate" +> ,"alter" +> ,"and" +> --,"any" +> ,"are" +> ,"array" +> --,"array_agg" +> ,"array_max_cardinality" +> ,"as" +> ,"asensitive" +> ,"asymmetric" +> ,"at" +> ,"atomic" +> ,"authorization" +> --,"avg" +> ,"begin" +> ,"begin_frame" +> ,"begin_partition" +> ,"between" +> ,"bigint" +> ,"binary" +> ,"blob" +> ,"boolean" +> ,"both" +> ,"by" +> ,"call" +> ,"called" +> ,"cardinality" +> ,"cascaded" +> ,"case" +> ,"cast" +> ,"ceil" +> ,"ceiling" +> ,"char" +> ,"char_length" +> ,"character" +> ,"character_length" +> ,"check" +> ,"clob" +> ,"close" +> ,"coalesce" +> ,"collate" +> --,"collect" +> ,"column" +> ,"commit" +> ,"condition" +> ,"connect" +> ,"constraint" +> ,"contains" +> ,"convert" +> --,"corr" +> ,"corresponding" +> --,"count" +> --,"covar_pop" +> --,"covar_samp" +> ,"create" +> ,"cross" +> ,"cube" +> --,"cume_dist" +> ,"current" +> ,"current_catalog" +> --,"current_date" +> --,"current_default_transform_group" +> --,"current_path" +> --,"current_role" +> ,"current_row" +> ,"current_schema" +> ,"current_time" +> ,"current_timestamp" +> ,"current_transform_group_for_type" +> --,"current_user" +> ,"cursor" +> ,"cycle" +> ,"date" +> --,"day" +> ,"deallocate" +> ,"dec" +> ,"decimal" +> ,"declare" +> --,"default" +> ,"delete" +> --,"dense_rank" +> ,"deref" +> ,"describe" +> ,"deterministic" +> ,"disconnect" +> ,"distinct" +> ,"double" +> ,"drop" +> ,"dynamic" +> ,"each" +> --,"element" +> ,"else" +> ,"end" +> ,"end_frame" +> ,"end_partition" +> ,"end-exec" +> ,"equals" +> ,"escape" +> --,"every" +> ,"except" +> ,"exec" +> ,"execute" +> ,"exists" +> ,"exp" +> ,"external" +> ,"extract" +> --,"false" +> ,"fetch" +> ,"filter" +> ,"first_value" +> ,"float" +> ,"floor" +> ,"for" +> ,"foreign" +> ,"frame_row" +> ,"free" +> ,"from" +> ,"full" +> ,"function" +> --,"fusion" +> ,"get" +> ,"global" +> ,"grant" +> ,"group" +> --,"grouping" +> ,"groups" +> ,"having" +> ,"hold" +> --,"hour" +> ,"identity" +> ,"in" +> ,"indicator" +> ,"inner" +> ,"inout" +> ,"insensitive" +> ,"insert" +> ,"int" +> ,"integer" +> ,"intersect" +> --,"intersection" +> ,"interval" +> ,"into" +> ,"is" +> ,"join" +> ,"lag" +> ,"language" +> ,"large" +> ,"last_value" +> ,"lateral" +> ,"lead" +> ,"leading" +> ,"left" +> ,"like" +> ,"like_regex" +> ,"ln" +> ,"local" +> ,"localtime" +> ,"localtimestamp" +> ,"lower" +> ,"match" +> --,"max" +> ,"member" +> ,"merge" +> ,"method" +> --,"min" +> --,"minute" +> ,"mod" +> ,"modifies" +> --,"module" +> --,"month" +> ,"multiset" +> ,"national" +> ,"natural" +> ,"nchar" +> ,"nclob" +> ,"new" +> ,"no" +> ,"none" +> ,"normalize" +> ,"not" +> ,"nth_value" +> ,"ntile" +> --,"null" +> ,"nullif" +> ,"numeric" +> ,"octet_length" +> ,"occurrences_regex" +> ,"of" +> ,"offset" +> ,"old" +> ,"on" +> ,"only" +> ,"open" +> ,"or" +> ,"order" +> ,"out" +> ,"outer" +> ,"over" +> ,"overlaps" +> ,"overlay" +> ,"parameter" +> ,"partition" +> ,"percent" +> --,"percent_rank" +> --,"percentile_cont" +> --,"percentile_disc" +> ,"period" +> ,"portion" +> ,"position" +> ,"position_regex" +> ,"power" +> ,"precedes" +> ,"precision" +> ,"prepare" +> ,"primary" +> ,"procedure" +> ,"range" +> --,"rank" +> ,"reads" +> ,"real" +> ,"recursive" +> ,"ref" +> ,"references" +> ,"referencing" +> --,"regr_avgx" +> --,"regr_avgy" +> --,"regr_count" +> --,"regr_intercept" +> --,"regr_r2" +> --,"regr_slope" +> --,"regr_sxx" +> --,"regr_sxy" +> --,"regr_syy" +> ,"release" +> ,"result" +> ,"return" +> ,"returns" +> ,"revoke" +> ,"right" +> ,"rollback" +> ,"rollup" +> ,"row" +> ,"row_number" +> ,"rows" +> ,"savepoint" +> ,"scope" +> ,"scroll" +> ,"search" +> --,"second" +> ,"select" +> ,"sensitive" +> --,"session_user" +> ,"set" +> ,"similar" +> ,"smallint" +> --,"some" +> ,"specific" +> ,"specifictype" +> ,"sql" +> ,"sqlexception" +> ,"sqlstate" +> ,"sqlwarning" +> ,"sqrt" +> --,"start" +> ,"static" +> --,"stddev_pop" +> --,"stddev_samp" +> ,"submultiset" +> ,"substring" +> ,"substring_regex" +> ,"succeeds" +> --,"sum" +> ,"symmetric" +> ,"system" +> ,"system_time" +> --,"system_user" +> ,"table" +> ,"tablesample" +> ,"then" +> ,"time" +> ,"timestamp" +> ,"timezone_hour" +> ,"timezone_minute" +> ,"to" +> ,"trailing" +> ,"translate" +> ,"translate_regex" +> ,"translation" +> ,"treat" +> ,"trigger" +> ,"truncate" +> ,"trim" +> ,"trim_array" +> --,"true" +> ,"uescape" +> ,"union" +> ,"unique" +> --,"unknown" +> ,"unnest" +> ,"update" +> ,"upper" +> --,"user" +> ,"using" +> --,"value" +> ,"values" +> ,"value_of" +> --,"var_pop" +> --,"var_samp" +> ,"varbinary" +> ,"varchar" +> ,"varying" +> ,"versioning" +> ,"when" +> ,"whenever" +> ,"where" +> ,"width_bucket" +> ,"window" +> ,"with" +> ,"within" +> ,"without" +> --,"year" +> ] + +TODO: create this list properly + move this list into the dialect data type + +> reservedWord _ = reservedWord ansi2011 ++ ["limit"] + +----------- + +bit hacky, used to make the dialect available during parsing so +different parsers can be used for different dialects + +> type ParseState = Dialect + +> type Token = ((String,Int,Int),L.Token) + +> type Parser = GenParser Token ParseState + +> guardDialect :: [SyntaxFlavour] -> Parser () +> guardDialect ds = do +> d <- getState +> guard (diSyntaxFlavour d `elem` ds) + +TODO: the ParseState and the Dialect argument should be turned into a +flags struct. Part (or all?) of this struct is the dialect +information, but each dialect has different versions + a big set of +flags to control syntax variations within a version of a product +dialect (for instance, string and identifier parsing rules vary from +dialect to dialect and version to version, and most or all SQL DBMSs +appear to have a set of flags to further enable or disable variations +for quoting and escaping strings and identifiers). + +The dialect stuff can also be used for custom options: e.g. to only +parse dml for instance. diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs deleted file mode 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ /dev/null @@ -1,2018 +0,0 @@ - -= TOC: - -notes -Public api -Names - parsing identifiers -Typenames -Value expressions - simple literals - star, param - parens expression, row constructor and scalar subquery - case, cast, exists, unique, array/ multiset constructor - typed literal, app, special function, aggregate, window function - suffixes: in, between, quantified comparison, match predicate, array - subscript, escape, collate - operators - value expression top level - helpers -query expressions - select lists - from clause - other table expression clauses: - where, group by, having, order by, offset and fetch - common table expressions - query expression - set operations -lexers -utilities - -= Notes about the code - -The lexers appear at the bottom of the file. There tries to be a clear -separation between the lexers and the other parser which only use the -lexers, this isn't 100% complete at the moment and needs fixing. - -== Left factoring - -The parsing code is aggressively left factored, and try is avoided as -much as possible. Try is avoided because: - - * when it is overused it makes the code hard to follow - * when it is overused it makes the parsing code harder to debug - * it makes the parser error messages much worse - -The code could be made a bit simpler with a few extra 'trys', but this -isn't done because of the impact on the parser error -messages. Apparently it can also help the speed but this hasn't been -looked into. - -== Parser rrror messages - -A lot of care has been given to generating good parser error messages -for invalid syntax. There are a few utils below which partially help -in this area. - -There is a set of crafted bad expressions in ErrorMessages.lhs, these -are used to guage the quality of the error messages and monitor -regressions by hand. The use of is limited as much as possible: -each instance should justify itself by improving an actual error -message. - -There is also a plan to write a really simple expression parser which -doesn't do precedence and associativity, and the fix these with a pass -over the ast. I don't think there is any other way to sanely handle -the common prefixes between many infix and postfix multiple keyword -operators, and some other ambiguities also. This should help a lot in -generating good error messages also. - -Both the left factoring and error message work are greatly complicated -by the large number of shared prefixes of the various elements in SQL -syntax. - -== Main left factoring issues - -There are three big areas which are tricky to left factor: - - * typenames - * value expressions which can start with an identifier - * infix and suffix operators - -=== typenames - -There are a number of variations of typename syntax. The standard -deals with this by switching on the name of the type which is parsed -first. This code doesn't do this currently, but might in the -future. Taking the approach in the standard grammar will limit the -extensibility of the parser and might affect the ease of adapting to -support other sql dialects. - -=== identifier value expressions - -There are a lot of value expression nodes which start with -identifiers, and can't be distinguished the tokens after the initial -identifier are parsed. Using try to implement these variations is very -simple but makes the code much harder to debug and makes the parser -error messages really bad. - -Here is a list of these nodes: - - * identifiers - * function application - * aggregate application - * window application - * typed literal: typename 'literal string' - * interval literal which is like the typed literal with some extras - -There is further ambiguity e.g. with typed literals with precision, -functions, aggregates, etc. - these are an identifier, followed by -parens comma separated value expressions or something similar, and it -is only later that we can find a token which tells us which flavour it -is. - -There is also a set of nodes which start with an identifier/keyword -but can commit since no other syntax can start the same way: - - * case - * cast - * exists, unique subquery - * array constructor - * multiset constructor - * all the special syntax functions: extract, position, substring, - convert, translate, overlay, trim, etc. - -The interval literal mentioned above is treated in this group at the -moment: if we see 'interval' we parse it either as a full interval -literal or a typed literal only. - -Some items in this list might have to be fixed in the future, e.g. to -support standard 'substring(a from 3 for 5)' as well as regular -function substring syntax 'substring(a,3,5) at the same time. - -The work in left factoring all this is mostly done, but there is still -a substantial bit to complete and this is by far the most difficult -bit. At the moment, the work around is to use try, the downsides of -which is the poor parsing error messages. - -=== infix and suffix operators - -== permissiveness - -The parser is very permissive in many ways. This departs from the -standard which is able to eliminate a number of possibilities just in -the grammar, which this parser allows. This is done for a number of -reasons: - - * it makes the parser simple - less variations - * it should allow for dialects and extensibility more easily in the - future (e.g. new infix binary operators with custom precedence) - * many things which are effectively checked in the grammar in the - standard, can be checked using a typechecker or other simple static - analysis - -To use this code as a front end for a sql engine, or as a sql validity -checker, you will need to do a lot of checks on the ast. A -typechecker/static checker plus annotation to support being a compiler -front end is planned but not likely to happen too soon. - -Some of the areas this affects: - -typenames: the variation of the type name should switch on the actual -name given according to the standard, but this code only does this for -the special case of interval type names. E.g. you can write 'int -collate C' or 'int(15,2)' and this will parse as a character type name -or a precision scale type name instead of being rejected. - -value expressions: every variation on value expressions uses the same -parser/syntax. This means we don't try to stop non boolean valued -expressions in boolean valued contexts in the parser. Another area -this affects is that we allow general value expressions in group by, -whereas the standard only allows column names with optional collation. - -These are all areas which are specified (roughly speaking) in the -syntax rather than the semantics in the standard, and we are not -fixing them in the syntax but leaving them till the semantic checking -(which doesn't exist in this code at this time). - -> {-# LANGUAGE TupleSections #-} -> -- | This is the module with the parser functions. -> module Language.SQL.SimpleSQL.Parser -> (parseQueryExpr -> ,parseValueExpr -> ,parseQueryExprs -> ,ParseError(..)) where - -> import Control.Monad.Identity (Identity) -> import Control.Monad (guard, void, when) -> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>), (<**>), pure) -> import Data.Maybe (catMaybes) -> import Data.Char (toLower) -> import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition -> ,option,between,sepBy,sepBy1,string,manyTill,anyChar -> ,try,string,many1,oneOf,digit,(<|>),choice,char,eof -> ,optionMaybe,optional,many,letter,runParser -> ,chainl1, chainr1,() {-,notFollowedBy,alphaNum-}, lookAhead) -> -- import Text.Parsec.String (Parser) -> import Text.Parsec.Perm (permute,(<$?>), (<|?>)) -> import Text.Parsec.Prim (Parsec, getState) -> import qualified Text.Parsec.Expr as E -> import Data.List (intercalate,sort,groupBy) -> import Data.Function (on) -> import Language.SQL.SimpleSQL.Syntax -> import Language.SQL.SimpleSQL.Combinators -> import Language.SQL.SimpleSQL.Errors - -= Public API - -> -- | Parses a query expr, trailing semicolon optional. -> parseQueryExpr :: Dialect -> -- ^ dialect of SQL to use -> -> FilePath -> -- ^ filename to use in error messages -> -> Maybe (Int,Int) -> -- ^ line number and column number of the first character -> -- in the source to use in error messages -> -> String -> -- ^ the SQL source to parse -> -> Either ParseError QueryExpr -> parseQueryExpr = wrapParse topLevelQueryExpr - -> -- | Parses a list of query expressions, with semi colons between -> -- them. The final semicolon is optional. -> parseQueryExprs :: Dialect -> -- ^ dialect of SQL to use -> -> FilePath -> -- ^ filename to use in error messages -> -> Maybe (Int,Int) -> -- ^ line number and column number of the first character -> -- in the source to use in error messages -> -> String -> -- ^ the SQL source to parse -> -> Either ParseError [QueryExpr] -> parseQueryExprs = wrapParse queryExprs - -> -- | Parses a value expression. -> parseValueExpr :: Dialect -> -- ^ dialect of SQL to use -> -> FilePath -> -- ^ filename to use in error messages -> -> Maybe (Int,Int) -> -- ^ line number and column number of the first character -> -- in the source to use in error messages -> -> String -> -- ^ the SQL source to parse -> -> Either ParseError ValueExpr -> parseValueExpr = wrapParse valueExpr - -This helper function takes the parser given and: - -sets the position when parsing -automatically skips leading whitespace -checks the parser parses all the input using eof -converts the error return to the nice wrapper - -> wrapParse :: Parser a -> -> Dialect -> -> FilePath -> -> Maybe (Int,Int) -> -> String -> -> Either ParseError a -> wrapParse parser d f p src = -> either (Left . convParseError src) Right -> $ runParser (setPos p *> whitespace *> parser <* eof) -> d f src -> where -> setPos Nothing = pure () -> setPos (Just (l,c)) = fmap up getPosition >>= setPosition -> where up = flip setSourceColumn c . flip setSourceLine l - ------------------------------------------------- - -= Names - -Names represent identifiers and a few other things. The parser here -handles regular identifiers, dotten chain identifiers, quoted -identifiers and unicode quoted identifiers. - -Dots: dots in identifier chains are parsed here and represented in the -Iden constructor usually. If parts of the chains are non identifier -value expressions, then this is represented by a BinOp "." -instead. Dotten chain identifiers which appear in other contexts (such -as function names, table names, are represented as [Name] only. - -Identifier grammar: - -unquoted: -underscore <|> letter : many (underscore <|> alphanum - -example -_example123 - -quoted: - -double quote, many (non quote character or two double quotes -together), double quote - -"example quoted" -"example with "" quote" - -unicode quoted is the same as quoted in this parser, except it starts -with U& or u& - -u&"example quoted" - -> name :: Parser Name -> name = do -> d <- getState -> choice [QName <$> quotedIdentifier -> ,UQName <$> uquotedIdentifier -> ,Name <$> identifierBlacklist (blacklist d) -> ,dqName] -> where -> dqName = guardDialect [MySQL] *> -> lexeme (DQName "`" "`" -> <$> (char '`' -> *> manyTill anyChar (char '`'))) - -todo: replace (:[]) with a named function all over - -> names :: Parser [Name] -> names = reverse <$> (((:[]) <$> name) anotherName) -> -- can't use a simple chain here since we -> -- want to wrap the . + name in a try -> -- this will change when this is left factored -> where -> anotherName :: Parser ([Name] -> [Name]) -> anotherName = try ((:) <$> (symbol "." *> name)) - -= Type Names - -Typenames are used in casts, and also in the typed literal syntax, -which is a typename followed by a string literal. - -Here are the grammar notes: - -== simple type name - -just an identifier chain or a multi word identifier (this is a fixed -list of possibilities, e.g. as 'character varying', see below in the -parser code for the exact list). - - ::= - | multiword-type-identifier - -== Precision type name - - ::= - -e.g. char(5) - -note: above and below every where a simple type name can appear, this -means a single identifier/quoted or a dotted chain, or a multi word -identifier - -== Precision scale type name - - ::= - -e.g. decimal(15,2) - -== Lob type name - -this is a variation on the precision type name with some extra info on -the units: - - ::= - [ ] [ ] - - ::= K | M | G - ::= CHARACTERS | CODE_UNITS | OCTETS - -(if both multiplier and char length units are missing, then this will -parse as a precision type name) - -e.g. -clob(5M octets) - -== char type name - -this is a simple type with optional precision which allows the -character set or the collation to appear as a suffix: - - ::= - - [ ] - [ CHARACTER SET ] - [ COLLATE ] - -e.g. - -char(5) character set my_charset collate my_collation - -= Time typename - -this is typename with optional precision and either 'with time zone' -or 'without time zone' suffix, e.g.: - - ::= - [ ] - - ::= WITH TIME ZONE | WITHOUT TIME ZONE - WITH TIME ZONE | WITHOUT TIME ZONE - -= row type name - - ::= - ROW [ { }... ] - - ::= - -e.g. -row(a int, b char(5)) - -= interval type name - - ::= INTERVAL [TO ] - - ::= - [ [ ] ] - -= array type name - - ::= ARRAY [ ] - -= multiset type name - - ::= MULTISET - -A type name will parse into the 'smallest' constructor it will fit in -syntactically, e.g. a clob(5) will parse to a precision type name, not -a lob type name. - -Unfortunately, to improve the error messages, there is a lot of (left) -factoring in this function, and it is a little dense. - -> typeName :: Parser TypeName -> typeName = lexeme $ -> (rowTypeName <|> intervalTypeName <|> otherTypeName) -> tnSuffix -> where -> rowTypeName = -> RowTypeName <$> (keyword_ "row" *> parens (commaSep1 rowField)) -> rowField = (,) <$> name <*> typeName -> ---------------------------- -> intervalTypeName = -> keyword_ "interval" *> -> (uncurry IntervalTypeName <$> intervalQualifier) -> ---------------------------- -> otherTypeName = -> nameOfType <**> -> (typeNameWithParens -> <|> pure Nothing <**> (timeTypeName <|> charTypeName) -> <|> pure TypeName) -> nameOfType = reservedTypeNames <|> names -> charTypeName = charSet <**> (option [] tcollate <$$$$> CharTypeName) -> <|> pure [] <**> (tcollate <$$$$> CharTypeName) -> typeNameWithParens = -> (openParen *> unsignedInteger) -> <**> (closeParen *> precMaybeSuffix -> <|> (precScaleTypeName <|> precLengthTypeName) <* closeParen) -> precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName) -> <|> pure (flip PrecTypeName) -> precScaleTypeName = (comma *> unsignedInteger) <$$$> PrecScaleTypeName -> precLengthTypeName = -> Just <$> lobPrecSuffix -> <**> (optionMaybe lobUnits <$$$$> PrecLengthTypeName) -> <|> pure Nothing <**> ((Just <$> lobUnits) <$$$$> PrecLengthTypeName) -> timeTypeName = tz <$$$> TimeTypeName -> ---------------------------- -> lobPrecSuffix = PrecK <$ keyword_ "k" -> <|> PrecM <$ keyword_ "m" -> <|> PrecG <$ keyword_ "g" -> <|> PrecT <$ keyword_ "t" -> <|> PrecP <$ keyword_ "p" -> lobUnits = PrecCharacters <$ keyword_ "characters" -> <|> PrecOctets <$ keyword_ "octets" -> tz = True <$ keywords_ ["with", "time","zone"] -> <|> False <$ keywords_ ["without", "time","zone"] -> charSet = keywords_ ["character", "set"] *> names -> tcollate = keyword_ "collate" *> names -> ---------------------------- -> tnSuffix = multiset <|> array -> multiset = MultisetTypeName <$ keyword_ "multiset" -> array = keyword_ "array" *> -> (optionMaybe (brackets unsignedInteger) <$$> ArrayTypeName) -> ---------------------------- -> -- this parser handles the fixed set of multi word -> -- type names, plus all the type names which are -> -- reserved words -> reservedTypeNames = (:[]) . Name . unwords <$> makeKeywordTree -> ["double precision" -> ,"character varying" -> ,"char varying" -> ,"character large object" -> ,"char large object" -> ,"national character" -> ,"national char" -> ,"national character varying" -> ,"national char varying" -> ,"national character large object" -> ,"nchar large object" -> ,"nchar varying" -> ,"bit varying" -> ,"binary large object" -> ,"binary varying" -> -- reserved keyword typenames: -> ,"array" -> ,"bigint" -> ,"binary" -> ,"blob" -> ,"boolean" -> ,"char" -> ,"character" -> ,"clob" -> ,"date" -> ,"dec" -> ,"decimal" -> ,"double" -> ,"float" -> ,"int" -> ,"integer" -> ,"nchar" -> ,"nclob" -> ,"numeric" -> ,"real" -> ,"smallint" -> ,"time" -> ,"timestamp" -> ,"varchar" -> ,"varbinary" -> ] - -= Value expressions - -== simple literals - -See the stringToken lexer below for notes on string literal syntax. - -> stringLit :: Parser ValueExpr -> stringLit = StringLit <$> stringToken - -> numberLit :: Parser ValueExpr -> numberLit = NumLit <$> numberLiteral - -> characterSetLit :: Parser ValueExpr -> characterSetLit = -> CSStringLit <$> shortCSPrefix <*> stringToken -> where -> shortCSPrefix = try $ choice -> [(:[]) <$> oneOf "nNbBxX" -> ,string "u&" -> ,string "U&" -> ] <* lookAhead quote - -> simpleLiteral :: Parser ValueExpr -> simpleLiteral = numberLit <|> stringLit <|> characterSetLit - -== star, param, host param - -=== star - -used in select *, select x.*, and agg(*) variations, and some other -places as well. The parser doesn't attempt to check that the star is -in a valid context, it parses it OK in any value expression context. - -> star :: Parser ValueExpr -> star = Star <$ symbol "*" - -== parameter - -unnamed parameter or named parameter -use in e.g. select * from t where a = ? -select x from t where x > :param - -> parameter :: Parser ValueExpr -> parameter = choice -> [Parameter <$ questionMark -> ,HostParameter -> <$> hostParameterToken -> <*> optionMaybe (keyword "indicator" *> hostParameterToken)] - -== parens - -value expression parens, row ctor and scalar subquery - -> parensExpr :: Parser ValueExpr -> parensExpr = parens $ choice -> [SubQueryExpr SqSq <$> queryExpr -> ,ctor <$> commaSep1 valueExpr] -> where -> ctor [a] = Parens a -> ctor as = SpecialOp [Name "rowctor"] as - -== case, cast, exists, unique, array/multiset constructor, interval - -All of these start with a fixed keyword which is reserved, so no other -syntax can start with the same keyword. - -=== case expression - -> caseExpr :: Parser ValueExpr -> caseExpr = -> Case <$> (keyword_ "case" *> optionMaybe valueExpr) -> <*> many1 whenClause -> <*> optionMaybe elseClause -> <* keyword_ "end" -> where -> whenClause = (,) <$> (keyword_ "when" *> commaSep1 valueExpr) -> <*> (keyword_ "then" *> valueExpr) -> elseClause = keyword_ "else" *> valueExpr - -=== cast - -cast: cast(expr as type) - -> cast :: Parser ValueExpr -> cast = keyword_ "cast" *> -> parens (Cast <$> valueExpr -> <*> (keyword_ "as" *> typeName)) - -=== exists, unique - -subquery expression: -[exists|unique] (queryexpr) - -> subquery :: Parser ValueExpr -> subquery = SubQueryExpr <$> sqkw <*> parens queryExpr -> where -> sqkw = SqExists <$ keyword_ "exists" <|> SqUnique <$ keyword_ "unique" - -=== array/multiset constructor - -> arrayCtor :: Parser ValueExpr -> arrayCtor = keyword_ "array" >> -> choice -> [ArrayCtor <$> parens queryExpr -> ,Array (Iden [Name "array"]) <$> brackets (commaSep valueExpr)] - -As far as I can tell, table(query expr) is just syntax sugar for -multiset(query expr). It must be there for compatibility or something. - -> multisetCtor :: Parser ValueExpr -> multisetCtor = -> choice -> [keyword_ "multiset" >> -> choice -> [MultisetQueryCtor <$> parens queryExpr -> ,MultisetCtor <$> brackets (commaSep valueExpr)] -> ,keyword_ "table" >> -> MultisetQueryCtor <$> parens queryExpr] - -> nextValueFor :: Parser ValueExpr -> nextValueFor = keywords_ ["next","value","for"] >> -> NextValueFor <$> names - -=== interval - -interval literals are a special case and we follow the grammar less -permissively here - -parse SQL interval literals, something like -interval '5' day (3) -or -interval '5' month - -if the literal looks like this: -interval 'something' - -then it is parsed as a regular typed literal. It must have a -interval-datetime-field suffix to parse as an intervallit - -It uses try because of a conflict with interval type names: todo, fix -this. also fix the monad -> applicative - -> intervalLit :: Parser ValueExpr -> intervalLit = try (keyword_ "interval" >> do -> s <- optionMaybe $ choice [True <$ symbol_ "+" -> ,False <$ symbol_ "-"] -> lit <- stringToken -> q <- optionMaybe intervalQualifier -> mkIt s lit q) -> where -> mkIt Nothing val Nothing = pure $ TypedLit (TypeName [Name "interval"]) val -> mkIt s val (Just (a,b)) = pure $ IntervalLit s val a b -> mkIt (Just {}) _val Nothing = fail "cannot use sign without interval qualifier" - -== typed literal, app, special, aggregate, window, iden - -All of these start with identifiers (some of the special functions -start with reserved keywords). - -they are all variations on suffixes on the basic identifier parser - -The windows is a suffix on the app parser - -=== iden prefix term - -all the value expressions which start with an identifier - -(todo: really put all of them here instead of just some of them) - -> idenExpr :: Parser ValueExpr -> idenExpr = -> -- todo: work out how to left factor this -> try (TypedLit <$> typeName <*> stringToken) -> <|> (names <**> option Iden app) - -=== special - -These are keyword operators which don't look like normal prefix, -postfix or infix binary operators. They mostly look like function -application but with keywords in the argument list instead of commas -to separate the arguments. - -the special op keywords -parse an operator which is -operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.) - -> data SpecialOpKFirstArg = SOKNone -> | SOKOptional -> | SOKMandatory - -> specialOpK :: String -- name of the operator -> -> SpecialOpKFirstArg -- has a first arg without a keyword -> -> [(String,Bool)] -- the other args with their keywords -> -- and whether they are optional -> -> Parser ValueExpr -> specialOpK opName firstArg kws = -> keyword_ opName >> do -> void openParen -> let pfa = do -> e <- valueExpr -> -- check we haven't parsed the first -> -- keyword as an identifier -> guard (case (e,kws) of -> (Iden [Name i], (k,_):_) | map toLower i == k -> False -> _ -> True) -> pure e -> fa <- case firstArg of -> SOKNone -> pure Nothing -> SOKOptional -> optionMaybe (try pfa) -> SOKMandatory -> Just <$> pfa -> as <- mapM parseArg kws -> void closeParen -> pure $ SpecialOpK [Name opName] fa $ catMaybes as -> where -> parseArg (nm,mand) = -> let p = keyword_ nm >> valueExpr -> in fmap (nm,) <$> if mand -> then Just <$> p -> else optionMaybe (try p) - -The actual operators: - -EXTRACT( date_part FROM expression ) - -POSITION( string1 IN string2 ) - -SUBSTRING(extraction_string FROM starting_position [FOR length] -[COLLATE collation_name]) - -CONVERT(char_value USING conversion_char_name) - -TRANSLATE(char_value USING translation_name) - -OVERLAY(string PLACING embedded_string FROM start -[FOR length]) - -TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ] -target_string -[COLLATE collation_name] ) - -> specialOpKs :: Parser ValueExpr -> specialOpKs = choice $ map try -> [extract, position, substring, convert, translate, overlay, trim] - -> extract :: Parser ValueExpr -> extract = specialOpK "extract" SOKMandatory [("from", True)] - -> position :: Parser ValueExpr -> position = specialOpK "position" SOKMandatory [("in", True)] - -strictly speaking, the substring must have at least one of from and -for, but the parser doens't enforce this - -> substring :: Parser ValueExpr -> substring = specialOpK "substring" SOKMandatory -> [("from", False),("for", False)] - -> convert :: Parser ValueExpr -> convert = specialOpK "convert" SOKMandatory [("using", True)] - - -> translate :: Parser ValueExpr -> translate = specialOpK "translate" SOKMandatory [("using", True)] - -> overlay :: Parser ValueExpr -> overlay = specialOpK "overlay" SOKMandatory -> [("placing", True),("from", True),("for", False)] - -trim is too different because of the optional char, so a custom parser -the both ' ' is filled in as the default if either parts are missing -in the source - -> trim :: Parser ValueExpr -> trim = -> keyword "trim" >> -> parens (mkTrim -> <$> option "both" sides -> <*> option " " stringToken -> <*> (keyword_ "from" *> valueExpr)) -> where -> sides = choice ["leading" <$ keyword_ "leading" -> ,"trailing" <$ keyword_ "trailing" -> ,"both" <$ keyword_ "both"] -> mkTrim fa ch fr = -> SpecialOpK [Name "trim"] Nothing -> $ catMaybes [Just (fa,StringLit ch) -> ,Just ("from", fr)] - -=== app, aggregate, window - -This parses all these variations: -normal function application with just a csv of value exprs -aggregate variations (distinct, order by in parens, filter and where - suffixes) -window apps (fn/agg followed by over) - -This code is also a little dense like the typename code because of -left factoring, later they will even have to be partially combined -together. - -> app :: Parser ([Name] -> ValueExpr) -> app = -> openParen *> choice -> [duplicates -> <**> (commaSep1 valueExpr -> <**> (((option [] orderBy) <* closeParen) -> <**> (optionMaybe afilter <$$$$$> AggregateApp))) -> -- separate cases with no all or distinct which must have at -> -- least one value expr -> ,commaSep1 valueExpr -> <**> choice -> [closeParen *> choice -> [window -> ,withinGroup -> ,(Just <$> afilter) <$$$> aggAppWithoutDupeOrd -> ,pure (flip App)] -> ,orderBy <* closeParen -> <**> (optionMaybe afilter <$$$$> aggAppWithoutDupe)] -> -- no valueExprs: duplicates and order by not allowed -> ,([] <$ closeParen) <**> option (flip App) (window <|> withinGroup) -> ] -> where -> aggAppWithoutDupeOrd n es f = AggregateApp n SQDefault es [] f -> aggAppWithoutDupe n = AggregateApp n SQDefault - -> afilter :: Parser ValueExpr -> afilter = keyword_ "filter" *> parens (keyword_ "where" *> valueExpr) - -> withinGroup :: Parser ([ValueExpr] -> [Name] -> ValueExpr) -> withinGroup = -> (keywords_ ["within", "group"] *> parens orderBy) <$$$> AggregateAppGroup - -==== window - -parse a window call as a suffix of a regular function call -this looks like this: -functionname(args) over ([partition by ids] [order by orderitems]) - -No support for explicit frames yet. - -TODO: add window support for other aggregate variations, needs some -changes to the syntax also - -> window :: Parser ([ValueExpr] -> [Name] -> ValueExpr) -> window = -> keyword_ "over" *> openParen *> option [] partitionBy -> <**> (option [] orderBy -> <**> (((optionMaybe frameClause) <* closeParen) <$$$$$> WindowApp)) -> where -> partitionBy = keywords_ ["partition","by"] *> commaSep1 valueExpr -> frameClause = -> frameRowsRange -- TODO: this 'and' could be an issue -> <**> (choice [(keyword_ "between" *> frameLimit True) -> <**> ((keyword_ "and" *> frameLimit True) -> <$$$> FrameBetween) -> -- maybe this should still use a b expression -> -- for consistency -> ,frameLimit False <**> pure (flip FrameFrom)]) -> frameRowsRange = FrameRows <$ keyword_ "rows" -> <|> FrameRange <$ keyword_ "range" -> frameLimit useB = -> choice -> [Current <$ keywords_ ["current", "row"] -> -- todo: create an automatic left factor for stuff like this -> ,keyword_ "unbounded" *> -> choice [UnboundedPreceding <$ keyword_ "preceding" -> ,UnboundedFollowing <$ keyword_ "following"] -> ,(if useB then valueExprB else valueExpr) -> <**> (Preceding <$ keyword_ "preceding" -> <|> Following <$ keyword_ "following") -> ] - -== suffixes - -These are all generic suffixes on any value expr - -=== in - -in: two variations: -a in (expr0, expr1, ...) -a in (queryexpr) - -> inSuffix :: Parser (ValueExpr -> ValueExpr) -> inSuffix = -> mkIn <$> inty -> <*> parens (choice -> [InQueryExpr <$> queryExpr -> ,InList <$> commaSep1 valueExpr]) -> where -> inty = choice [True <$ keyword_ "in" -> ,False <$ keywords_ ["not","in"]] -> mkIn i v = \e -> In i e v - -=== between - -between: -expr between expr and expr - -There is a complication when parsing between - when parsing the second -expression it is ambiguous when you hit an 'and' whether it is a -binary operator or part of the between. This code follows what -postgres does, which might be standard across SQL implementations, -which is that you can't have a binary and operator in the middle -expression in a between unless it is wrapped in parens. The 'bExpr -parsing' is used to create alternative value expression parser which -is identical to the normal one expect it doesn't recognise the binary -and operator. This is the call to valueExprB. - -> betweenSuffix :: Parser (ValueExpr -> ValueExpr) -> betweenSuffix = -> makeOp <$> Name <$> opName -> <*> valueExprB -> <*> (keyword_ "and" *> valueExprB) -> where -> opName = choice -> ["between" <$ keyword_ "between" -> ,"not between" <$ try (keywords_ ["not","between"])] -> makeOp n b c = \a -> SpecialOp [n] [a,b,c] - -=== quantified comparison - -a = any (select * from t) - -> quantifiedComparisonSuffix :: Parser (ValueExpr -> ValueExpr) -> quantifiedComparisonSuffix = do -> c <- comp -> cq <- compQuan -> q <- parens queryExpr -> pure $ \v -> QuantifiedComparison v [c] cq q -> where -> comp = Name <$> choice (map symbol -> ["=", "<>", "<=", "<", ">", ">="]) -> compQuan = choice -> [CPAny <$ keyword_ "any" -> ,CPSome <$ keyword_ "some" -> ,CPAll <$ keyword_ "all"] - -=== match - -a match (select a from t) - -> matchPredicateSuffix :: Parser (ValueExpr -> ValueExpr) -> matchPredicateSuffix = do -> keyword_ "match" -> u <- option False (True <$ keyword_ "unique") -> q <- parens queryExpr -> pure $ \v -> Match v u q - -=== array subscript - -> arraySuffix :: Parser (ValueExpr -> ValueExpr) -> arraySuffix = do -> es <- brackets (commaSep valueExpr) -> pure $ \v -> Array v es - -=== escape - -> escapeSuffix :: Parser (ValueExpr -> ValueExpr) -> escapeSuffix = do -> ctor <- choice -> [Escape <$ keyword_ "escape" -> ,UEscape <$ keyword_ "uescape"] -> c <- anyChar -> pure $ \v -> ctor v c - -=== collate - -> collateSuffix:: Parser (ValueExpr -> ValueExpr) -> collateSuffix = do -> keyword_ "collate" -> i <- names -> pure $ \v -> Collate v i - - -== operators - -The 'regular' operators in this parsing and in the abstract syntax are -unary prefix, unary postfix and binary infix operators. The operators -can be symbols (a + b), single keywords (a and b) or multiple keywords -(a is similar to b). - -TODO: carefully review the precedences and associativities. - -TODO: to fix the parsing completely, I think will need to parse -without precedence and associativity and fix up afterwards, since SQL -syntax is way too messy. It might be possible to avoid this if we -wanted to avoid extensibility and to not be concerned with parse error -messages, but both of these are too important. - -> opTable :: Bool -> [[E.Operator String ParseState Identity ValueExpr]] -> opTable bExpr = -> [-- parse match and quantified comparisons as postfix ops -> -- todo: left factor the quantified comparison with regular -> -- binary comparison, somehow -> [E.Postfix $ try quantifiedComparisonSuffix -> ,E.Postfix matchPredicateSuffix -> ] -> ,[binarySym "." E.AssocLeft] -> ,[postfix' arraySuffix -> ,postfix' escapeSuffix -> ,postfix' collateSuffix] -> ,[prefixSym "+", prefixSym "-"] -> ,[binarySym "^" E.AssocLeft] -> ,[binarySym "*" E.AssocLeft -> ,binarySym "/" E.AssocLeft -> ,binarySym "%" E.AssocLeft] -> ,[binarySym "+" E.AssocLeft -> ,binarySym "-" E.AssocLeft] -> ,[binarySym ">=" E.AssocNone -> ,binarySym "<=" E.AssocNone -> ,binarySym "!=" E.AssocRight -> ,binarySym "<>" E.AssocRight -> ,binarySym "||" E.AssocRight -> ,prefixSym "~" -> ,binarySym "&" E.AssocRight -> ,binarySym "|" E.AssocRight -> ,binaryKeyword "like" E.AssocNone -> ,binaryKeyword "overlaps" E.AssocNone] -> ++ [binaryKeywords $ makeKeywordTree -> ["not like" -> ,"is similar to" -> ,"is not similar to" -> ,"is distinct from" -> ,"is not distinct from"] -> ,postfixKeywords $ makeKeywordTree -> ["is null" -> ,"is not null" -> ,"is true" -> ,"is not true" -> ,"is false" -> ,"is not false" -> ,"is unknown" -> ,"is not unknown"] -> ] -> ++ [multisetBinOp] -> -- have to use try with inSuffix because of a conflict -> -- with 'in' in position function, and not between -> -- between also has a try in it to deal with 'not' -> -- ambiguity -> ++ [E.Postfix $ try inSuffix,E.Postfix betweenSuffix] -> ] -> ++ -> [[binarySym "<" E.AssocNone -> ,binarySym ">" E.AssocNone] -> ,[binarySym "=" E.AssocRight] -> ,[prefixKeyword "not"]] -> ++ -> if bExpr then [] else [[binaryKeyword "and" E.AssocLeft]] -> ++ -> [[binaryKeyword "or" E.AssocLeft]] -> where -> binarySym nm assoc = binary (symbol_ nm) nm assoc -> binaryKeyword nm assoc = binary (keyword_ nm) nm assoc -> binaryKeywords p = -> E.Infix (do -> o <- try p -> pure (\a b -> BinOp a [Name $ unwords o] b)) -> E.AssocNone -> postfixKeywords p = -> postfix' $ do -> o <- try p -> pure $ PostfixOp [Name $ unwords o] -> binary p nm assoc = -> E.Infix (p >> pure (\a b -> BinOp a [Name nm] b)) assoc -> multisetBinOp = E.Infix (do -> keyword_ "multiset" -> o <- choice [Union <$ keyword_ "union" -> ,Intersect <$ keyword_ "intersect" -> ,Except <$ keyword_ "except"] -> d <- option SQDefault duplicates -> pure (\a b -> MultisetBinOp a o d b)) -> E.AssocLeft -> prefixKeyword nm = prefix (keyword_ nm) nm -> prefixSym nm = prefix (symbol_ nm) nm -> prefix p nm = prefix' (p >> pure (PrefixOp [Name nm])) -> -- hack from here -> -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported -> -- not implemented properly yet -> -- I don't think this will be enough for all cases -> -- at least it works for 'not not a' -> -- ok: "x is not true is not true" -> -- no work: "x is not true is not null" -> prefix' p = E.Prefix . chainl1 p $ pure (.) -> postfix' p = E.Postfix . chainl1 p $ pure (flip (.)) - -== value expression top level - -This parses most of the value exprs.The order of the parsers and use -of try is carefully done to make everything work. It is a little -fragile and could at least do with some heavy explanation. Update: the -'try's have migrated into the individual parsers, they still need -documenting/fixing. - -> valueExpr :: Parser ValueExpr -> valueExpr = E.buildExpressionParser (opTable False) term - -> term :: Parser ValueExpr -> term = choice [simpleLiteral -> ,parameter -> ,star -> ,parensExpr -> ,caseExpr -> ,cast -> ,arrayCtor -> ,multisetCtor -> ,nextValueFor -> ,subquery -> ,intervalLit -> ,specialOpKs -> ,idenExpr] -> "value expression" - -expose the b expression for window frame clause range between - -> valueExprB :: Parser ValueExpr -> valueExprB = E.buildExpressionParser (opTable True) term - -== helper parsers - -This is used in interval literals and in interval type names. - -> intervalQualifier :: Parser (IntervalTypeField,Maybe IntervalTypeField) -> intervalQualifier = -> (,) <$> intervalField -> <*> optionMaybe (keyword_ "to" *> intervalField) -> where -> intervalField = -> Itf -> <$> datetimeField -> <*> optionMaybe -> (parens ((,) <$> unsignedInteger -> <*> optionMaybe (comma *> unsignedInteger))) - -TODO: use datetime field in extract also -use a data type for the datetime field? - -> datetimeField :: Parser String -> datetimeField = choice (map keyword ["year","month","day" -> ,"hour","minute","second"]) -> "datetime field" - -This is used in multiset operations (value expr), selects (query expr) -and set operations (query expr). - -> duplicates :: Parser SetQuantifier -> duplicates = -> choice [All <$ keyword_ "all" -> ,Distinct <$ keyword "distinct"] - -------------------------------------------------- - -= query expressions - -== select lists - -> selectItem :: Parser (ValueExpr,Maybe Name) -> selectItem = (,) <$> valueExpr <*> optionMaybe als -> where als = optional (keyword_ "as") *> name - -> selectList :: Parser [(ValueExpr,Maybe Name)] -> selectList = commaSep1 selectItem - -== from - -Here is the rough grammar for joins - -tref -(cross | [natural] ([inner] | (left | right | full) [outer])) join -tref -[on expr | using (...)] - -TODO: either use explicit 'operator precedence' parsers or build -expression parser for the 'tref operators' such as joins, lateral, -aliases. - -> from :: Parser [TableRef] -> from = keyword_ "from" *> commaSep1 tref -> where -> -- TODO: use P (a->) for the join tref suffix -> -- chainl or buildexpressionparser -> tref = nonJoinTref >>= optionSuffix joinTrefSuffix -> nonJoinTref = choice -> [parens $ choice -> [TRQueryExpr <$> queryExpr -> ,TRParens <$> tref] -> ,TRLateral <$> (keyword_ "lateral" -> *> nonJoinTref) -> ,do -> n <- names -> choice [TRFunction n -> <$> parens (commaSep valueExpr) -> ,pure $ TRSimple n]] aliasSuffix -> aliasSuffix = fromAlias <$$> TRAlias -> joinTrefSuffix t = -> (TRJoin t <$> option False (True <$ keyword_ "natural") -> <*> joinType -> <*> nonJoinTref -> <*> optionMaybe joinCondition) -> >>= optionSuffix joinTrefSuffix - -TODO: factor the join stuff to produce better error messages (and make -it more readable) - -> joinType :: Parser JoinType -> joinType = choice -> [JCross <$ keyword_ "cross" <* keyword_ "join" -> ,JInner <$ keyword_ "inner" <* keyword_ "join" -> ,JLeft <$ keyword_ "left" -> <* optional (keyword_ "outer") -> <* keyword_ "join" -> ,JRight <$ keyword_ "right" -> <* optional (keyword_ "outer") -> <* keyword_ "join" -> ,JFull <$ keyword_ "full" -> <* optional (keyword_ "outer") -> <* keyword_ "join" -> ,JInner <$ keyword_ "join"] - -> joinCondition :: Parser JoinCondition -> joinCondition = choice -> [keyword_ "on" >> JoinOn <$> valueExpr -> ,keyword_ "using" >> JoinUsing <$> parens (commaSep1 name)] - -> fromAlias :: Parser Alias -> fromAlias = Alias <$> tableAlias <*> columnAliases -> where -> tableAlias = optional (keyword_ "as") *> name -> columnAliases = optionMaybe $ parens $ commaSep1 name - -== simple other parts - -Parsers for where, group by, having, order by and limit, which are -pretty trivial. - -> whereClause :: Parser ValueExpr -> whereClause = keyword_ "where" *> valueExpr - -> groupByClause :: Parser [GroupingExpr] -> groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression -> where -> groupingExpression = choice -> [keyword_ "cube" >> -> Cube <$> parens (commaSep groupingExpression) -> ,keyword_ "rollup" >> -> Rollup <$> parens (commaSep groupingExpression) -> ,GroupingParens <$> parens (commaSep groupingExpression) -> ,keywords_ ["grouping", "sets"] >> -> GroupingSets <$> parens (commaSep groupingExpression) -> ,SimpleGroup <$> valueExpr -> ] - -> having :: Parser ValueExpr -> having = keyword_ "having" *> valueExpr - -> orderBy :: Parser [SortSpec] -> orderBy = keywords_ ["order","by"] *> commaSep1 ob -> where -> ob = SortSpec -> <$> valueExpr -> <*> option DirDefault (choice [Asc <$ keyword_ "asc" -> ,Desc <$ keyword_ "desc"]) -> <*> option NullsOrderDefault -> -- todo: left factor better -> (keyword_ "nulls" >> -> choice [NullsFirst <$ keyword "first" -> ,NullsLast <$ keyword "last"]) - -allows offset and fetch in either order -+ postgresql offset without row(s) and limit instead of fetch also - -> offsetFetch :: Parser (Maybe ValueExpr, Maybe ValueExpr) -> offsetFetch = permute ((,) <$?> (Nothing, Just <$> offset) -> <|?> (Nothing, Just <$> fetch)) - -> offset :: Parser ValueExpr -> offset = keyword_ "offset" *> valueExpr -> <* option () (choice [keyword_ "rows" -> ,keyword_ "row"]) - -> fetch :: Parser ValueExpr -> fetch = fetchFirst <|> limit -> where -> fetchFirst = guardDialect [SQL2011] -> *> fs *> valueExpr <* ro -> fs = makeKeywordTree ["fetch first", "fetch next"] -> ro = makeKeywordTree ["rows only", "row only"] -> -- todo: not in ansi sql dialect -> limit = guardDialect [MySQL] *> -> keyword_ "limit" *> valueExpr - -== common table expressions - -> with :: Parser QueryExpr -> with = keyword_ "with" >> -> With <$> option False (True <$ keyword_ "recursive") -> <*> commaSep1 withQuery <*> queryExpr -> where -> withQuery = (,) <$> (fromAlias <* keyword_ "as") -> <*> parens queryExpr - -== query expression - -This parser parses any query expression variant: normal select, cte, -and union, etc.. - -> queryExpr :: Parser QueryExpr -> queryExpr = choice -> [with -> ,chainr1 (choice [values,table, select]) setOp] -> where -> select = keyword_ "select" >> -> mkSelect -> <$> option SQDefault duplicates -> <*> selectList -> <*> optionMaybe tableExpression -> mkSelect d sl Nothing = -> makeSelect{qeSetQuantifier = d, qeSelectList = sl} -> mkSelect d sl (Just (TableExpression f w g h od ofs fe)) = -> Select d sl f w g h od ofs fe -> values = keyword_ "values" -> >> Values <$> commaSep (parens (commaSep valueExpr)) -> table = keyword_ "table" >> Table <$> names - -local data type to help with parsing the bit after the select list, -called 'table expression' in the ansi sql grammar. Maybe this should -be in the public syntax? - -> data TableExpression -> = TableExpression -> {_teFrom :: [TableRef] -> ,_teWhere :: Maybe ValueExpr -> ,_teGroupBy :: [GroupingExpr] -> ,_teHaving :: Maybe ValueExpr -> ,_teOrderBy :: [SortSpec] -> ,_teOffset :: Maybe ValueExpr -> ,_teFetchFirst :: Maybe ValueExpr} - -> tableExpression :: Parser TableExpression -> tableExpression = mkTe <$> from -> <*> optionMaybe whereClause -> <*> option [] groupByClause -> <*> optionMaybe having -> <*> option [] orderBy -> <*> offsetFetch -> where -> mkTe f w g h od (ofs,fe) = -> TableExpression f w g h od ofs fe - -> setOp :: Parser (QueryExpr -> QueryExpr -> QueryExpr) -> setOp = cq -> <$> setOpK -> <*> option SQDefault duplicates -> <*> corr -> where -> cq o d c q0 q1 = CombineQueryExpr q0 o d c q1 -> setOpK = choice [Union <$ keyword_ "union" -> ,Intersect <$ keyword_ "intersect" -> ,Except <$ keyword_ "except"] -> "set operator" -> corr = option Respectively (Corresponding <$ keyword_ "corresponding") - - -wrapper for query expr which ignores optional trailing semicolon. - -TODO: change style - -> topLevelQueryExpr :: Parser QueryExpr -> topLevelQueryExpr = queryExpr (id <$ semi) - -wrapper to parse a series of query exprs from a single source. They -must be separated by semicolon, but for the last expression, the -trailing semicolon is optional. - -TODO: change style - -> queryExprs :: Parser [QueryExpr] -> queryExprs = (:[]) <$> queryExpr -> >>= optionSuffix ((semi *>) . pure) -> >>= optionSuffix (\p -> (p++) <$> queryExprs) - ----------------------------------------------- - -= multi keyword helper - -This helper is to help parsing multiple options of multiple keywords -with similar prefixes, e.g. parsing 'is null' and 'is not null'. - -use to left factor/ improve: -typed literal and general identifiers -not like, not in, not between operators -help with factoring keyword functions and other app-likes -the join keyword sequences -fetch first/next -row/rows only - -There is probably a simpler way of doing this but I am a bit -thick. - -> makeKeywordTree :: [String] -> Parser [String] -> makeKeywordTree sets = -> parseTrees (sort $ map words sets) -> where -> parseTrees :: [[String]] -> Parser [String] -> parseTrees ws = do -> let gs :: [[[String]]] -> gs = groupBy ((==) `on` safeHead) ws -> choice $ map parseGroup gs -> parseGroup :: [[String]] -> Parser [String] -> parseGroup l@((k:_):_) = do -> keyword_ k -> let tls = catMaybes $ map safeTail l -> pr = (k:) <$> parseTrees tls -> if (or $ map null tls) -> then pr <|> pure [k] -> else pr -> parseGroup _ = guard False >> error "impossible" -> safeHead (x:_) = Just x -> safeHead [] = Nothing -> safeTail (_:x) = Just x -> safeTail [] = Nothing - ------------------------------------------------- - -= lexing parsers - -whitespace parser which skips comments also - -> whitespace :: Parser () -> whitespace = -> choice [simpleWhitespace *> whitespace -> ,lineComment *> whitespace -> ,blockComment *> whitespace -> ,pure ()] "whitespace" -> where -> lineComment = try (string "--") -> *> manyTill anyChar (void (char '\n') <|> eof) -> blockComment = -- no nesting of block comments in SQL -> try (string "/*") -> -- try used here so it doesn't fail when we see a -> -- '*' which isn't followed by a '/' -> *> manyTill anyChar (try $ string "*/") -> -- use many1 so we can more easily avoid non terminating loops -> simpleWhitespace = void $ many1 (oneOf " \t\n") - -> lexeme :: Parser a -> Parser a -> lexeme p = p <* whitespace - -> unsignedInteger :: Parser Integer -> unsignedInteger = read <$> lexeme (many1 digit) "integer" - - -number literals - -here is the rough grammar target: - -digits -digits.[digits][e[+-]digits] -[digits].digits[e[+-]digits] -digitse[+-]digits - -numbers are parsed to strings, not to a numeric type. This is to avoid -making a decision on how to represent numbers, the client code can -make this choice. - -> numberLiteral :: Parser String -> numberLiteral = lexeme ( -> (int (pp dot pp int) -> <|> (++) <$> dot <*> int) -> pp expon) -> where -> int = many1 digit -> dot = string "." -> expon = (:) <$> oneOf "eE" <*> sInt -> sInt = (++) <$> option "" (string "+" <|> string "-") <*> int -> pp = (<$$> (++)) - - -> identifier :: Parser String -> identifier = lexeme ((:) <$> firstChar <*> many nonFirstChar) -> "identifier" -> where -> firstChar = letter <|> char '_' "identifier" -> nonFirstChar = digit <|> firstChar "" - -> quotedIdentifier :: Parser String -> quotedIdentifier = quotedIdenHelper - -> quotedIdenHelper :: Parser String -> quotedIdenHelper = -> lexeme (dq *> manyTill anyChar dq >>= optionSuffix moreIden) -> "identifier" -> where -> moreIden s0 = do -> void dq -> s <- manyTill anyChar dq -> optionSuffix moreIden (s0 ++ "\"" ++ s) -> dq = char '"' "double quote" - -> uquotedIdentifier :: Parser String -> uquotedIdentifier = -> try (string "u&" <|> string "U&") *> quotedIdenHelper -> "identifier" - -parses an identifier with a : prefix. The : isn't included in the -return value - -> hostParameterToken :: Parser String -> hostParameterToken = lexeme $ char ':' *> identifier - -todo: work out the symbol parsing better - -> symbol :: String -> Parser String -> symbol s = try (lexeme $ do -> u <- choice (many1 (char '.') : -> map (try . string) [">=","<=","!=","<>","||"] -> ++ map (string . (:[])) "+-^*/%~&|<>=") -> guard (s == u) -> pure s) -> s - -> questionMark :: Parser Char -> questionMark = lexeme (char '?') "question mark" - -> openParen :: Parser Char -> openParen = lexeme $ char '(' - -> closeParen :: Parser Char -> closeParen = lexeme $ char ')' - -> openBracket :: Parser Char -> openBracket = lexeme $ char '[' - -> closeBracket :: Parser Char -> closeBracket = lexeme $ char ']' - - -> comma :: Parser Char -> comma = lexeme (char ',') "comma" - -> semi :: Parser Char -> semi = lexeme (char ';') "semicolon" - -> quote :: Parser Char -> quote = lexeme (char '\'') "single quote" - -> --stringToken :: Parser String -> --stringToken = lexeme (char '\'' *> manyTill anyChar (char '\'')) -> -- todo: tidy this up, add the prefixes stuff, and add the multiple -> -- string stuff -> stringToken :: Parser String -> stringToken = -> lexeme (nlquote *> manyTill anyChar nlquote -> >>= optionSuffix moreString) -> "string" -> where -> moreString s0 = choice -> [-- handle two adjacent quotes -> do -> void nlquote -> s <- manyTill anyChar nlquote -> optionSuffix moreString (s0 ++ "'" ++ s) -> ,-- handle string in separate parts -> -- e.g. 'part 1' 'part 2' -> do --can this whitespace be factored out? -> -- since it will be parsed twice when there is no more literal -> -- yes: split the adjacent quote and multiline literal -> -- into two different suffixes -> -- won't need to call lexeme at the top level anymore after this -> try (whitespace <* nlquote) -> s <- manyTill anyChar nlquote -> optionSuffix moreString (s0 ++ s) -> ] -> -- non lexeme quote -> nlquote = char '\'' "single quote" - -= helper functions - -> keyword :: String -> Parser String -> keyword k = try (do -> i <- identifier -> guard (map toLower i == k) -> pure k) k - -helper function to improve error messages - -> keywords_ :: [String] -> Parser () -> keywords_ ks = mapM_ keyword_ ks intercalate " " ks - - -> parens :: Parser a -> Parser a -> parens = between openParen closeParen - -> brackets :: Parser a -> Parser a -> brackets = between openBracket closeBracket - -> commaSep :: Parser a -> Parser [a] -> commaSep = (`sepBy` comma) - -> keyword_ :: String -> Parser () -> keyword_ = void . keyword - -> symbol_ :: String -> Parser () -> symbol_ = void . symbol - -> commaSep1 :: Parser a -> Parser [a] -> commaSep1 = (`sepBy1` comma) - -> identifierBlacklist :: [String] -> Parser String -> identifierBlacklist bl = try (do -> i <- identifier -> when (map toLower i `elem` bl) $ -> fail $ "keyword not allowed here: " ++ i -> pure i) -> "identifier" - -> blacklist :: Dialect -> [String] -> blacklist = reservedWord - -These blacklisted names are mostly needed when we parse something with -an optional alias, e.g. select a a from t. If we write select a from -t, we have to make sure the from isn't parsed as an alias. I'm not -sure what other places strictly need the blacklist, and in theory it -could be tuned differently for each place the identifierString/ -identifier parsers are used to only blacklist the bare -minimum. Something like this might be needed for dialect support, even -if it is pretty silly to use a keyword as an unquoted identifier when -there is a effing quoting syntax as well. - -The standard has a weird mix of reserved keywords and unreserved -keywords (I'm not sure what exactly being an unreserved keyword -means). - -> reservedWord :: Dialect -> [String] -> reservedWord SQL2011 = -> ["abs" -> --,"all" -> ,"allocate" -> ,"alter" -> ,"and" -> --,"any" -> ,"are" -> ,"array" -> --,"array_agg" -> ,"array_max_cardinality" -> ,"as" -> ,"asensitive" -> ,"asymmetric" -> ,"at" -> ,"atomic" -> ,"authorization" -> --,"avg" -> ,"begin" -> ,"begin_frame" -> ,"begin_partition" -> ,"between" -> ,"bigint" -> ,"binary" -> ,"blob" -> ,"boolean" -> ,"both" -> ,"by" -> ,"call" -> ,"called" -> ,"cardinality" -> ,"cascaded" -> ,"case" -> ,"cast" -> ,"ceil" -> ,"ceiling" -> ,"char" -> ,"char_length" -> ,"character" -> ,"character_length" -> ,"check" -> ,"clob" -> ,"close" -> ,"coalesce" -> ,"collate" -> --,"collect" -> ,"column" -> ,"commit" -> ,"condition" -> ,"connect" -> ,"constraint" -> ,"contains" -> ,"convert" -> --,"corr" -> ,"corresponding" -> --,"count" -> --,"covar_pop" -> --,"covar_samp" -> ,"create" -> ,"cross" -> ,"cube" -> --,"cume_dist" -> ,"current" -> ,"current_catalog" -> --,"current_date" -> --,"current_default_transform_group" -> --,"current_path" -> --,"current_role" -> ,"current_row" -> ,"current_schema" -> ,"current_time" -> ,"current_timestamp" -> ,"current_transform_group_for_type" -> --,"current_user" -> ,"cursor" -> ,"cycle" -> ,"date" -> --,"day" -> ,"deallocate" -> ,"dec" -> ,"decimal" -> ,"declare" -> --,"default" -> ,"delete" -> --,"dense_rank" -> ,"deref" -> ,"describe" -> ,"deterministic" -> ,"disconnect" -> ,"distinct" -> ,"double" -> ,"drop" -> ,"dynamic" -> ,"each" -> --,"element" -> ,"else" -> ,"end" -> ,"end_frame" -> ,"end_partition" -> ,"end-exec" -> ,"equals" -> ,"escape" -> --,"every" -> ,"except" -> ,"exec" -> ,"execute" -> ,"exists" -> ,"exp" -> ,"external" -> ,"extract" -> --,"false" -> ,"fetch" -> ,"filter" -> ,"first_value" -> ,"float" -> ,"floor" -> ,"for" -> ,"foreign" -> ,"frame_row" -> ,"free" -> ,"from" -> ,"full" -> ,"function" -> --,"fusion" -> ,"get" -> ,"global" -> ,"grant" -> ,"group" -> --,"grouping" -> ,"groups" -> ,"having" -> ,"hold" -> --,"hour" -> ,"identity" -> ,"in" -> ,"indicator" -> ,"inner" -> ,"inout" -> ,"insensitive" -> ,"insert" -> ,"int" -> ,"integer" -> ,"intersect" -> --,"intersection" -> ,"interval" -> ,"into" -> ,"is" -> ,"join" -> ,"lag" -> ,"language" -> ,"large" -> ,"last_value" -> ,"lateral" -> ,"lead" -> ,"leading" -> ,"left" -> ,"like" -> ,"like_regex" -> ,"ln" -> ,"local" -> ,"localtime" -> ,"localtimestamp" -> ,"lower" -> ,"match" -> --,"max" -> ,"member" -> ,"merge" -> ,"method" -> --,"min" -> --,"minute" -> ,"mod" -> ,"modifies" -> --,"module" -> --,"month" -> ,"multiset" -> ,"national" -> ,"natural" -> ,"nchar" -> ,"nclob" -> ,"new" -> ,"no" -> ,"none" -> ,"normalize" -> ,"not" -> ,"nth_value" -> ,"ntile" -> --,"null" -> ,"nullif" -> ,"numeric" -> ,"octet_length" -> ,"occurrences_regex" -> ,"of" -> ,"offset" -> ,"old" -> ,"on" -> ,"only" -> ,"open" -> ,"or" -> ,"order" -> ,"out" -> ,"outer" -> ,"over" -> ,"overlaps" -> ,"overlay" -> ,"parameter" -> ,"partition" -> ,"percent" -> --,"percent_rank" -> --,"percentile_cont" -> --,"percentile_disc" -> ,"period" -> ,"portion" -> ,"position" -> ,"position_regex" -> ,"power" -> ,"precedes" -> ,"precision" -> ,"prepare" -> ,"primary" -> ,"procedure" -> ,"range" -> --,"rank" -> ,"reads" -> ,"real" -> ,"recursive" -> ,"ref" -> ,"references" -> ,"referencing" -> --,"regr_avgx" -> --,"regr_avgy" -> --,"regr_count" -> --,"regr_intercept" -> --,"regr_r2" -> --,"regr_slope" -> --,"regr_sxx" -> --,"regr_sxy" -> --,"regr_syy" -> ,"release" -> ,"result" -> ,"return" -> ,"returns" -> ,"revoke" -> ,"right" -> ,"rollback" -> ,"rollup" -> --,"row" -> ,"row_number" -> ,"rows" -> ,"savepoint" -> ,"scope" -> ,"scroll" -> ,"search" -> --,"second" -> ,"select" -> ,"sensitive" -> --,"session_user" -> --,"set" -> ,"similar" -> ,"smallint" -> --,"some" -> ,"specific" -> ,"specifictype" -> ,"sql" -> ,"sqlexception" -> ,"sqlstate" -> ,"sqlwarning" -> ,"sqrt" -> --,"start" -> ,"static" -> --,"stddev_pop" -> --,"stddev_samp" -> ,"submultiset" -> ,"substring" -> ,"substring_regex" -> ,"succeeds" -> --,"sum" -> ,"symmetric" -> ,"system" -> ,"system_time" -> --,"system_user" -> ,"table" -> ,"tablesample" -> ,"then" -> ,"time" -> ,"timestamp" -> ,"timezone_hour" -> ,"timezone_minute" -> ,"to" -> ,"trailing" -> ,"translate" -> ,"translate_regex" -> ,"translation" -> ,"treat" -> ,"trigger" -> ,"truncate" -> ,"trim" -> ,"trim_array" -> --,"true" -> ,"uescape" -> ,"union" -> ,"unique" -> --,"unknown" -> ,"unnest" -> ,"update" -> ,"upper" -> --,"user" -> ,"using" -> --,"value" -> ,"values" -> ,"value_of" -> --,"var_pop" -> --,"var_samp" -> ,"varbinary" -> ,"varchar" -> ,"varying" -> ,"versioning" -> ,"when" -> ,"whenever" -> ,"where" -> ,"width_bucket" -> ,"window" -> ,"with" -> ,"within" -> ,"without" -> --,"year" -> ] - -TODO: create this list properly - -> reservedWord MySQL = reservedWord SQL2011 ++ ["limit"] - - ------------ - -bit hacky, used to make the dialect available during parsing so -different parsers can be used for different dialects - -> type ParseState = Dialect - -> type Parser = Parsec String ParseState - -> guardDialect :: [Dialect] -> Parser () -> guardDialect ds = do -> d <- getState -> guard (d `elem` ds) - -TODO: the ParseState and the Dialect argument should be turned into a -flags struct. Part (or all?) of this struct is the dialect -information, but each dialect has different versions + a big set of -flags to control syntax variations within a version of a product -dialect (for instance, string and identifier parsing rules vary from -dialect to dialect and version to version, and most or all SQL DBMSs -appear to have a set of flags to further enable or disable variations -for quoting and escaping strings and identifiers). diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -1,88 +1,98 @@ > {-# LANGUAGE CPP #-} -> > -- | These is the pretty printing functions, which produce SQL > -- source from ASTs. The code attempts to format the output in a > -- readable way. > module Language.SQL.SimpleSQL.Pretty > (prettyQueryExpr -> ,prettyValueExpr -> ,prettyQueryExprs +> ,prettyScalarExpr +> ,prettyStatement +> ,prettyStatements > ) where +#if MIN_VERSION_base(4,11,0) + +> import Prelude hiding ((<>)) + +#endif + TODO: there should be more comments in this file, especially the bits which have been changed to try to improve the layout of the output. > import Language.SQL.SimpleSQL.Syntax +> import Language.SQL.SimpleSQL.Dialect > import Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens, > nest, Doc, punctuate, comma, sep, quotes, -> doubleQuotes, brackets,hcat) +> brackets,hcat) > import Data.Maybe (maybeToList, catMaybes) > import Data.List (intercalate) -#if MIN_VERSION_base(4,11,0) -> import Prelude hiding ((<>)) -#endif - > -- | Convert a query expr ast to concrete syntax. > prettyQueryExpr :: Dialect -> QueryExpr -> String > prettyQueryExpr d = render . queryExpr d > -- | Convert a value expr ast to concrete syntax. -> prettyValueExpr :: Dialect -> ValueExpr -> String -> prettyValueExpr d = render . valueExpr d +> prettyScalarExpr :: Dialect -> ScalarExpr -> String +> prettyScalarExpr d = render . scalarExpr d -> -- | Convert a list of query exprs to concrete syntax. A semi colon -> -- is inserted after each query expr. -> prettyQueryExprs :: Dialect -> [QueryExpr] -> String -> prettyQueryExprs d = render . vcat . map ((<> text ";\n") . queryExpr d) +> -- | Convert a statement ast to concrete syntax. +> prettyStatement :: Dialect -> Statement -> String +> prettyStatement d = render . statement d -= value expressions +> -- | Convert a list of statements to concrete syntax. A semicolon +> -- is inserted after each statement. +> prettyStatements :: Dialect -> [Statement] -> String +> prettyStatements d = render . vcat . map ((<> text ";\n") . statement d) -> valueExpr :: Dialect -> ValueExpr -> Doc -> valueExpr _ (StringLit s) = quotes $ text $ doubleUpQuotes s += scalar expressions -> valueExpr _ (NumLit s) = text s -> valueExpr _ (IntervalLit s v f t) = +> scalarExpr :: Dialect -> ScalarExpr -> Doc +> scalarExpr _ (StringLit s e t) = text s <> text t <> text e + +> scalarExpr _ (NumLit s) = text s +> scalarExpr _ (IntervalLit s v f t) = > text "interval" -> <+> me (\x -> if x then text "+" else text "-") s +> <+> me (\x -> text $ case x of +> Plus -> "+" +> Minus -> "-") s > <+> quotes (text v) > <+> intervalTypeField f > <+> me (\x -> text "to" <+> intervalTypeField x) t -> valueExpr _ (Iden i) = names i -> valueExpr _ Star = text "*" -> valueExpr _ Parameter = text "?" -> valueExpr _ (HostParameter p i) = -> text (':':p) -> <+> me (\i' -> text "indicator" <+> text (':':i')) i +> scalarExpr _ (Iden i) = names i +> scalarExpr _ Star = text "*" +> scalarExpr _ Parameter = text "?" +> scalarExpr _ (PositionalArg n) = text $ "$" ++ show n +> scalarExpr _ (HostParameter p i) = +> text p +> <+> me (\i' -> text "indicator" <+> text i') i -> valueExpr d (App f es) = names f <> parens (commaSep (map (valueExpr d) es)) +> scalarExpr d (App f es) = names f <> parens (commaSep (map (scalarExpr d) es)) -> valueExpr dia (AggregateApp f d es od fil) = +> scalarExpr dia (AggregateApp f d es od fil) = > names f > <> parens ((case d of > Distinct -> text "distinct" > All -> text "all" > SQDefault -> empty) -> <+> commaSep (map (valueExpr dia) es) +> <+> commaSep (map (scalarExpr dia) es) > <+> orderBy dia od) > <+> me (\x -> text "filter" -> <+> parens (text "where" <+> valueExpr dia x)) fil +> <+> parens (text "where" <+> scalarExpr dia x)) fil -> valueExpr d (AggregateAppGroup f es od) = +> scalarExpr d (AggregateAppGroup f es od) = > names f -> <> parens (commaSep (map (valueExpr d) es)) +> <> parens (commaSep (map (scalarExpr d) es)) > <+> if null od > then empty > else text "within group" <+> parens (orderBy d od) -> valueExpr d (WindowApp f es pb od fr) = -> names f <> parens (commaSep $ map (valueExpr d) es) +> scalarExpr d (WindowApp f es pb od fr) = +> names f <> parens (commaSep $ map (scalarExpr d) es) > <+> text "over" > <+> parens ((case pb of > [] -> empty > _ -> text "partition by" -> <+> nest 13 (commaSep $ map (valueExpr d) pb)) +> <+> nest 13 (commaSep $ map (scalarExpr d) pb)) > <+> orderBy d od > <+> me frd fr) > where @@ -96,72 +106,73 @@ > fpd UnboundedPreceding = text "unbounded preceding" > fpd UnboundedFollowing = text "unbounded following" > fpd Current = text "current row" -> fpd (Preceding e) = valueExpr d e <+> text "preceding" -> fpd (Following e) = valueExpr d e <+> text "following" +> fpd (Preceding e) = scalarExpr d e <+> text "preceding" +> fpd (Following e) = scalarExpr d e <+> text "following" -> valueExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name "between"] -> ,[Name "not between"]] = -> sep [valueExpr dia a -> ,names nm <+> valueExpr dia b -> ,nest (length (unnames nm) + 1) $ text "and" <+> valueExpr dia c] +> scalarExpr dia (SpecialOp nm [a,b,c]) | nm `elem` [[Name Nothing "between"] +> ,[Name Nothing "not between"]] = +> sep [scalarExpr dia a +> ,names nm <+> scalarExpr dia b +> ,nest (length (unnames nm) + 1) $ text "and" <+> scalarExpr dia c] -> valueExpr d (SpecialOp [Name "rowctor"] as) = -> parens $ commaSep $ map (valueExpr d) as +> scalarExpr d (SpecialOp [Name Nothing "rowctor"] as) = +> parens $ commaSep $ map (scalarExpr d) as -> valueExpr d (SpecialOp nm es) = -> names nm <+> parens (commaSep $ map (valueExpr d) es) +> scalarExpr d (SpecialOp nm es) = +> names nm <+> parens (commaSep $ map (scalarExpr d) es) -> valueExpr d (SpecialOpK nm fs as) = +> scalarExpr d (SpecialOpK nm fs as) = > names nm <> parens (sep $ catMaybes -> (fmap (valueExpr d) fs -> : map (\(n,e) -> Just (text n <+> valueExpr d e)) as)) +> (fmap (scalarExpr d) fs +> : map (\(n,e) -> Just (text n <+> scalarExpr d e)) as)) -> valueExpr d (PrefixOp f e) = names f <+> valueExpr d e -> valueExpr d (PostfixOp f e) = valueExpr d e <+> names f -> valueExpr d e@(BinOp _ op _) | op `elem` [[Name "and"], [Name "or"]] = +> scalarExpr d (PrefixOp f e) = names f <+> scalarExpr d e +> scalarExpr d (PostfixOp f e) = scalarExpr d e <+> names f +> scalarExpr d e@(BinOp _ op _) | op `elem` [[Name Nothing "and"] +> ,[Name Nothing "or"]] = > -- special case for and, or, get all the ands so we can vcat them > -- nicely > case ands e of -> (e':es) -> vcat (valueExpr d e' -> : map ((names op <+>) . valueExpr d) es) +> (e':es) -> vcat (scalarExpr d e' +> : map ((names op <+>) . scalarExpr d) es) > [] -> empty -- shouldn't be possible > where > ands (BinOp a op' b) | op == op' = ands a ++ ands b > ands x = [x] > -- special case for . we don't use whitespace -> valueExpr d (BinOp e0 [Name "."] e1) = -> valueExpr d e0 <> text "." <> valueExpr d e1 -> valueExpr d (BinOp e0 f e1) = -> valueExpr d e0 <+> names f <+> valueExpr d e1 +> scalarExpr d (BinOp e0 [Name Nothing "."] e1) = +> scalarExpr d e0 <> text "." <> scalarExpr d e1 +> scalarExpr d (BinOp e0 f e1) = +> scalarExpr d e0 <+> names f <+> scalarExpr d e1 -> valueExpr dia (Case t ws els) = -> sep $ [text "case" <+> me (valueExpr dia) t] +> scalarExpr dia (Case t ws els) = +> sep $ [text "case" <+> me (scalarExpr dia) t] > ++ map w ws > ++ maybeToList (fmap e els) > ++ [text "end"] > where > w (t0,t1) = -> text "when" <+> nest 5 (commaSep $ map (valueExpr dia) t0) -> <+> text "then" <+> nest 5 (valueExpr dia t1) -> e el = text "else" <+> nest 5 (valueExpr dia el) -> valueExpr d (Parens e) = parens $ valueExpr d e -> valueExpr d (Cast e tn) = -> text "cast" <> parens (sep [valueExpr d e +> text "when" <+> nest 5 (commaSep $ map (scalarExpr dia) t0) +> <+> text "then" <+> nest 5 (scalarExpr dia t1) +> e el = text "else" <+> nest 5 (scalarExpr dia el) +> scalarExpr d (Parens e) = parens $ scalarExpr d e +> scalarExpr d (Cast e tn) = +> text "cast" <> parens (sep [scalarExpr d e > ,text "as" > ,typeName tn]) -> valueExpr _ (TypedLit tn s) = +> scalarExpr _ (TypedLit tn s) = > typeName tn <+> quotes (text s) -> valueExpr d (SubQueryExpr ty qe) = +> scalarExpr d (SubQueryExpr ty qe) = > (case ty of > SqSq -> empty > SqExists -> text "exists" > SqUnique -> text "unique" > ) <+> parens (queryExpr d qe) -> valueExpr d (QuantifiedComparison v c cp sq) = -> valueExpr d v +> scalarExpr d (QuantifiedComparison v c cp sq) = +> scalarExpr d v > <+> names c > <+> (text $ case cp of > CPAny -> "any" @@ -169,36 +180,36 @@ > CPAll -> "all") > <+> parens (queryExpr d sq) -> valueExpr d (Match v u sq) = -> valueExpr d v +> scalarExpr d (Match v u sq) = +> scalarExpr d v > <+> text "match" > <+> (if u then text "unique" else empty) > <+> parens (queryExpr d sq) -> valueExpr d (In b se x) = -> valueExpr d se <+> +> scalarExpr d (In b se x) = +> scalarExpr d se <+> > (if b then empty else text "not") > <+> text "in" > <+> parens (nest (if b then 3 else 7) $ > case x of -> InList es -> commaSep $ map (valueExpr d) es +> InList es -> commaSep $ map (scalarExpr d) es > InQueryExpr qe -> queryExpr d qe) -> valueExpr d (Array v es) = -> valueExpr d v <> brackets (commaSep $ map (valueExpr d) es) +> scalarExpr d (Array v es) = +> scalarExpr d v <> brackets (commaSep $ map (scalarExpr d) es) -> valueExpr d (ArrayCtor q) = +> scalarExpr d (ArrayCtor q) = > text "array" <> parens (queryExpr d q) -> valueExpr d (MultisetCtor es) = -> text "multiset" <> brackets (commaSep $ map (valueExpr d) es) +> scalarExpr d (MultisetCtor es) = +> text "multiset" <> brackets (commaSep $ map (scalarExpr d) es) -> valueExpr d (MultisetQueryCtor q) = +> scalarExpr d (MultisetQueryCtor q) = > text "multiset" <> parens (queryExpr d q) -> valueExpr d (MultisetBinOp a c q b) = +> scalarExpr d (MultisetBinOp a c q b) = > sep -> [valueExpr d a +> [scalarExpr d a > ,text "multiset" > ,text $ case c of > Union -> "union" @@ -208,56 +219,45 @@ > SQDefault -> empty > All -> text "all" > Distinct -> text "distinct" -> ,valueExpr d b] - - - -> valueExpr _ (CSStringLit cs st) = -> text cs <> quotes (text $ doubleUpQuotes st) +> ,scalarExpr d b] -> valueExpr d (Escape v e) = -> valueExpr d v <+> text "escape" <+> text [e] +> {-scalarExpr d (Escape v e) = +> scalarExpr d v <+> text "escape" <+> text [e] -> valueExpr d (UEscape v e) = -> valueExpr d v <+> text "uescape" <+> text [e] +> scalarExpr d (UEscape v e) = +> scalarExpr d v <+> text "uescape" <+> text [e]-} -> valueExpr d (Collate v c) = -> valueExpr d v <+> text "collate" <+> names c +> scalarExpr d (Collate v c) = +> scalarExpr d v <+> text "collate" <+> names c -> valueExpr _ (NextValueFor ns) = +> scalarExpr _ (NextValueFor ns) = > text "next value for" <+> names ns -> valueExpr d (VEComment cmt v) = -> vcat $ map comment cmt ++ [valueExpr d v] - -> doubleUpQuotes :: String -> String -> doubleUpQuotes [] = [] -> doubleUpQuotes ('\'':cs) = '\'':'\'':doubleUpQuotes cs -> doubleUpQuotes (c:cs) = c:doubleUpQuotes cs - -> doubleUpDoubleQuotes :: String -> String -> doubleUpDoubleQuotes [] = [] -> doubleUpDoubleQuotes ('"':cs) = '"':'"':doubleUpDoubleQuotes cs -> doubleUpDoubleQuotes (c:cs) = c:doubleUpDoubleQuotes cs +> scalarExpr d (VEComment cmt v) = +> vcat $ map comment cmt ++ [scalarExpr d v] +> scalarExpr _ (OdbcLiteral t s) = +> text "{" <> lt t <+> quotes (text s) <> text "}" +> where +> lt OLDate = text "d" +> lt OLTime = text "t" +> lt OLTimestamp = text "ts" +> scalarExpr d (OdbcFunc e) = +> text "{fn" <+> scalarExpr d e <> text "}" > unname :: Name -> String -> unname (QName n) = "\"" ++ doubleUpDoubleQuotes n ++ "\"" -> unname (UQName n) = "U&\"" ++ doubleUpDoubleQuotes n ++ "\"" -> unname (Name n) = n -> unname (DQName s e n) = s ++ n ++ e +> unname (Name Nothing n) = n +> unname (Name (Just (s,e)) n) = +> s ++ n ++ e > unnames :: [Name] -> String > unnames ns = intercalate "." $ map unname ns > name :: Name -> Doc -> name (QName n) = doubleQuotes $ text $ doubleUpDoubleQuotes n -> name (UQName n) = -> text "U&" <> doubleQuotes (text $ doubleUpDoubleQuotes n) -> name (Name n) = text n -> name (DQName s e n) = text s <> text n <> text e +> name (Name Nothing n) = text n +> name (Name (Just (s,e)) n) = text s <> text n <> text e > names :: [Name] -> Doc > names ns = hcat $ punctuate (text ".") $ map name ns @@ -328,21 +328,21 @@ > Distinct -> text "distinct" > ,nest 7 $ sep [selectList dia sl] > ,from dia fr -> ,maybeValueExpr dia "where" wh +> ,maybeScalarExpr dia "where" wh > ,grpBy dia gb -> ,maybeValueExpr dia "having" hv +> ,maybeScalarExpr dia "having" hv > ,orderBy dia od -> ,me (\e -> text "offset" <+> valueExpr dia e <+> text "rows") off +> ,me (\e -> text "offset" <+> scalarExpr dia e <+> text "rows") off > ,fetchFirst > ] > where > fetchFirst = -> me (\e -> if dia == MySQL -> then text "limit" <+> valueExpr dia e -> else text "fetch first" <+> valueExpr dia e +> me (\e -> if diSyntaxFlavour dia == MySQL +> then text "limit" <+> scalarExpr dia e +> else text "fetch first" <+> scalarExpr dia e > <+> text "rows only") fe -> queryExpr dia (CombineQueryExpr q1 ct d c q2) = +> queryExpr dia (QueryExprSetOp q1 ct d c q2) = > sep [queryExpr dia q1 > ,text (case ct of > Union -> "union" @@ -364,7 +364,7 @@ > ,queryExpr d qe] > queryExpr d (Values vs) = > text "values" -> <+> nest 7 (commaSep (map (parens . commaSep . map (valueExpr d)) vs)) +> <+> nest 7 (commaSep (map (parens . commaSep . map (scalarExpr d)) vs)) > queryExpr _ (Table t) = text "table" <+> names t > queryExpr d (QEComment cmt v) = > vcat $ map comment cmt ++ [queryExpr d v] @@ -375,10 +375,10 @@ > text "as" <+> name nm > <+> me (parens . commaSep . map name) cols -> selectList :: Dialect -> [(ValueExpr,Maybe Name)] -> Doc +> selectList :: Dialect -> [(ScalarExpr,Maybe Name)] -> Doc > selectList d is = commaSep $ map si is > where -> si (e,al) = valueExpr d e <+> me als al +> si (e,al) = scalarExpr d e <+> me als al > als al = text "as" <+> name al > from :: Dialect -> [TableRef] -> Doc @@ -390,7 +390,7 @@ > tr (TRSimple t) = names t > tr (TRLateral t) = text "lateral" <+> tr t > tr (TRFunction f as) = -> names f <> parens (commaSep $ map (valueExpr d) as) +> names f <> parens (commaSep $ map (scalarExpr d) as) > tr (TRAlias t a) = sep [tr t, alias a] > tr (TRParens t) = parens $ tr t > tr (TRQueryExpr q) = parens $ queryExpr d q @@ -399,6 +399,7 @@ > ,if b then text "natural" else empty > ,joinText jt <+> tr t1 > ,joinCond jc] +> tr (TROdbc t) = text "{oj" <+> tr t <+> text "}" > joinText jt = > sep [case jt of > JInner -> text "inner" @@ -407,22 +408,22 @@ > JFull -> text "full" > JCross -> text "cross" > ,text "join"] -> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr d e +> joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr d e > joinCond (Just (JoinUsing es)) = > text "using" <+> parens (commaSep $ map name es) > joinCond Nothing = empty -> maybeValueExpr :: Dialect -> String -> Maybe ValueExpr -> Doc -> maybeValueExpr d k = me +> maybeScalarExpr :: Dialect -> String -> Maybe ScalarExpr -> Doc +> maybeScalarExpr d k = me > (\e -> sep [text k -> ,nest (length k + 1) $ valueExpr d e]) +> ,nest (length k + 1) $ scalarExpr d e]) > grpBy :: Dialect -> [GroupingExpr] -> Doc > grpBy _ [] = empty > grpBy d gs = sep [text "group by" > ,nest 9 $ commaSep $ map ge gs] > where -> ge (SimpleGroup e) = valueExpr d e +> ge (SimpleGroup e) = scalarExpr d e > ge (GroupingParens g) = parens (commaSep $ map ge g) > ge (Cube es) = text "cube" <> parens (commaSep $ map ge es) > ge (Rollup es) = text "rollup" <> parens (commaSep $ map ge es) @@ -434,7 +435,7 @@ > ,nest 9 $ commaSep $ map f os] > where > f (SortSpec e d n) = -> valueExpr dia e +> scalarExpr dia e > <+> (case d of > Asc -> text "asc" > Desc -> text "desc" @@ -444,6 +445,361 @@ > NullsFirst -> text "nulls" <+> text "first" > NullsLast -> text "nulls" <+> text "last") += statements + +> statement :: Dialect -> Statement -> Doc + + +== ddl + +> statement _ (CreateSchema nm) = +> text "create" <+> text "schema" <+> names nm + +> statement d (CreateTable nm cds) = +> text "create" <+> text "table" <+> names nm +> <+> parens (commaSep $ map cd cds) +> where +> cd (TableConstraintDef n con) = +> maybe empty (\s -> text "constraint" <+> names s) n +> <+> tableConstraint d con +> cd (TableColumnDef cd') = columnDef d cd' + +> statement d (AlterTable t act) = +> texts ["alter","table"] <+> names t +> <+> alterTableAction d act + +> statement _ (DropSchema nm db) = +> text "drop" <+> text "schema" <+> names nm <+> dropBehav db + +> statement d (CreateDomain nm ty def cs) = +> text "create" <+> text "domain" <+> names nm +> <+> typeName ty +> <+> maybe empty (\def' -> text "default" <+> scalarExpr d def') def +> <+> sep (map con cs) +> where +> con (cn, e) = +> maybe empty (\cn' -> text "constraint" <+> names cn') cn +> <+> text "check" <> parens (scalarExpr d e) + +> statement d (AlterDomain nm act) = +> texts ["alter","domain"] +> <+> names nm +> <+> a act +> where +> a (ADSetDefault v) = texts ["set","default"] <+> scalarExpr d v +> a (ADDropDefault) = texts ["drop","default"] +> a (ADAddConstraint cnm e) = +> text "add" +> <+> maybe empty (\cnm' -> text "constraint" <+> names cnm') cnm +> <+> text "check" <> parens (scalarExpr d e) +> a (ADDropConstraint cnm) = texts ["drop", "constraint"] +> <+> names cnm + + +> statement _ (DropDomain nm db) = +> text "drop" <+> text "domain" <+> names nm <+> dropBehav db + +> statement _ (CreateSequence nm sgos) = +> texts ["create","sequence"] <+> names nm +> <+> sep (map sequenceGeneratorOption sgos) + +> statement _ (AlterSequence nm sgos) = +> texts ["alter","sequence"] <+> names nm +> <+> sep (map sequenceGeneratorOption sgos) + +> statement _ (DropSequence nm db) = +> text "drop" <+> text "sequence" <+> names nm <+> dropBehav db + + +> statement d (CreateAssertion nm ex) = +> texts ["create","assertion"] <+> names nm +> <+> text "check" <+> parens (scalarExpr d ex) + +> statement _ (DropAssertion nm db) = +> text "drop" <+> text "assertion" <+> names nm <+> dropBehav db + +== dml + +> statement d (SelectStatement q) = queryExpr d q + +> statement d (Delete t a w) = +> text "delete" <+> text "from" +> <+> names t <+> maybe empty (\x -> text "as" <+> name x) a +> <+> maybeScalarExpr d "where" w + +> statement _ (Truncate t ir) = +> text "truncate" <+> text "table" <+> names t +> <+> case ir of +> DefaultIdentityRestart -> empty +> ContinueIdentity -> text "continue" <+> text "identity" +> RestartIdentity -> text "restart" <+> text "identity" + +> statement d (Insert t cs s) = +> text "insert" <+> text "into" <+> names t +> <+> maybe empty (\cs' -> parens (commaSep $ map name cs')) cs +> <+> case s of +> DefaultInsertValues -> text "default" <+> text "values" +> InsertQuery q -> queryExpr d q + +> statement d (Update t a sts whr) = +> text "update" <+> names t +> <+> maybe empty (\x -> text "as" <+> name x) a +> <+> text "set" <+> commaSep (map sc sts) +> <+> maybeScalarExpr d "where" whr +> where +> sc (Set tg v) = names tg <+> text "=" <+> scalarExpr d v +> sc (SetMultiple ts vs) = parens (commaSep $ map names ts) <+> text "=" +> <+> parens (commaSep $ map (scalarExpr d) vs) + +> statement _ (DropTable n b) = +> text "drop" <+> text "table" <+> names n <+> dropBehav b + +> statement d (CreateView r nm al q co) = +> text "create" <+> (if r then text "recursive" else empty) +> <+> text "view" <+> names nm +> <+> (maybe empty (\al' -> parens $ commaSep $ map name al')) al +> <+> text "as" +> <+> queryExpr d q +> <+> case co of +> Nothing -> empty +> Just DefaultCheckOption -> texts ["with", "check", "option"] +> Just CascadedCheckOption -> texts ["with", "cascaded", "check", "option"] +> Just LocalCheckOption -> texts ["with", "local", "check", "option"] + +> statement _ (DropView n b) = +> text "drop" <+> text "view" <+> names n <+> dropBehav b + + +== transactions + +> statement _ StartTransaction = +> texts ["start", "transaction"] + +> statement _ (Savepoint nm) = +> text "savepoint" <+> name nm + +> statement _ (ReleaseSavepoint nm) = +> texts ["release", "savepoint"] <+> name nm + +> statement _ Commit = +> text "commit" + +> statement _ (Rollback mn) = +> text "rollback" +> <+> maybe empty (\n -> texts ["to","savepoint"] <+> name n) mn + +== access control + +> statement _ (GrantPrivilege pas po rs go) = +> text "grant" <+> commaSep (map privAct pas) +> <+> text "on" <+> privObj po +> <+> text "to" <+> commaSep (map name rs) +> <+> grantOpt go +> where +> grantOpt WithGrantOption = texts ["with","grant","option"] +> grantOpt WithoutGrantOption = empty + +> statement _ (GrantRole rs trs ao) = +> text "grant" <+> commaSep (map name rs) +> <+> text "to" <+> commaSep (map name trs) +> <+> adminOpt ao +> where +> adminOpt WithAdminOption = texts ["with","admin","option"] +> adminOpt WithoutAdminOption = empty + +> statement _ (CreateRole nm) = +> texts ["create","role"] <+> name nm + +> statement _ (DropRole nm) = +> texts ["drop","role"] <+> name nm + +> statement _ (RevokePrivilege go pas po rs db) = +> text "revoke" +> <+> grantOptFor go +> <+> commaSep (map privAct pas) +> <+> text "on" <+> privObj po +> <+> text "from" <+> commaSep (map name rs) +> <+> dropBehav db +> where +> grantOptFor GrantOptionFor = texts ["grant","option","for"] +> grantOptFor NoGrantOptionFor = empty + +> statement _ (RevokeRole ao rs trs db) = +> text "revoke" +> <+> adminOptFor ao +> <+> commaSep (map name rs) +> <+> text "from" <+> commaSep (map name trs) +> <+> dropBehav db +> where +> adminOptFor AdminOptionFor = texts ["admin","option","for"] +> adminOptFor NoAdminOptionFor = empty + + +> statement _ (StatementComment cs) = vcat $ map comment cs + + +== sessions + + +== extras + +> dropBehav :: DropBehaviour -> Doc +> dropBehav DefaultDropBehaviour = empty +> dropBehav Cascade = text "cascade" +> dropBehav Restrict = text "restrict" + + +> columnDef :: Dialect -> ColumnDef -> Doc +> columnDef d (ColumnDef n t mdef cons) = +> name n <+> typeName t +> <+> case mdef of +> Nothing -> empty +> Just (DefaultClause def) -> +> text "default" <+> scalarExpr d def +> Just (GenerationClause e) -> +> texts ["generated","always","as"] <+> parens (scalarExpr d e) +> Just (IdentityColumnSpec w o) -> +> text "generated" +> <+> (case w of +> GeneratedAlways -> text "always" +> GeneratedByDefault -> text "by" <+> text "default") +> <+> text "as" <+> text "identity" +> <+> (case o of +> [] -> empty +> os -> parens (sep $ map sequenceGeneratorOption os)) +> <+> sep (map cdef cons) +> where +> cdef (ColConstraintDef cnm con) = +> maybe empty (\s -> text "constraint" <+> names s) cnm +> <+> pcon con +> pcon ColNotNullConstraint = texts ["not","null"] +> pcon ColUniqueConstraint = text "unique" +> pcon ColPrimaryKeyConstraint = texts ["primary","key"] +> pcon (ColCheckConstraint v) = text "check" <+> parens (scalarExpr d v) +> pcon (ColReferencesConstraint tb c m u del) = +> text "references" +> <+> names tb +> <+> maybe empty (\c' -> parens (name c')) c +> <+> refMatch m +> <+> refAct "update" u +> <+> refAct "delete" del + +> sequenceGeneratorOption :: SequenceGeneratorOption -> Doc +> sequenceGeneratorOption (SGODataType t) = +> text "as" <+> typeName t +> sequenceGeneratorOption (SGORestart mi) = +> text "restart" <+> maybe empty (\mi' -> texts ["with", show mi']) mi +> sequenceGeneratorOption (SGOStartWith i) = texts ["start", "with", show i] +> sequenceGeneratorOption (SGOIncrementBy i) = texts ["increment", "by", show i] +> sequenceGeneratorOption (SGOMaxValue i) = texts ["maxvalue", show i] +> sequenceGeneratorOption SGONoMaxValue = texts ["no", "maxvalue"] +> sequenceGeneratorOption (SGOMinValue i) = texts ["minvalue", show i] +> sequenceGeneratorOption SGONoMinValue = texts ["no", "minvalue"] +> sequenceGeneratorOption SGOCycle = text "cycle" +> sequenceGeneratorOption SGONoCycle = text "no cycle" + +> refMatch :: ReferenceMatch -> Doc +> refMatch m = case m of +> DefaultReferenceMatch -> empty +> MatchFull -> texts ["match", "full"] +> MatchPartial -> texts ["match","partial"] +> MatchSimple -> texts ["match", "simple"] + +> refAct :: String -> ReferentialAction -> Doc +> refAct t a = case a of +> DefaultReferentialAction -> empty +> RefCascade -> texts ["on", t, "cascade"] +> RefSetNull -> texts ["on", t, "set", "null"] +> RefSetDefault -> texts ["on", t, "set", "default"] +> RefRestrict -> texts ["on", t, "restrict"] +> RefNoAction -> texts ["on", t, "no", "action"] + +> alterTableAction :: Dialect -> AlterTableAction -> Doc +> alterTableAction d (AddColumnDef cd) = +> texts ["add", "column"] <+> columnDef d cd + +> alterTableAction d (AlterColumnSetDefault n v) = +> texts ["alter", "column"] +> <+> name n +> <+> texts ["set","default"] <+> scalarExpr d v +> alterTableAction _ (AlterColumnDropDefault n) = +> texts ["alter", "column"] +> <+> name n +> <+> texts ["drop","default"] + +> alterTableAction _ (AlterColumnSetNotNull n) = +> texts ["alter", "column"] +> <+> name n +> <+> texts ["set","not","null"] + +> alterTableAction _ (AlterColumnDropNotNull n) = +> texts ["alter", "column"] +> <+> name n +> <+> texts ["drop","not","null"] + +> alterTableAction _ (AlterColumnSetDataType n t) = +> texts ["alter", "column"] +> <+> name n +> <+> texts ["set","data","Type"] +> <+> typeName t + +> alterTableAction _ (DropColumn n b) = +> texts ["drop", "column"] +> <+> name n +> <+> dropBehav b + +> alterTableAction d (AddTableConstraintDef n con) = +> text "add" +> <+> maybe empty (\s -> text "constraint" <+> names s) n +> <+> tableConstraint d con + +> alterTableAction _ (DropTableConstraintDef n b) = +> texts ["drop", "constraint"] +> <+> names n +> <+> dropBehav b + + +> tableConstraint :: Dialect -> TableConstraint -> Doc +> tableConstraint _ (TableUniqueConstraint ns) = +> text "unique" <+> parens (commaSep $ map name ns) +> tableConstraint _ (TablePrimaryKeyConstraint ns) = +> texts ["primary","key"] <+> parens (commaSep $ map name ns) +> tableConstraint _ (TableReferencesConstraint cs t tcs m u del) = +> texts ["foreign", "key"] +> <+> parens (commaSep $ map name cs) +> <+> text "references" +> <+> names t +> <+> maybe empty (\c' -> parens (commaSep $ map name c')) tcs +> <+> refMatch m +> <+> refAct "update" u +> <+> refAct "delete" del +> tableConstraint d (TableCheckConstraint v) = text "check" <+> parens (scalarExpr d v) + + +> privAct :: PrivilegeAction -> Doc +> privAct PrivAll = texts ["all","privileges"] +> privAct (PrivSelect cs) = text "select" <+> maybeColList cs +> privAct (PrivInsert cs) = text "insert" <+> maybeColList cs +> privAct (PrivUpdate cs) = text "update" <+> maybeColList cs +> privAct (PrivReferences cs) = text "references" <+> maybeColList cs +> privAct PrivDelete = text "delete" +> privAct PrivUsage = text "usage" +> privAct PrivTrigger = text "trigger" +> privAct PrivExecute = text "execute" + +> maybeColList :: [Name] -> Doc +> maybeColList cs = +> if null cs +> then empty +> else parens (commaSep $ map name cs) + +> privObj :: PrivilegeObject -> Doc +> privObj (PrivTable nm) = names nm +> privObj (PrivDomain nm) = text "domain" <+> names nm +> privObj (PrivType nm) = text "type" <+> names nm +> privObj (PrivSequence nm) = text "sequence" <+> names nm +> privObj (PrivFunction nm) = texts ["specific", "function"] <+> names nm + = utils > commaSep :: [Doc] -> Doc @@ -454,3 +810,6 @@ > comment :: Comment -> Doc > comment (BlockComment str) = text "/*" <+> text str <+> text "*/" + +> texts :: [String] -> Doc +> texts ts = sep $ map text ts diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -1,12 +1,13 @@ -> -- | The AST for SQL queries. +> -- | The AST for SQL. > {-# LANGUAGE DeriveDataTypeable #-} > module Language.SQL.SimpleSQL.Syntax -> (-- * Value expressions -> ValueExpr(..) +> (-- * Scalar expressions +> ScalarExpr(..) > ,Name(..) > ,TypeName(..) > ,IntervalTypeField(..) +> ,Sign(..) > ,PrecMultiplier(..) > ,PrecUnits(..) > ,SetQuantifier(..) @@ -19,10 +20,11 @@ > ,Frame(..) > ,FrameRows(..) > ,FramePos(..) +> ,OdbcLiteralType(..) > -- * Query expressions > ,QueryExpr(..) > ,makeSelect -> ,CombineOp(..) +> ,SetOperatorName(..) > ,Corresponding(..) > ,Alias(..) > ,GroupingExpr(..) @@ -30,18 +32,49 @@ > ,TableRef(..) > ,JoinType(..) > ,JoinCondition(..) -> -- * dialect -> ,Dialect(..) -> -- * comment +> -- * Statements +> ,Statement(..) +> ,DropBehaviour(..) +> ,IdentityRestart(..) +> ,InsertSource(..) +> ,SetClause(..) +> ,TableElement(..) +> ,ColumnDef(..) +> ,DefaultClause(..) +> ,IdentityWhen(..) +> ,SequenceGeneratorOption(..) +> ,ColConstraintDef(..) +> ,ColConstraint(..) +> ,TableConstraint(..) +> ,ReferenceMatch(..) +> ,ReferentialAction(..) +> ,AlterTableAction(..) +> ,CheckOption(..) +> ,AlterDomainAction(..) +> ,AdminOption(..) +> ,GrantOption(..) +> ,PrivilegeObject(..) +> ,PrivilegeAction(..) +> ,AdminOptionFor(..) +> ,GrantOptionFor(..) +> -- * Dialects +> ,Dialect(allowOdbc) +> ,ansi2011 +> ,mysql +> ,postgres +> ,oracle +> ,sqlserver +> -- * Comment > ,Comment(..) > ) where > import Data.Data +> import Language.SQL.SimpleSQL.Dialect > -- | Represents a value expression. This is used for the expressions > -- in select lists. It is also used for expressions in where, group > -- by, having, order by and so on. -> data ValueExpr +> data ScalarExpr > = -- | a numeric literal optional decimal point, e+- > -- integral exponent, e.g > -- @@ -57,37 +90,68 @@ > -- > -- * 12.34e-6 > NumLit String -> -- | string literal, currently only basic strings between -> -- single quotes with a single quote escaped using '' -> | StringLit String +> -- | string literal, with the start and end quote +> -- e.g. 'test' -> StringLit "'" "'" "test" +> | StringLit String String String > -- | text of interval literal, units of interval precision, > -- e.g. interval 3 days (3) > | IntervalLit -> {ilSign :: Maybe Bool -- ^ true if + used, false if - used +> {ilSign :: Maybe Sign -- ^ if + or - used > ,ilLiteral :: String -- ^ literal text > ,ilFrom :: IntervalTypeField > ,ilTo :: Maybe IntervalTypeField > } + +> -- | prefix 'typed literal', e.g. int '42' +> | TypedLit TypeName String + > -- | identifier with parts separated by dots > | Iden [Name] > -- | star, as in select *, t.*, count(*) > | Star + +> | Parameter -- ^ Represents a ? in a parameterized query +> | PositionalArg Int -- ^ Represents an e.g. $1 in a parameterized query +> | HostParameter String (Maybe String) -- ^ represents a host +> -- parameter, e.g. :a. The +> -- Maybe String is for the +> -- indicator, e.g. :var +> -- indicator :nl + + +> -- | Infix binary operators. This is used for symbol operators +> -- (a + b), keyword operators (a and b) and multiple keyword +> -- operators (a is similar to b) +> | BinOp ScalarExpr [Name] ScalarExpr +> -- | Prefix unary operators. This is used for symbol +> -- operators, keyword operators and multiple keyword operators. +> | PrefixOp [Name] ScalarExpr +> -- | Postfix unary operators. This is used for symbol +> -- operators, keyword operators and multiple keyword operators. +> | PostfixOp [Name] ScalarExpr +> -- | Used for ternary, mixfix and other non orthodox +> -- operators. Currently used for row constructors, and for +> -- between. +> | SpecialOp [Name] [ScalarExpr] + > -- | function application (anything that looks like c style > -- function application syntactically) -> | App [Name] [ValueExpr] +> | App [Name] [ScalarExpr] + + > -- | aggregate application, which adds distinct or all, and > -- order by, to regular function application > | AggregateApp > {aggName :: [Name] -- ^ aggregate function name > ,aggDistinct :: SetQuantifier -- ^ distinct -> ,aggArgs :: [ValueExpr]-- ^ args +> ,aggArgs :: [ScalarExpr]-- ^ args > ,aggOrderBy :: [SortSpec] -- ^ order by -> ,aggFilter :: Maybe ValueExpr -- ^ filter +> ,aggFilter :: Maybe ScalarExpr -- ^ filter > } > -- | aggregates with within group > | AggregateAppGroup > {aggName :: [Name] -- ^ aggregate function name -> ,aggArgs :: [ValueExpr] -- ^ args +> ,aggArgs :: [ScalarExpr] -- ^ args > ,aggGroup :: [SortSpec] -- ^ within group > } > -- | window application, which adds over (partition by a order @@ -95,83 +159,78 @@ > -- not currently supported > | WindowApp > {wnName :: [Name] -- ^ window function name -> ,wnArgs :: [ValueExpr] -- ^ args -> ,wnPartition :: [ValueExpr] -- ^ partition by +> ,wnArgs :: [ScalarExpr] -- ^ args +> ,wnPartition :: [ScalarExpr] -- ^ partition by > ,wnOrderBy :: [SortSpec] -- ^ order by > ,wnFrame :: Maybe Frame -- ^ frame clause > } -> -- | Infix binary operators. This is used for symbol operators -> -- (a + b), keyword operators (a and b) and multiple keyword -> -- operators (a is similar to b) -> | BinOp ValueExpr [Name] ValueExpr -> -- | Prefix unary operators. This is used for symbol -> -- operators, keyword operators and multiple keyword operators. -> | PrefixOp [Name] ValueExpr -> -- | Postfix unary operators. This is used for symbol -> -- operators, keyword operators and multiple keyword operators. -> | PostfixOp [Name] ValueExpr -> -- | Used for ternary, mixfix and other non orthodox -> -- operators. Currently used for row constructors, and for -> -- between. -> | SpecialOp [Name] [ValueExpr] + > -- | Used for the operators which look like functions > -- except the arguments are separated by keywords instead > -- of commas. The maybe is for the first unnamed argument > -- if it is present, and the list is for the keyword argument > -- pairs. -> | SpecialOpK [Name] (Maybe ValueExpr) [(String,ValueExpr)] +> | SpecialOpK [Name] (Maybe ScalarExpr) [(String,ScalarExpr)] + +> -- | cast(a as typename) +> | Cast ScalarExpr TypeName + > -- | case expression. both flavours supported > | Case -> {caseTest :: Maybe ValueExpr -- ^ test value -> ,caseWhens :: [([ValueExpr],ValueExpr)] -- ^ when branches -> ,caseElse :: Maybe ValueExpr -- ^ else value +> {caseTest :: Maybe ScalarExpr -- ^ test value +> ,caseWhens :: [([ScalarExpr],ScalarExpr)] -- ^ when branches +> ,caseElse :: Maybe ScalarExpr -- ^ else value > } -> | Parens ValueExpr -> -- | cast(a as typename) -> | Cast ValueExpr TypeName -> -- | prefix 'typed literal', e.g. int '42' -> | TypedLit TypeName String -> -- | exists, all, any, some subqueries -> | SubQueryExpr SubQueryExprType QueryExpr + +> | Parens ScalarExpr + > -- | in list literal and in subquery, if the bool is false it > -- means not in was used ('a not in (1,2)') -> | In Bool ValueExpr InPredValue -> | Parameter -- ^ Represents a ? in a parameterized query -> | HostParameter String (Maybe String) -- ^ represents a host -> -- parameter, e.g. :a. The -> -- Maybe String is for the -> -- indicator, e.g. :var -> -- indicator :nl +> | In Bool ScalarExpr InPredValue + +> -- | exists, all, any, some subqueries +> | SubQueryExpr SubQueryExprType QueryExpr + > | QuantifiedComparison -> ValueExpr +> ScalarExpr > [Name] -- operator > CompPredQuantifier > QueryExpr -> | Match ValueExpr Bool -- true if unique + +> | Match ScalarExpr Bool -- true if unique > QueryExpr -> | Array ValueExpr [ValueExpr] -- ^ represents an array +> | Array ScalarExpr [ScalarExpr] -- ^ represents an array > -- access expression, or an array ctor > -- e.g. a[3]. The first -> -- valueExpr is the array, the +> -- scalarExpr is the array, the > -- second is the subscripts/ctor args > | ArrayCtor QueryExpr -- ^ this is used for the query expression version of array constructors, e.g. array(select * from t) -> | CSStringLit String String -> | Escape ValueExpr Char -> | UEscape ValueExpr Char -> | Collate ValueExpr [Name] -> | MultisetBinOp ValueExpr CombineOp SetQuantifier ValueExpr -> | MultisetCtor [ValueExpr] + +todo: special syntax for like, similar with escape - escape cannot go +in other places + +> -- | Escape ScalarExpr Char +> -- | UEscape ScalarExpr Char +> | Collate ScalarExpr [Name] +> | MultisetBinOp ScalarExpr SetOperatorName SetQuantifier ScalarExpr +> | MultisetCtor [ScalarExpr] > | MultisetQueryCtor QueryExpr > | NextValueFor [Name] -> | VEComment [Comment] ValueExpr +> | VEComment [Comment] ScalarExpr +> | OdbcLiteral OdbcLiteralType String +> -- ^ an odbc literal e.g. {d '2000-01-01'} +> | OdbcFunc ScalarExpr +> -- ^ an odbc function call e.g. {fn CHARACTER_LENGTH('test')} > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents an identifier name, which can be quoted or unquoted. -> data Name = Name String -> | QName String -> | UQName String -> | DQName String String String -> -- ^ dialect quoted name, the fields are start quote, end quote and the string itself, e.g. `something` is parsed to DQName "`" "`" "something, and $a$ test $a$ is parsed to DQName "$a$" "$a" " test " +> -- examples: +> -- +> -- * test -> Name Nothing "test" +> -- * "test" -> Name (Just "\"","\"") "test" +> -- * `something` -> Name (Just ("`","`") "something" +> -- * [ms] -> Name (Just ("[","]") "ms" +> data Name = Name (Maybe (String,String)) String > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents a type name, used in casts. @@ -192,21 +251,24 @@ > data IntervalTypeField = Itf String (Maybe (Integer, Maybe Integer)) > deriving (Eq,Show,Read,Data,Typeable) +> data Sign = Plus | Minus +> deriving (Eq,Show,Read,Data,Typeable) + > data PrecMultiplier = PrecK | PrecM | PrecG | PrecT | PrecP > deriving (Eq,Show,Read,Data,Typeable) > data PrecUnits = PrecCharacters > | PrecOctets > deriving (Eq,Show,Read,Data,Typeable) -> -- | Used for 'expr in (value expression list)', and 'expr in +> -- | Used for 'expr in (scalar expression list)', and 'expr in > -- (subquery)' syntax. -> data InPredValue = InList [ValueExpr] +> data InPredValue = InList [ScalarExpr] > | InQueryExpr QueryExpr > deriving (Eq,Show,Read,Data,Typeable) not sure if scalar subquery, exists and unique should be represented like this -> -- | A subquery in a value expression. +> -- | A subquery in a scalar expression. > data SubQueryExprType > = -- | exists (query expr) > SqExists @@ -223,7 +285,7 @@ > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents one field in an order by list. -> data SortSpec = SortSpec ValueExpr Direction NullsOrder +> data SortSpec = SortSpec ScalarExpr Direction NullsOrder > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents 'nulls first' or 'nulls last' in an order by clause. @@ -245,12 +307,21 @@ > -- | represents the start or end of a frame > data FramePos = UnboundedPreceding -> | Preceding ValueExpr +> | Preceding ScalarExpr > | Current -> | Following ValueExpr +> | Following ScalarExpr > | UnboundedFollowing > deriving (Eq,Show,Read,Data,Typeable) + +> -- | the type of an odbc literal (e.g. {d '2000-01-01'}), +> -- correpsonding to the letter after the opening { +> data OdbcLiteralType = OLDate +> | OLTime +> | OLTimestamp +> deriving (Eq,Show,Read,Data,Typeable) + + > -- | Represents a query expression, which can be: > -- > -- * a regular select; @@ -265,7 +336,7 @@ > data QueryExpr > = Select > {qeSetQuantifier :: SetQuantifier -> ,qeSelectList :: [(ValueExpr,Maybe Name)] +> ,qeSelectList :: [(ScalarExpr,Maybe Name)] > -- ^ the expressions and the column aliases TODO: consider breaking this up. The SQL grammar has @@ -275,16 +346,16 @@ This would make some things a bit cleaner? > ,qeFrom :: [TableRef] -> ,qeWhere :: Maybe ValueExpr +> ,qeWhere :: Maybe ScalarExpr > ,qeGroupBy :: [GroupingExpr] -> ,qeHaving :: Maybe ValueExpr +> ,qeHaving :: Maybe ScalarExpr > ,qeOrderBy :: [SortSpec] -> ,qeOffset :: Maybe ValueExpr -> ,qeFetchFirst :: Maybe ValueExpr +> ,qeOffset :: Maybe ScalarExpr +> ,qeFetchFirst :: Maybe ScalarExpr > } -> | CombineQueryExpr +> | QueryExprSetOp > {qe0 :: QueryExpr -> ,qeCombOp :: CombineOp +> ,qeCombOp :: SetOperatorName > ,qeSetQuantifier :: SetQuantifier > ,qeCorresponding :: Corresponding > ,qe1 :: QueryExpr @@ -293,7 +364,7 @@ > {qeWithRecursive :: Bool > ,qeViews :: [(Alias,QueryExpr)] > ,qeQueryExpression :: QueryExpr} -> | Values [[ValueExpr]] +> | Values [[ScalarExpr]] > | Table [Name] > | QEComment [Comment] QueryExpr > deriving (Eq,Show,Read,Data,Typeable) @@ -335,7 +406,7 @@ > -- | The direction for a column in order by. > data Direction = DirDefault | Asc | Desc deriving (Eq,Show,Read,Data,Typeable) > -- | Query expression set operators. -> data CombineOp = Union | Except | Intersect deriving (Eq,Show,Read,Data,Typeable) +> data SetOperatorName = Union | Except | Intersect deriving (Eq,Show,Read,Data,Typeable) > -- | Corresponding, an option for the set operators. > data Corresponding = Corresponding | Respectively deriving (Eq,Show,Read,Data,Typeable) @@ -345,7 +416,7 @@ > | Cube [GroupingExpr] > | Rollup [GroupingExpr] > | GroupingSets [GroupingExpr] -> | SimpleGroup ValueExpr +> | SimpleGroup ScalarExpr > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents a entry in the csv of tables in the from clause. @@ -360,9 +431,11 @@ > -- | from (query expr) > | TRQueryExpr QueryExpr > -- | from function(args) -> | TRFunction [Name] [ValueExpr] +> | TRFunction [Name] [ScalarExpr] > -- | from lateral t > | TRLateral TableRef +> -- | ODBC {oj t1 left outer join t2 on expr} syntax +> | TROdbc TableRef > deriving (Eq,Show,Read,Data,Typeable) > -- | Represents an alias for a table valued expression, used in with @@ -376,19 +449,289 @@ > deriving (Eq,Show,Read,Data,Typeable) > -- | The join condition. -> data JoinCondition = JoinOn ValueExpr -- ^ on expr +> data JoinCondition = JoinOn ScalarExpr -- ^ on expr > | JoinUsing [Name] -- ^ using (column list) > deriving (Eq,Show,Read,Data,Typeable) +--------------------------- -> -- | Used to set the dialect used for parsing and pretty printing, -> -- very unfinished at the moment. -> data Dialect = SQL2011 -> | MySQL -> deriving (Eq,Show,Read,Data,Typeable) +> data Statement = +> -- ddl +> CreateSchema [Name] +> | DropSchema [Name] DropBehaviour +> | CreateTable [Name] [TableElement] +> | AlterTable [Name] AlterTableAction +> | DropTable [Name] DropBehaviour +> | CreateView Bool [Name] (Maybe [Name]) +> QueryExpr (Maybe CheckOption) +> | DropView [Name] DropBehaviour +> | CreateDomain [Name] TypeName (Maybe ScalarExpr) +> [(Maybe [Name], ScalarExpr)] +> | AlterDomain [Name] AlterDomainAction +> | DropDomain [Name] DropBehaviour +> -- probably won't do character sets, collations +> -- and translations because I think they are too far from +> -- reality +> {- | CreateCharacterSet +> | DropCharacterSet +> | CreateCollation +> | DropCollation +> | CreateTranslation +> | DropTranslation -} +> | CreateAssertion [Name] ScalarExpr +> | DropAssertion [Name] DropBehaviour +> {- | CreateTrigger +> | DropTrigger +> | CreateType +> | AlterType +> | DropType +> -- routine stuff? TODO +> | CreateCast +> | DropCast +> | CreateOrdering +> | DropOrdering -} +> -- transforms +> | CreateSequence [Name] [SequenceGeneratorOption] +> | AlterSequence [Name] [SequenceGeneratorOption] +> | DropSequence [Name] DropBehaviour +> -- dml +> | SelectStatement QueryExpr +> {- | DeclareCursor +> | OpenCursor +> | FetchCursor +> | CloseCursor +> | SelectInto -} +> -- | DeletePositioned +> | Delete [Name] (Maybe Name) (Maybe ScalarExpr) +> | Truncate [Name] IdentityRestart +> | Insert [Name] (Maybe [Name]) InsertSource +> -- | Merge +> | Update [Name] (Maybe Name) [SetClause] (Maybe ScalarExpr) +> {- | TemporaryTable +> | FreeLocator +> | HoldLocator -} +> -- access control +> | GrantPrivilege [PrivilegeAction] PrivilegeObject [Name] GrantOption +> | GrantRole [Name] [Name] AdminOption +> | CreateRole Name +> | DropRole Name +> | RevokePrivilege GrantOptionFor [PrivilegeAction] PrivilegeObject +> [Name] DropBehaviour +> | RevokeRole AdminOptionFor [Name] [Name] DropBehaviour +> -- transaction management +> | StartTransaction +> -- | SetTransaction +> -- | SetContraints +> | Savepoint Name +> | ReleaseSavepoint Name +> | Commit +> | Rollback (Maybe Name) +> -- session +> {- | SetSessionCharacteristics +> | SetSessionAuthorization +> | SetRole +> | SetTimeZone +> | SetCatalog +> | SetSchema +> | SetNames +> | SetTransform +> | SetCollation -} +> | StatementComment [Comment] +> deriving (Eq,Show,Read,Data,Typeable) -> -- | Comment. Useful when generating SQL code programmatically. +> data DropBehaviour = +> Restrict +> | Cascade +> | DefaultDropBehaviour +> deriving (Eq,Show,Read,Data,Typeable) + +> data IdentityRestart = +> ContinueIdentity +> | RestartIdentity +> | DefaultIdentityRestart +> deriving (Eq,Show,Read,Data,Typeable) + +> data InsertSource = +> InsertQuery QueryExpr +> | DefaultInsertValues +> deriving (Eq,Show,Read,Data,Typeable) + +> data SetClause = +> Set [Name] ScalarExpr +> | SetMultiple [[Name]] [ScalarExpr] +> deriving (Eq,Show,Read,Data,Typeable) + +> data TableElement = +> TableColumnDef ColumnDef +> | TableConstraintDef (Maybe [Name]) TableConstraint +> deriving (Eq,Show,Read,Data,Typeable) + +> data ColumnDef = ColumnDef Name TypeName +> (Maybe DefaultClause) +> [ColConstraintDef] +> -- (Maybe CollateClause) +> deriving (Eq,Show,Read,Data,Typeable) + +> data ColConstraintDef = +> ColConstraintDef (Maybe [Name]) ColConstraint +> -- (Maybe [ConstraintCharacteristics]) +> deriving (Eq,Show,Read,Data,Typeable) + +> data ColConstraint = +> ColNotNullConstraint +> | ColUniqueConstraint +> | ColPrimaryKeyConstraint +> | ColReferencesConstraint [Name] (Maybe Name) +> ReferenceMatch +> ReferentialAction +> ReferentialAction +> | ColCheckConstraint ScalarExpr +> deriving (Eq,Show,Read,Data,Typeable) + +> data TableConstraint = +> TableUniqueConstraint [Name] +> | TablePrimaryKeyConstraint [Name] +> | TableReferencesConstraint [Name] [Name] (Maybe [Name]) +> ReferenceMatch +> ReferentialAction +> ReferentialAction +> | TableCheckConstraint ScalarExpr +> deriving (Eq,Show,Read,Data,Typeable) + + +> data ReferenceMatch = +> DefaultReferenceMatch +> | MatchFull +> | MatchPartial +> | MatchSimple +> deriving (Eq,Show,Read,Data,Typeable) + +> data ReferentialAction = +> DefaultReferentialAction +> | RefCascade +> | RefSetNull +> | RefSetDefault +> | RefRestrict +> | RefNoAction +> deriving (Eq,Show,Read,Data,Typeable) + +> data AlterTableAction = +> AddColumnDef ColumnDef +> | AlterColumnSetDefault Name ScalarExpr +> | AlterColumnDropDefault Name +> | AlterColumnSetNotNull Name +> | AlterColumnDropNotNull Name +> | AlterColumnSetDataType Name TypeName +> {- | AlterColumnAlterIdentity +> | AlterColumnDropIdentity +> | AlterColumnDropColumnGeneration-} +> | DropColumn Name DropBehaviour +> | AddTableConstraintDef (Maybe [Name]) TableConstraint +> -- | AlterTableConstraintDef +> | DropTableConstraintDef [Name] DropBehaviour +> deriving (Eq,Show,Read,Data,Typeable) + +> {-data ConstraintCharacteristics = +> ConstraintCharacteristics +> ConstraintCheckTime +> Deferrable +> ConstraintEnforcement +> deriving (Eq,Show,Read,Data,Typeable) + +> data ConstraintCheckTime = +> DefaultConstraintCheckTime +> | InitiallyDeferred +> | InitiallyImmeditate +> deriving (Eq,Show,Read,Data,Typeable) + +> data Deferrable = +> DefaultDefferable +> | Deferrable +> | NotDeferrable +> deriving (Eq,Show,Read,Data,Typeable) + +> data ConstraintEnforcement = +> DefaultConstraintEnforcement +> | Enforced +> | NotEnforced +> deriving (Eq,Show,Read,Data,Typeable) -} + +> {-data TableConstraintDef +> deriving (Eq,Show,Read,Data,Typeable) -} + +> data DefaultClause = +> DefaultClause ScalarExpr +> | IdentityColumnSpec IdentityWhen [SequenceGeneratorOption] +> | GenerationClause ScalarExpr +> deriving (Eq,Show,Read,Data,Typeable) + +> data IdentityWhen = +> GeneratedAlways +> | GeneratedByDefault +> deriving (Eq,Show,Read,Data,Typeable) + +> data SequenceGeneratorOption = +> SGODataType TypeName +> | SGOStartWith Integer +> | SGORestart (Maybe Integer) +> | SGOIncrementBy Integer +> | SGOMaxValue Integer +> | SGONoMaxValue +> | SGOMinValue Integer +> | SGONoMinValue +> | SGOCycle +> | SGONoCycle +> deriving (Eq,Show,Read,Data,Typeable) + +> data CheckOption = +> DefaultCheckOption +> | CascadedCheckOption +> | LocalCheckOption +> deriving (Eq,Show,Read,Data,Typeable) + +> data AlterDomainAction = +> ADSetDefault ScalarExpr +> | ADDropDefault +> | ADAddConstraint (Maybe [Name]) ScalarExpr +> | ADDropConstraint [Name] +> deriving (Eq,Show,Read,Data,Typeable) + + +> data AdminOption = WithAdminOption | WithoutAdminOption +> deriving (Eq,Show,Read,Data,Typeable) + +> data GrantOption = WithGrantOption | WithoutGrantOption +> deriving (Eq,Show,Read,Data,Typeable) + +> data AdminOptionFor = AdminOptionFor | NoAdminOptionFor +> deriving (Eq,Show,Read,Data,Typeable) + +> data GrantOptionFor = GrantOptionFor | NoGrantOptionFor +> deriving (Eq,Show,Read,Data,Typeable) + +> data PrivilegeObject = +> PrivTable [Name] +> | PrivDomain [Name] +> | PrivType [Name] +> | PrivSequence [Name] +> | PrivFunction [Name] +> deriving (Eq,Show,Read,Data,Typeable) + +> data PrivilegeAction = +> PrivAll +> | PrivSelect [Name] +> | PrivDelete +> | PrivInsert [Name] +> | PrivUpdate [Name] +> | PrivReferences [Name] +> | PrivUsage +> | PrivTrigger +> | PrivExecute +> deriving (Eq,Show,Read,Data,Typeable) + +> -- | Comment. Useful when generating SQL code programmatically. The +> -- parser doesn't produce these. > data Comment = BlockComment String > deriving (Eq,Show,Read,Data,Typeable) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,11 +1,49 @@ -If you need help updating to a new version of simple-sql-parser, -please email jakewheatmail@gmail.com or use the github bug tracker, -https://github.com/JakeWheat/simple-sql-parser/issues. +0.5.0 + update to work with ghc 8.6.5, also tested with 8.4.4 and 8.2.1 + rename some of the modules Lexer -> Lex, Parser -> Parse + add a separate lexer to simplify code and speed up parsing + replace SqlIndent with new tool, SimpleSqlParserTool (amazing + name) which can indent, and parse and lex. + experiments in new approach to dealing with fixities with separate + pass after parsing + dml :add support for insert, update, delete and truncate + ddl: add limited support for create schema, plus drop schema + create, alter and drop table with defaults and constraints + create, alter and drop for domain, view, sequence + create and drop for assertion + access control: simple create and drop for role + simple grant and revoke + limited support for transaction management: start transation, + rollback, commit, savepoint + fix the precendence of operators which was following the weird + postgresql 9.4 and earlier precendences instead of the standard + refactor the syntax for names, identifiers and strings slightly + refactor the dialect support, add some support for postgresql + syntax + change parsing of identifiers and strings to not unescape the + identifier or string text during parsing + add some explicit parse failures for probably ambiguous text + */ without /* (outside quoted identifier, string) will fail + .,e,E following a number without whitespace always fails + three symbols together fails explicitly, instead of trying to + lex and giving a less good error at parse time (applies to | + and : in postgres dialect) + fix parsing of functions whose name is a keyword (e.g. abs) + add basic support for parsing odbc syntax ({d 'literals'} {fn + app(something)} and {oj t1 left outer join ... } + rename ValueExpr -> ScalarExpr (I think scalar expression is + slightly less incorrect) + rename CombineQueryExpr to QueryExprSetOp and CombineOp to SetOperatorName + use explicit data type for sign in interval literals + add comments to statement syntax (aimed at codegen) + add support for oracle type size units 'char' and 'byte', example: varchar2(55 byte) + updated the makefile to use cabal v2 commands + fix for parsing window functions with keyword names 0.4.4 tested with ghc 8.2.1 and 8.4.3 0.4.3 tested with ghc 8.0.2 and 8.2.1 -0.4.1 (commit TBD) +0.4.1 (commit c156c5c34e91e1f7ef449d2c1ea14e282104fd90) tested with ghc 7.4.2, 7.6.3, 7.8.4,7.10.0.20150123 simple demonstration of how dialects could be handled internally add ability to add comments to syntax tree to help with generating diff --git a/simple-sql-parser.cabal b/simple-sql-parser.cabal --- a/simple-sql-parser.cabal +++ b/simple-sql-parser.cabal @@ -1,9 +1,13 @@ name: simple-sql-parser -version: 0.4.4 -synopsis: A parser for SQL queries +version: 0.5.0 +synopsis: A parser for SQL. -description: A parser for SQL queries. Parses most SQL:2011 - queries. Please see the homepage for more information +description: + + A parser for SQL. Parses most SQL:2011 + queries, non-query DML, DDL, access control and + transaction management syntax. Please see the + homepage for more information . homepage: http://jakewheat.github.io/simple-sql-parser/latest @@ -11,7 +15,7 @@ license-file: LICENSE author: Jake Wheat maintainer: jakewheatmail@gmail.com -copyright: Copyright Jake Wheat 2013, 2014 +copyright: Copyright Jake Wheat 2013, 2014, 2015 category: Database,Language build-type: Simple extra-source-files: README,LICENSE,changelog @@ -22,16 +26,18 @@ type: git location: https://github.com/JakeWheat/simple-sql-parser.git -Flag sqlindent - Description: Build SQLIndent exe +Flag parserexe + Description: Build SimpleSqlParserTool exe Default: False library exposed-modules: Language.SQL.SimpleSQL.Pretty, - Language.SQL.SimpleSQL.Parser, + Language.SQL.SimpleSQL.Parse, + Language.SQL.SimpleSQL.Lex, Language.SQL.SimpleSQL.Syntax Other-Modules: Language.SQL.SimpleSQL.Errors, - Language.SQL.SimpleSQL.Combinators + Language.SQL.SimpleSQL.Combinators, + Language.SQL.SimpleSQL.Dialect other-extensions: TupleSections build-depends: base >=4 && <5, parsec >=3.1 && <3.2, @@ -50,51 +56,82 @@ parsec >=3.1 && <3.2, mtl >=2.1 && <2.3, pretty >= 1.1 && < 1.2, - - HUnit >= 1.2 && < 1.7, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4 + tasty >= 1.1 && < 1.3, + tasty-hunit >= 0.9 && < 0.11 Other-Modules: Language.SQL.SimpleSQL.Pretty, - Language.SQL.SimpleSQL.Parser, + Language.SQL.SimpleSQL.Parse, + Language.SQL.SimpleSQL.Lex, Language.SQL.SimpleSQL.Syntax, Language.SQL.SimpleSQL.Errors, - Language.SQL.SimpleSQL.Combinators + Language.SQL.SimpleSQL.Combinators, + Language.SQL.SimpleSQL.Dialect - --Language.SQL.SimpleSQL.ErrorMessages, + Language.SQL.SimpleSQL.ErrorMessages, Language.SQL.SimpleSQL.FullQueries, Language.SQL.SimpleSQL.GroupBy, Language.SQL.SimpleSQL.MySQL, Language.SQL.SimpleSQL.Postgres, + Language.SQL.SimpleSQL.Odbc, + Language.SQL.SimpleSQL.Oracle, Language.SQL.SimpleSQL.QueryExprComponents, Language.SQL.SimpleSQL.QueryExprs, - Language.SQL.SimpleSQL.SQL2011, + Language.SQL.SimpleSQL.SQL2011Queries, + Language.SQL.SimpleSQL.SQL2011AccessControl, + Language.SQL.SimpleSQL.SQL2011Bits, + Language.SQL.SimpleSQL.SQL2011DataManipulation, + Language.SQL.SimpleSQL.SQL2011Schema, Language.SQL.SimpleSQL.TableRefs, Language.SQL.SimpleSQL.TestTypes, Language.SQL.SimpleSQL.Tests, Language.SQL.SimpleSQL.Tpch, - Language.SQL.SimpleSQL.ValueExprs + Language.SQL.SimpleSQL.ScalarExprs, + Language.SQL.SimpleSQL.LexerTests other-extensions: TupleSections,DeriveDataTypeable default-language: Haskell2010 + ghc-options: -Wall -threaded + +executable SimpleSqlParserTool + main-is: SimpleSqlParserTool.lhs + hs-source-dirs: .,tools + Build-Depends: base >=4 && <5, + parsec >=3.1 && <3.2, + mtl >=2.1 && <2.3, + pretty >= 1.1 && < 1.2, + pretty-show >= 1.6 && < 1.10 + other-extensions: TupleSections,DeriveDataTypeable + default-language: Haskell2010 ghc-options: -Wall + Other-Modules: Language.SQL.SimpleSQL.Combinators + Language.SQL.SimpleSQL.Dialect + Language.SQL.SimpleSQL.Errors + Language.SQL.SimpleSQL.Lex + Language.SQL.SimpleSQL.Parse + Language.SQL.SimpleSQL.Pretty + Language.SQL.SimpleSQL.Syntax -executable SQLIndent - main-is: SQLIndent.lhs + if flag(parserexe) + buildable: True + else + buildable: False + +executable Fixity + main-is: Fixity.lhs hs-source-dirs: .,tools - Other-Modules: Language.SQL.SimpleSQL.Pretty, - Language.SQL.SimpleSQL.Parser, - Language.SQL.SimpleSQL.Syntax, - Language.SQL.SimpleSQL.Errors, - Language.SQL.SimpleSQL.Combinators Build-Depends: base >=4 && <5, parsec >=3.1 && <3.2, mtl >=2.1 && <2.3, - pretty >= 1.1 && < 1.2 + pretty >= 1.1 && < 1.2, + pretty-show >= 1.6 && < 1.10, + tasty >= 1.1 && < 1.3, + tasty-hunit >= 0.9 && < 0.11 + other-extensions: TupleSections,DeriveDataTypeable default-language: Haskell2010 ghc-options: -Wall - if flag(sqlindent) + if flag(parserexe) buildable: True else buildable: False + diff --git a/tools/Fixity.lhs b/tools/Fixity.lhs new file mode 100644 --- /dev/null +++ b/tools/Fixity.lhs @@ -0,0 +1,702 @@ + += Fixity fixups + +The point of this code is to be able to take a table of fixity +information for unary and binary operators, then adjust an ast to +match these fixities. The standard way of handling this is handling +fixities at the parsing stage. + +For the SQL parser, this is difficult because there is lots of weird +syntax for operators (such as prefix and postfix multiple keyword +operators, between, etc.). + +An alterative idea which is used in some places is to parse the tree +regarding all the operators to have the same precedence and left +associativity, then correct the fixity in a pass over the ast after +parsing. Would also like to use this to fix the fixity for the join +trees, and set operations, after parsing them. TODO: anything else? + + +Approach + +Really not sure how to get this correct. So: lots of testing + +Basic testing idea: create an expression, then write down manually how +the expression should parse with correct fixity. Can write down the +expression in concrete syntax, and the correct fixity version using +parens. + +Then can parse the expression, fix it, parse the fixed expression, +remove the parens and compare them to make sure they are equal. + +Second layer of testing. For each source expression parsed, run it +through a generator which will generate every version of that tree by +choosing all possibilities of fixities on a token by token basis. This +will ensure the fixity fixer is robust. An alternative approach is to +guarantee the parser will produce trees where all the fixities are +known (e.g. unary operators always bind tighter than binary, binary +are all left associative, prefix unary bind tighter than postfix. This +way, the fix code can make some assumptions and have less code. We +will stick with the full general version which is more robust. + +Another testing approach is to parse the tree with our non fixity +respecting parser then fix it, and also parse it with a fixity +respecting expression parser, and check the results are the same. This +is difficult with the parsec build expression parser which doesn't +handle nested unary operators, so have to find or write another build +expression parser. We can test the fixer with simple operators (single +symbol prefix, postfix and binary ops) and then use it on the complex +sql ast trees. + +Can also try to generate trees ala quickcheck/smallcheck, then check +them with the fixer and the build expression parser. + +generate a tree: + +start with a term +then roll dice: + add a prefix + add a postfix + do nothing +then roll dice + add a binary op + for the second arg, recurse the algo + + +algorithm: + +consider possible cases: +binop with two binops args +binop with prefix on left +binop with postfix on right +postfix with prefix inside +prefix with postfix inside +postfix with binop inside +prefix with binop inside + +write a function to deal with each case and try to compose + +Tasks: + +write unary op tests: on each other, and with binary ops +figure out how to generate trees +do the step one tests (write the fixity with parens) +check out parsers expression parser +see if can generate trees using smallcheck +try to test these trees against expression parser + otherwise, generate tree, generate variations, check fixity always +produces same result + + + + +todo: + +1. more tests for unary operators with each other +2. moving unary operators inside and outside binary operators: + have to think about how this will work in general case +3. ways to generate lots of tests and check them + -> what about creating a parser which parses to a list of all possible + parses with different fixities for each operator it sees? +4. ambiguous fixity cases - need position annotation to do these nicely +5. real sql: how to work with a variety of ast nodes +6. plug into simple-sql-parser +7. refactor the simple-sql-parser parsing code +8. simple-sql-parser todo for sqream: add other dml, dialects, + procedural? +9. testing idea: write big expressions with explicit parens everywhere + parse this + remove the parens + pretty print, then parse and fixfixity to see if same + then generate all variations of tree as if the fixities are different + and then fixfixity to check it restores the original + + +write fixity tests +write code to do the fixing +add error cases: put it in the either monad to report these + +check the descend +then: move to real sql + different abstract representations of binops, etc. + what is the best way to deal with this? typeclass? conversion to and + from a generic tree? + + + + + +can the binops be fixed on their own (precedence and assocativity) +and then the prefix and postfix ops in separate passes + +what about a pass which puts the tree into canonical form: +all left associative, all unary ops tight as possible? +then the fixer can be easier? + + + + + +> {-# LANGUAGE DeriveDataTypeable,TupleSections #-} +> import Data.Data + +> import Text.Parsec.String (Parser) +> import Text.Parsec (try) +> import Text.Parsec.Char +> import Text.Parsec.Combinator +> import Text.Parsec (parse,ParseError) +> import Control.Applicative ((<|>),many) -- ((<**>),(<$>),(<*), (*>),(<*>), (<$), (<|>), many) +> --import qualified Text.Parsec.String.Expr as E +> import Control.Monad +> --import Data.List (intercalate) +> import Data.Maybe () +> --import qualified Test.HUnit as H +> --import FunctionsAndTypesForParsing +> import Debug.Trace +> import Text.Show.Pretty +> import Data.List +> import Control.Applicative + +> import qualified Test.Tasty as T +> import qualified Test.Tasty.HUnit as H + + +> data Expr = BinOp Expr String Expr +> | PrefOp String Expr +> | PostOp String Expr +> | Iden String +> | Lit String +> | App String [Expr] +> | Parens Expr +> deriving (Eq,Show,Data,Typeable) + +-------- + +quick parser + +> parensValue :: Parser Expr +> parensValue = Parens <$> parens valueExpr + +> idenApp :: Parser Expr +> idenApp = try $ do +> i <- identifier +> guard (i `notElem` ["not", "and", "or", "is"]) +> choice [do +> args <- parens (commaSep valueExpr) +> return $ App i args +> ,return $ Iden i +> ] + +> lit :: Parser Expr +> lit = stringLit <|> numLit +> where +> stringLit = Lit <$> lexeme (char '\'' *> manyTill anyChar (char '\'')) +> numLit = do +> x <- lexeme (many1 digit) +> let y :: Integer +> y = read x +> return $ Lit $ show y + +> prefOp :: Parser Expr +> prefOp = sym <|> kw +> where +> sym = do +> let prefOps = ["+", "-"] +> s <- choice $ map symbol prefOps +> v <- term +> return $ PrefOp s v +> kw = do +> let prefOps = ["not"] +> i <- identifier +> guard (i `elem` prefOps) +> v <- term +> return $ PrefOp i v + +> postOp :: Parser (Expr -> Expr) +> postOp = try $ do +> let kws = ["is null"] +> kwsp = map (\a -> try $ do +> let x :: [String] +> x = words a +> mapM_ keyword_ x +> return $ PostOp a +> ) kws +> choice kwsp + +> binOp :: Parser (Expr -> Expr -> Expr) +> binOp = symbolBinOp <|> kwBinOp +> where +> symbolBinOp = do +> let binOps = ["+", "-", "*", "/"] +> s <- choice $ map symbol binOps +> return $ \a b -> BinOp a s b +> kwBinOp = do +> let kwBinOps = ["and", "or"] +> i <- identifier +> guard (i `elem` kwBinOps) +> return $ \a b -> BinOp a i b + +> term :: Parser Expr +> term = (parensValue +> <|> try prefOp +> <|> idenApp +> <|> lit) +> postOp + +> -- () :: Parser a -> Parser (a -> a) -> Parser a +> -- p q = p <**> option id q + +> () :: Parser a -> Parser (a -> a) -> Parser a +> p q = foldr ($) <$> p <*> (reverse <$> many q) + +> valueExpr :: Parser Expr +> valueExpr = chainl1 term binOp + + +> parens :: Parser a -> Parser a +> parens = between openParen closeParen + +> openParen :: Parser Char +> openParen = lexeme $ char '(' +> closeParen :: Parser Char +> closeParen = lexeme $ char ')' + +> symbol :: String -> Parser String +> symbol s = try $ lexeme $ do +> u <- many1 (oneOf "<>=+-^%/*!|") +> guard (s == u) +> return s + +> identifier :: Parser String +> identifier = lexeme ((:) <$> firstChar <*> many nonFirstChar) +> where +> firstChar = letter <|> char '_' +> nonFirstChar = digit <|> firstChar + +> keyword :: String -> Parser String +> keyword k = try $ do +> i <- identifier +> guard (i == k) +> return k + +> keyword_ :: String -> Parser () +> keyword_ = void . keyword + +> whitespace :: Parser () +> whitespace = +> choice [simpleWhitespace *> whitespace +> ,lineComment *> whitespace +> ,blockComment *> whitespace +> ,return ()] +> where +> lineComment = try (string "--") +> *> manyTill anyChar (void (char '\n') <|> eof) +> blockComment = try (string "/*") +> *> manyTill anyChar (try $ string "*/") +> simpleWhitespace = void $ many1 (oneOf " \t\n") +> lexeme :: Parser a -> Parser a +> lexeme p = p <* whitespace +> comma :: Parser Char +> comma = lexeme $ char ',' + +> commaSep :: Parser a -> Parser [a] +> commaSep = (`sepBy` comma) + +> parseExpr :: String -> Either ParseError Expr +> parseExpr = parse (whitespace *> valueExpr <* eof) "" + +-------------- + +> data Assoc = AssocLeft | AssocRight | AssocNone deriving (Eq,Show) + +> type Fixities = [(String, (Int, Assoc))] + +> fixFixity :: Fixities -> Expr -> Expr +> fixFixity fixities = fixBinOpPrecedence . fixBinOpAssociativity . fixNestedPrefPostPrec +> where +> fixBinOpAssociativity e = case e of +> BinOp a op b -> +> let a' = fixBinOpAssociativity a +> b' = fixBinOpAssociativity b +> def = BinOp a' op b' +> in case (a',b') of +> -- both +> -- a1 op1 a2 op b1 op2 b2 +> (BinOp a1 op1 a2 +> ,BinOp b1 op2 b2) +> | Just (_p,opa) <- lookupFixity op +> , Just (_p,op1a) <- lookupFixity op1 +> , Just (_p,op2a) <- lookupFixity op2 +> -> case (opa, op1a, op2a) of +> (AssocRight, AssocRight, AssocRight) -> +> BinOp a1 op1 (BinOp a2 op (BinOp b1 op2 b2)) +> (AssocLeft, AssocLeft, AssocLeft) -> +> BinOp (BinOp (BinOp a1 op1 a2) op b1) op2 b2 +> --todo: other cases +> _ -> def +> -- just left side +> (BinOp a1 op1 a2, _) +> -- a1 op1 a2 op b' +> | Just (_p,opa) <- lookupFixity op +> , Just (_p,op1a) <- lookupFixity op1 +> -> case (opa, op1a) of +> (AssocRight, AssocRight) -> +> BinOp a1 op1 (BinOp a2 op b') +> (AssocLeft, AssocLeft) -> +> BinOp (BinOp a1 op1 a2) op b' +> _ -> def + +> -- just right side +> (_, BinOp b1 op2 b2) +> -- e op b1 op2 b2 +> | Just (_p,opa) <- lookupFixity op +> , Just (_p,op2a) <- lookupFixity op2 +> -> case (opa, op2a) of +> (AssocRight, AssocRight) -> +> BinOp a' op (BinOp b1 op2 b2) +> (AssocLeft, AssocLeft) -> +> BinOp (BinOp a' op b1) op2 b2 +> _ -> def +> _ -> def +> _ -> e + +> fixBinOpPrecedence e = case e of +> BinOp a op b -> +> let a' = fixBinOpPrecedence a +> b' = fixBinOpPrecedence b +> def = BinOp a' op b' +> in case (a',b') of +> -- both +> -- a1 op1 a2 op b1 op2 b2 +> -- all equal +> -- p > or < p1 == p2 +> -- p == p1 < or > p2 +> (BinOp a1 op1 a2 +> ,BinOp b1 op2 b2) +> | Just (p,_opa) <- lookupFixity op +> , Just (p1,_op1a) <- lookupFixity op1 +> , Just (p2,_op2a) <- lookupFixity op2 +> -> case () of +> -- _ | trace ("both prec " ++ show (p,p1,p2)) False -> undefined +> _ | p == p1 && p1 == p2 -> def +> _ | p > p1 && p1 == p2 -> BinOp a1 op1 b' +> _ | p < p1 && p1 == p2 -> BinOp (BinOp a1 op1 a2) op b' +> _ | p == p1 && p2 > p1 -> BinOp a' op (BinOp b1 op2 b2) +> _ | p == p1 && p2 < p1 -> def -- todo +> _ | otherwise -> def +> -- just left side +> (BinOp a1 op1 a2, _) +> -- a1 op1 a2 op b' +> | Just (p,_opa) <- lookupFixity op +> , Just (p1,_op1a) <- lookupFixity op1 +> -> case () of +> -- _ | trace ("left prec " ++ show (p,p1)) False -> undefined +> _ | p < p1 -> {-trace "b1" $ -}BinOp (BinOp a1 op1 a2) op b' +> | p > p1 -> {-trace "b2" $ -}BinOp a1 op1 (BinOp a2 op b') +> | otherwise -> def + +> -- just right side +> (_, BinOp b1 op2 b2) +> -- a' op b1 op2 b2 +> | Just (p,_opa) <- lookupFixity op +> , Just (p2,_op1a) <- lookupFixity op2 +> -> case () of +> -- _ | trace ("right prec " ++ show (p,p2)) False -> undefined +> _ | p > p2 -> {-trace "b1" $ -}BinOp (BinOp a' op b1) op2 b2 +> | p < p2 -> {-trace "b2" $ -}BinOp a' op (BinOp b1 op2 b2) +> | otherwise -> {-trace "def" $ -} def +> _ -> def +> _ -> e + +> fixNestedPrefPostPrec e = case e of +> PrefOp op a -> +> let a' = fixNestedPrefPostPrec a +> in case a' of +> PostOp op1 b | Just (p,_) <- lookupFixity op +> , Just (p1,_) <- lookupFixity op1 +> , p > p1 -> PostOp op1 (PrefOp op b) +> _ -> PrefOp op a' +> PostOp op a -> +> let a' = fixNestedPrefPostPrec a +> in case a' of +> PrefOp op1 b | Just (p,_) <- lookupFixity op +> , Just (p1,_) <- lookupFixity op1 +> , p > p1 -> PrefOp op1 (PostOp op b) +> _ -> PostOp op a' +> _ -> e + + + +> lookupFixity :: String -> Maybe (Int,Assoc) +> lookupFixity s = maybe (trace ("didn't find " ++ s ++ "\n" ++ ppShow fixities) Nothing) +> Just $ lookup s fixities + + +> sqlFixity :: [(String, (Int, Assoc))] +> sqlFixity = [(".", (13, AssocLeft)) +> ,("[]", (12, AssocNone)) + +unary + - +todo: split the fixity table into prefix, binary and postfix + +todo: don't have explicit precedence numbers in the table?? + +> ,("^", (10, AssocNone))] +> ++ m ["*", "/", "%"] (9, AssocLeft) +> ++ m ["+","-"] (8, AssocLeft) +> ++ m ["<", ">", "=", "<=", ">=", "<>"] (4, AssocNone) +> ++ [("is null", (3, AssocNone)) +> ,("not", (2, AssocRight)) +> ,("and", (1, AssocLeft)) +> ,("or", (0, AssocLeft))] + +> where +> m l a = map (,a) l + +------- + +some simple parser tests + +> data Test = Group String [Test] +> | ParserTest String Expr +> | FixityTest Fixities Expr Expr + +> parserTests :: Test +> parserTests = Group "parserTests" $ map (uncurry ParserTest) $ +> [("a", Iden "a") +> ,("'test'", Lit "test") +> ,("34", Lit "34") +> ,("f()", App "f" []) +> ,("f(3)", App "f" [Lit "3"]) +> ,("(7)", Parens (Lit "7")) +> ,("a + 3", BinOp (Iden "a") "+" (Lit "3")) +> ,("1 + 2 + 3", BinOp (BinOp (Lit "1") "+" (Lit "2")) "+" (Lit "3")) + +> ,("a or b", BinOp (Iden "a") "or" (Iden "b")) +> ,("-1", PrefOp "-" (Lit "1")) +> ,("not a", PrefOp "not" (Iden "a")) +> ,("not not a", PrefOp "not" (PrefOp "not" (Iden "a"))) +> ,("a is null", PostOp "is null" (Iden "a")) +> ,("a is null is null", PostOp "is null" (PostOp "is null" (Iden "a"))) +> ,("-a+3", BinOp (PrefOp "-" (Iden "a")) "+" (Lit "3")) +> ,("a is null and b is null", BinOp (PostOp "is null" (Iden "a")) +> "and" +> (PostOp "is null" (Iden "b"))) +> ] + +> makeParserTest :: String -> Expr -> T.TestTree +> makeParserTest s e = H.testCase s $ do +> let a = parseExpr s +> if (Right e == a) +> then putStrLn $ s ++ " OK" +> else putStrLn $ "bad parse " ++ s ++ " " ++ show a + +------ + +fixity checks + +test cases: + + +> fixityTests :: Test +> fixityTests = Group "fixityTests" $ +> map (\(f,s,e) -> FixityTest f s e) $ +> [ + +2 bin ops wrong associativity left + null versions + +> (sqlFixity +> ,i "a" `plus` (i "b" `plus` i "c") +> ,(i "a" `plus` i "b") `plus` i "c") +> ,(sqlFixity +> ,(i "a" `plus` i "b") `plus` i "c" +> ,(i "a" `plus` i "b") `plus` i "c") + +2 bin ops wrong associativity right + +> ,(timesRight +> ,i "a" `times` (i "b" `times` i "c") +> ,i "a" `times` (i "b" `times` i "c")) +> ,(timesRight +> ,(i "a" `times` i "b") `times` i "c" +> ,i "a" `times` (i "b" `times` i "c")) + + +2 bin ops wrong precedence left + +> ,(sqlFixity +> ,i "a" `plus` (i "b" `times` i "c") +> ,i "a" `plus` (i "b" `times` i "c")) + +> ,(sqlFixity +> ,(i "a" `plus` i "b") `times` i "c" +> ,i "a" `plus` (i "b" `times` i "c")) + +2 bin ops wrong precedence right + +> ,(sqlFixity +> ,(i "a" `times` i "b") `plus` i "c" +> ,(i "a" `times` i "b") `plus` i "c") + +> ,(sqlFixity +> ,i "a" `times` (i "b" `plus` i "c") +> ,(i "a" `times` i "b") `plus` i "c") + +a + b * c + d +a * b + c * d + +check all variations + +> ] ++ +> (let t = (i "a" `plus` i "b") +> `times` +> (i "c" `plus` i "d") +> trs = generateTrees $ splitTree t +> in [(sqlFixity, x +> ,i "a" `plus` (i "b" `times` i "c") +> `plus` i "d") +> | x <- trs]) +> ++ +> (let t = (i "a" `times` i "b") +> `plus` +> (i "c" `times` i "d") +> trs = generateTrees $ splitTree t +> in [(sqlFixity, x +> ,(i "a" `times` i "b") +> `plus` +> (i "c" `times` i "d")) +> | x <- trs]) + + +> ++ [ + +prefix then postfix wrong precedence + +> ([("+", (9, AssocNone)) +> ,("is null", (3, AssocNone))] +> ,PrefOp "+" (PostOp "is null" (i "a")) +> ,PostOp "is null" (PrefOp "+" (i "a"))) + +> ,([("+", (9, AssocNone)) +> ,("is null", (3, AssocNone))] +> ,PostOp "is null" (PrefOp "+" (i "a")) +> ,PostOp "is null" (PrefOp "+" (i "a"))) + +> ,([("+", (3, AssocNone)) +> ,("is null", (9, AssocNone))] +> ,PrefOp "+" (PostOp "is null" (i "a")) +> ,PrefOp "+" (PostOp "is null" (i "a"))) + +> ,([("+", (3, AssocNone)) +> ,("is null", (9, AssocNone))] +> ,PostOp "is null" (PrefOp "+" (i "a")) +> ,PrefOp "+" (PostOp "is null" (i "a"))) + +3-way unary operator movement: +take a starting point and generate variations + +postfix on first arg of binop (cannot move) make sure precedence wants + it to move + +prefix on second arg of binop (cannot move) + +prefix on binop, precedence wrong +postfix on binop precedence wrong +prefix on first arg of binop, precedence wrong +postfix on second arg of binop, precedence wrong + +ambiguous fixity tests + +sanity check: parens stops rearrangement + +check nesting 1 + f(expr) + +> ] +> where +> plus a b = BinOp a "+" b +> times a b = BinOp a "*" b +> i a = Iden a +> timesRight = [("*", (9, AssocRight))] + +testCase + +> makeFixityTest :: Fixities -> Expr -> Expr -> T.TestTree +> makeFixityTest fs s e = H.testCase (show s) $ do +> let s' = fixFixity fs s +> H.assertEqual "" s' e +> {-if (s' == e) +> then putStrLn $ show s ++ " OK" +> else putStrLn $ "ERROR\nstart: " ++ show s ++ "\nfixed: " ++ show s' ++ "\nshould be: " ++ show e-} + +> tests :: Test +> tests = Group "Tests" [parserTests, fixityTests] + +> makeTest :: Test -> T.TestTree +> makeTest (Group n ts) = T.testGroup n $ map makeTest ts +> makeTest (ParserTest s e) = makeParserTest s e +> makeTest (FixityTest f s e) = makeFixityTest f s e + +-------- + + > tests :: T.TestTree + > tests = T.testGroup "Tests" $ map makeFixityTest fixityTests + +> main :: IO () +> main = T.defaultMain $ makeTest tests +> {-do +> mapM_ checkTest tests +> mapM_ checkFixity fixityTests +> let plus a b = BinOp a "+" b +> times a b = BinOp a "*" b +> i a = Iden a +> let t = (i "a" `plus` i "b") +> `times` +> (i "c" `plus` i "d") +> spl = splitTree t +> trs = generateTrees spl +> --putStrLn $ "\nSplit\n" +> --putStrLn $ ppShow (fst spl, length $ snd spl) +> --putStrLn $ show $ length trs +> --putStrLn $ "\nTrees\n" +> --putStrLn $ intercalate "\n" $ map show trs +> return ()-} + +generating trees + +1. tree -> list +val op val op val op ... +(has to be two lists? + +generate variations: +pick numbers from 0 to n - 1 (n is the number of ops) +choose the op at this position to be the root +recurse on the two sides + +> splitTree :: Expr -> ([Expr], [Expr->Expr->Expr]) +> splitTree (BinOp a op b) = let (x,y) = splitTree a +> (z,w) = splitTree b +> in (x++z, y++ [\a b -> BinOp a op b] ++ w) +> splitTree x = ([x],[]) + + + +> generateTrees :: ([Expr], [Expr->Expr->Expr]) -> [Expr] +> generateTrees (es,ops) | length es /= length ops + 1 = +> error $ "mismatch in lengths " ++ show (length es, length ops) +> ++"\n" ++ ppShow es ++ "\n" +> generateTrees ([a,b], [op]) = [op a b] +> generateTrees ([a], []) = [a] +> generateTrees (vs, ops) = +> let n = length ops +> in --trace ("generating " ++ show (length vs, n) ++ "trees\n") $ +> concat $ flip map [0..n-1] $ \m -> +> let (v1,v2) = splitAt (m + 1) vs +> (ops1,op':ops2) = splitAt m ops +> r = [op' t u | t <- generateTrees (v1,ops1) +> , u <- generateTrees (v2,ops2)] +> in -- trace ("generated " ++ show (length r) ++ " trees") +> r +> generateTrees ([],[]) = [] + + + diff --git a/tools/Language/SQL/SimpleSQL/ErrorMessages.lhs b/tools/Language/SQL/SimpleSQL/ErrorMessages.lhs new file mode 100644 --- /dev/null +++ b/tools/Language/SQL/SimpleSQL/ErrorMessages.lhs @@ -0,0 +1,150 @@ + +Want to work on the error messages. Ultimately, parsec won't give the +best error message for a parser combinator library in haskell. Should +check out the alternatives such as polyparse and uu-parsing. + +For now the plan is to try to get the best out of parsec. Skip heavy +work on this until the parser is more left factored? + +Ideas: + +1. generate large lists of invalid syntax +2. create table of the sql source and the error message +3. save these tables and compare from version to version. Want to + catch improvements and regressions and investigate. Have to do this + manually + += generating bad sql source + +take good sql statements or expressions. Convert them into sequences +of tokens - want to preserve the whitespace and comments perfectly +here. Then modify these lists by either adding a token, removing a +token, or modifying a token (including creating bad tokens of raw +strings which don't represent anything than can be tokenized. + +Now can see the error message for all of these bad strings. Probably +have to generate and prune this list manually in stages since there +will be too many. + +Contexts: + +another area to focus on is contexts: for instance, we have a set of +e.g. 1000 bad scalar expressions with error messages. Now can put +those bad scalar expressions into various contexts and see that the +error messages are still good. + +plan: + +1. create a list of all the value expression, with some variations for + each +2. manually create some error variations for each expression +3. create a renderer which will create a csv of the expressions and + the errors + this is to load as a spreadsheet to investigate more +4. create a renderer for the csv which will create a markdown file for + the website. this is to demonstrate the error messages in the + documentation + +Then create some contexts for all of these: inside another value +expression, or inside a query expression. Do the same: render and +review the error messages. + +Then, create some query expressions to focus on the non value +expression parts. + + +> module Language.SQL.SimpleSQL.ErrorMessages where + +> {-import Language.SQL.SimpleSQL.Parser +> import Data.List +> import Text.Groom + +> valueExpressions :: [String] +> valueExpressions = +> ["10.." +> ,"..10" +> ,"10e1e2" +> ,"10e--3" +> ,"1a" +> ,"1%" + +> ,"'b'ad'" +> ,"'bad" +> ,"bad'" + +> ,"interval '5' ay" +> ,"interval '5' day (4.4)" +> ,"interval '5' day (a)" +> ,"intervala '5' day" +> ,"interval 'x' day (3" +> ,"interval 'x' day 3)" + +> ,"1badiden" +> ,"$" +> ,"!" +> ,"*.a" + +> ,"??" +> ,"3?" +> ,"?a" + +> ,"row" +> ,"row 1,2" +> ,"row(1,2" +> ,"row 1,2)" +> ,"row(1 2)" + +> ,"f(" +> ,"f)" + +> ,"f(a" +> ,"f a)" +> ,"f(a b)" + +TODO: +case +operators + +> ,"a + (b + c" + +casts +subqueries: + whole set of parentheses use +in list +'keyword' functions +aggregates +window functions + + +> ] + +> queryExpressions :: [String] +> queryExpressions = +> map sl1 valueExpressions +> ++ map sl2 valueExpressions +> ++ map sl3 valueExpressions +> ++ +> ["select a from t inner jin u"] +> where +> sl1 x = "select " ++ x ++ " from t" +> sl2 x = "select " ++ x ++ ", y from t" +> sl3 x = "select " ++ x ++ " fom t" + +> valExprs :: [String] -> [(String,String)] +> valExprs = map parseOne +> where +> parseOne x = let p = parseValueExpr "" Nothing x +> in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p) + + +> queryExprs :: [String] -> [(String,String)] +> queryExprs = map parseOne +> where +> parseOne x = let p = parseQueryExpr "" Nothing x +> in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p) + + +> pExprs :: [String] -> [String] -> String +> pExprs x y = +> let l = valExprs x ++ queryExprs y +> in intercalate "\n\n\n\n" $ map (\(a,b) -> a ++ "\n" ++ b) l +> -} diff --git a/tools/Language/SQL/SimpleSQL/FullQueries.lhs b/tools/Language/SQL/SimpleSQL/FullQueries.lhs --- a/tools/Language/SQL/SimpleSQL/FullQueries.lhs +++ b/tools/Language/SQL/SimpleSQL/FullQueries.lhs @@ -8,11 +8,11 @@ > fullQueriesTests :: TestItem -> fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr SQL2011)) +> fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr ansi2011)) > [("select count(*) from t" > ,makeSelect -> {qeSelectList = [(App [Name "count"] [Star], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] +> {qeSelectList = [(App [Name Nothing "count"] [Star], Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] > } > ) @@ -23,17 +23,17 @@ > \ having count(1) > 5\n\ > \ order by s" > ,makeSelect -> {qeSelectList = [(Iden [Name "a"], Nothing) -> ,(App [Name "sum"] -> [BinOp (Iden [Name "c"]) -> [Name "+"] (Iden [Name "d"])] -> ,Just $ Name "s")] -> ,qeFrom = [TRSimple [Name "t"], TRSimple [Name "u"]] -> ,qeWhere = Just $ BinOp (Iden [Name "a"]) [Name ">"] (NumLit "5") -> ,qeGroupBy = [SimpleGroup $ Iden [Name "a"]] -> ,qeHaving = Just $ BinOp (App [Name "count"] [NumLit "1"]) -> [Name ">"] (NumLit "5") -> ,qeOrderBy = [SortSpec (Iden [Name "s"]) DirDefault NullsOrderDefault] +> {qeSelectList = [(Iden [Name Nothing "a"], Nothing) +> ,(App [Name Nothing "sum"] +> [BinOp (Iden [Name Nothing "c"]) +> [Name Nothing "+"] (Iden [Name Nothing "d"])] +> ,Just $ Name Nothing "s")] +> ,qeFrom = [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]] +> ,qeWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5") +> ,qeGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] +> ,qeHaving = Just $ BinOp (App [Name Nothing "count"] [NumLit "1"]) +> [Name Nothing ">"] (NumLit "5") +> ,qeOrderBy = [SortSpec (Iden [Name Nothing "s"]) DirDefault NullsOrderDefault] > } > ) > ] diff --git a/tools/Language/SQL/SimpleSQL/GroupBy.lhs b/tools/Language/SQL/SimpleSQL/GroupBy.lhs --- a/tools/Language/SQL/SimpleSQL/GroupBy.lhs +++ b/tools/Language/SQL/SimpleSQL/GroupBy.lhs @@ -15,21 +15,21 @@ > ] > simpleGroupBy :: TestItem -> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) +> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a,sum(b) from t group by a" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) -> ,(App [Name "sum"] [Iden [Name "b"]],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = [SimpleGroup $ Iden [Name "a"]] +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing) +> ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] +> ,qeGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] > }) > ,("select a,b,sum(c) from t group by a,b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) -> ,(Iden [Name "b"],Nothing) -> ,(App [Name "sum"] [Iden [Name "c"]],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = [SimpleGroup $ Iden [Name "a"] -> ,SimpleGroup $ Iden [Name "b"]] +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing) +> ,(Iden [Name Nothing "b"],Nothing) +> ,(App [Name Nothing "sum"] [Iden [Name Nothing "c"]],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] +> ,qeGroupBy = [SimpleGroup $ Iden [Name Nothing "a"] +> ,SimpleGroup $ Iden [Name Nothing "b"]] > }) > ] @@ -37,23 +37,23 @@ sure which sql version they were introduced, 1999 or 2003 I think). > newGroupBy :: TestItem -> newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) +> newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr ansi2011)) > [("select * from t group by ()", ms [GroupingParens []]) > ,("select * from t group by grouping sets ((), (a))" > ,ms [GroupingSets [GroupingParens [] -> ,GroupingParens [SimpleGroup $ Iden [Name "a"]]]]) +> ,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"]]]]) > ,("select * from t group by cube(a,b)" -> ,ms [Cube [SimpleGroup $ Iden [Name "a"], SimpleGroup $ Iden [Name "b"]]]) +> ,ms [Cube [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]]) > ,("select * from t group by rollup(a,b)" -> ,ms [Rollup [SimpleGroup $ Iden [Name "a"], SimpleGroup $ Iden [Name "b"]]]) +> ,ms [Rollup [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]]) > ] > where > ms g = makeSelect {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] +> ,qeFrom = [TRSimple [Name Nothing "t"]] > ,qeGroupBy = g} > randomGroupBy :: TestItem -> randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr SQL2011) +> randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011) > ["select * from t GROUP BY a" > ,"select * from t GROUP BY GROUPING SETS((a))" > ,"select * from t GROUP BY a,b,c" diff --git a/tools/Language/SQL/SimpleSQL/LexerTests.lhs b/tools/Language/SQL/SimpleSQL/LexerTests.lhs new file mode 100644 --- /dev/null +++ b/tools/Language/SQL/SimpleSQL/LexerTests.lhs @@ -0,0 +1,335 @@ + + +Test for the lexer + +> module Language.SQL.SimpleSQL.LexerTests (lexerTests) where + +> import Language.SQL.SimpleSQL.TestTypes +> import Language.SQL.SimpleSQL.Lex (Token(..),tokenListWillPrintAndLex) +> --import Debug.Trace +> --import Data.Char (isAlpha) +> import Data.List + +> lexerTests :: TestItem +> lexerTests = Group "lexerTests" $ +> [Group "lexer token tests" [ansiLexerTests +> ,postgresLexerTests +> ,sqlServerLexerTests +> ,oracleLexerTests +> ,mySqlLexerTests +> ,odbcLexerTests]] + +> ansiLexerTable :: [(String,[Token])] +> ansiLexerTable = +> -- single char symbols +> map (\s -> ([s],[Symbol [s]])) "+-^*/%~&|?<>[]=,;()" +> -- multi char symbols +> ++ map (\s -> (s,[Symbol s])) [">=","<=","!=","<>","||"] +> ++ (let idens = ["a", "_a", "test", "table", "Stuff", "STUFF"] +> -- simple identifiers +> in map (\i -> (i, [Identifier Nothing i])) idens +> ++ map (\i -> ("\"" ++ i ++ "\"", [Identifier (Just ("\"","\"")) i])) idens +> -- todo: in order to make lex . pretty id, need to +> -- preserve the case of the u +> ++ map (\i -> ("u&\"" ++ i ++ "\"", [Identifier (Just ("u&\"","\"")) i])) idens +> -- host param +> ++ map (\i -> (':':i, [PrefixedVariable ':' i])) idens +> ) +> -- quoted identifiers with embedded double quotes +> -- the lexer doesn't unescape the quotes +> ++ [("\"normal \"\" iden\"", [Identifier (Just ("\"","\"")) "normal \"\" iden"])] +> -- strings +> -- the lexer doesn't apply escapes at all +> ++ [("'string'", [SqlString "'" "'" "string"]) +> ,("'normal '' quote'", [SqlString "'" "'" "normal '' quote"]) +> ,("'normalendquote '''", [SqlString "'" "'" "normalendquote ''"]) +> ,("'\n'", [SqlString "'" "'" "\n"])] +> -- csstrings +> ++ map (\c -> (c ++ "'test'", [SqlString (c ++ "'") "'" "test"])) +> ["n", "N","b", "B","x", "X", "u&"] +> -- numbers +> ++ [("10", [SqlNumber "10"]) +> ,(".1", [SqlNumber ".1"]) +> ,("5e3", [SqlNumber "5e3"]) +> ,("5e+3", [SqlNumber "5e+3"]) +> ,("5e-3", [SqlNumber "5e-3"]) +> ,("10.2", [SqlNumber "10.2"]) +> ,("10.2e7", [SqlNumber "10.2e7"])] +> -- whitespace +> ++ concat [[([a],[Whitespace [a]]) +> ,([a,b], [Whitespace [a,b]])] +> | a <- " \n\t", b <- " \n\t"] +> -- line comment +> ++ map (\c -> (c, [LineComment c])) +> ["--", "-- ", "-- this is a comment", "-- line com\n"] +> -- block comment +> ++ map (\c -> (c, [BlockComment c])) +> ["/**/", "/* */","/* this is a comment */" +> ,"/* this *is/ a comment */" +> ] + +> ansiLexerTests :: TestItem +> ansiLexerTests = Group "ansiLexerTests" $ +> [Group "ansi lexer token tests" $ [LexTest ansi2011 s t | (s,t) <- ansiLexerTable] +> ,Group "ansi generated combination lexer tests" $ +> [ LexTest ansi2011 (s ++ s1) (t ++ t1) +> | (s,t) <- ansiLexerTable +> , (s1,t1) <- ansiLexerTable +> , tokenListWillPrintAndLex ansi2011 $ t ++ t1 + +> ] +> ,Group "ansiadhoclexertests" $ +> map (uncurry $ LexTest ansi2011) +> [("", []) +> ,("-- line com\nstuff", [LineComment "-- line com\n",Identifier Nothing "stuff"]) +> ] ++ +> [-- want to make sure this gives a parse error +> LexFails ansi2011 "*/" +> -- combinations of pipes: make sure they fail because they could be +> -- ambiguous and it is really unclear when they are or not, and +> -- what the result is even when they are not ambiguous +> ,LexFails ansi2011 "|||" +> ,LexFails ansi2011 "||||" +> ,LexFails ansi2011 "|||||" +> -- another user experience thing: make sure extra trailing +> -- number chars are rejected rather than attempting to parse +> -- if the user means to write something that is rejected by this code, +> -- then they can use whitespace to make it clear and then it will parse +> ,LexFails ansi2011 "12e3e4" +> ,LexFails ansi2011 "12e3e4" +> ,LexFails ansi2011 "12e3e4" +> ,LexFails ansi2011 "12e3.4" +> ,LexFails ansi2011 "12.4.5" +> ,LexFails ansi2011 "12.4e5.6" +> ,LexFails ansi2011 "12.4e5e7"] +> ] + +todo: lexing tests +do quickcheck testing: +can try to generate valid tokens then check they parse + +same as above: can also try to pair tokens, create an accurate + function to say which ones can appear adjacent, and test + +I think this plus the explicit lists of tokens like above which do +basic sanity + explicit edge casts will provide a high level of +assurance. + + + +> postgresLexerTable :: [(String,[Token])] +> postgresLexerTable = +> -- single char symbols +> map (\s -> ([s],[Symbol [s]])) "+-^*/%~&|?<>[]=,;():" +> -- multi char symbols +> ++ map (\s -> (s,[Symbol s])) [">=","<=","!=","<>","||", "::","..",":="] +> -- generic symbols + +> ++ (let idens = ["a", "_a", "test", "table", "Stuff", "STUFF"] +> -- simple identifiers +> in map (\i -> (i, [Identifier Nothing i])) idens +> ++ map (\i -> ("\"" ++ i ++ "\"", [Identifier (Just ("\"","\"")) i])) idens +> -- todo: in order to make lex . pretty id, need to +> -- preserve the case of the u +> ++ map (\i -> ("u&\"" ++ i ++ "\"", [Identifier (Just ("u&\"","\"")) i])) idens +> -- host param +> ++ map (\i -> (':':i, [PrefixedVariable ':' i])) idens +> ) +> -- positional var +> ++ [("$1", [PositionalArg 1])] +> -- quoted identifiers with embedded double quotes +> ++ [("\"normal \"\" iden\"", [Identifier (Just ("\"","\"")) "normal \"\" iden"])] +> -- strings +> ++ [("'string'", [SqlString "'" "'" "string"]) +> ,("'normal '' quote'", [SqlString "'" "'" "normal '' quote"]) +> ,("'normalendquote '''", [SqlString "'" "'" "normalendquote ''"]) +> ,("'\n'", [SqlString "'" "'" "\n"]) +> ,("E'\n'", [SqlString "E'" "'" "\n"]) +> ,("e'this '' quote'", [SqlString "e'" "'" "this '' quote"]) +> ,("e'this \\' quote'", [SqlString "e'" "'" "this \\' quote"]) +> ,("'not this \\' quote", [SqlString "'" "'" "not this \\" +> ,Whitespace " " +> ,Identifier Nothing "quote"]) +> ,("$$ string 1 $$", [SqlString "$$" "$$" " string 1 "]) +> ,("$$ string $ 2 $$", [SqlString "$$" "$$" " string $ 2 "]) +> ,("$a$ $$string 3$$ $a$", [SqlString "$a$" "$a$" " $$string 3$$ "]) +> ] +> -- csstrings +> ++ map (\c -> (c ++ "'test'", [SqlString (c ++ "'") "'" "test"])) +> ["n", "N","b", "B","x", "X", "u&", "e", "E"] +> -- numbers +> ++ [("10", [SqlNumber "10"]) +> ,(".1", [SqlNumber ".1"]) +> ,("5e3", [SqlNumber "5e3"]) +> ,("5e+3", [SqlNumber "5e+3"]) +> ,("5e-3", [SqlNumber "5e-3"]) +> ,("10.2", [SqlNumber "10.2"]) +> ,("10.2e7", [SqlNumber "10.2e7"])] +> -- whitespace +> ++ concat [[([a],[Whitespace [a]]) +> ,([a,b], [Whitespace [a,b]])] +> | a <- " \n\t", b <- " \n\t"] +> -- line comment +> ++ map (\c -> (c, [LineComment c])) +> ["--", "-- ", "-- this is a comment", "-- line com\n"] +> -- block comment +> ++ map (\c -> (c, [BlockComment c])) +> ["/**/", "/* */","/* this is a comment */" +> ,"/* this *is/ a comment */" +> ] + +An operator name is a sequence of up to NAMEDATALEN-1 (63 by default) characters from the following list: + ++ - * / < > = ~ ! @ # % ^ & | ` ? + +There are a few restrictions on operator names, however: +-- and /* cannot appear anywhere in an operator name, since they will be taken as the start of a comment. + +A multiple-character operator name cannot end in + or -, unless the name also contains at least one of these characters: + +~ ! @ # % ^ & | ` ? + +todo: 'negative' tests +symbol then -- +symbol then /* +operators without one of the exception chars + followed by + or - without whitespace + +also: do the testing for the ansi compatibility special cases + +> postgresShortOperatorTable :: [(String,[Token])] +> postgresShortOperatorTable = +> [ (x, [Symbol x]) | x <- someValidPostgresOperators 2] + + +> postgresExtraOperatorTable :: [(String,[Token])] +> postgresExtraOperatorTable = +> [ (x, [Symbol x]) | x <- someValidPostgresOperators 4] + + +> someValidPostgresOperators :: Int -> [String] +> someValidPostgresOperators l = +> [ x +> | n <- [1..l] +> , x <- combos "+-*/<>=~!@#%^&|`?" n +> , not ("--" `isInfixOf` x || "/*" `isInfixOf` x || "*/" `isInfixOf` x) +> , not (last x `elem` "+-") +> || or (map (`elem` x) "~!@#%^&|`?") +> ] + +These are postgres operators, which if followed immediately by a + or +-, will lex as separate operators rather than one operator including +the + or -. + +> somePostgresOpsWhichWontAddTrailingPlusMinus :: Int -> [String] +> somePostgresOpsWhichWontAddTrailingPlusMinus l = +> [ x +> | n <- [1..l] +> , x <- combos "+-*/<>=" n +> , not ("--" `isInfixOf` x || "/*" `isInfixOf` x || "*/" `isInfixOf` x) +> , not (last x `elem` "+-") +> ] + + +> postgresLexerTests :: TestItem +> postgresLexerTests = Group "postgresLexerTests" $ +> [Group "postgres lexer token tests" $ +> [LexTest postgres s t | (s,t) <- postgresLexerTable] +> ,Group "postgres generated lexer token tests" $ +> [LexTest postgres s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable] +> ,Group "postgres generated combination lexer tests" $ +> [ LexTest postgres (s ++ s1) (t ++ t1) +> | (s,t) <- postgresLexerTable ++ postgresShortOperatorTable +> , (s1,t1) <- postgresLexerTable ++ postgresShortOperatorTable +> , tokenListWillPrintAndLex postgres $ t ++ t1 + +> ] +> ,Group "generated postgres edgecase lexertests" $ +> [LexTest postgres s t +> | (s,t) <- edgeCaseCommentOps +> ++ edgeCasePlusMinusOps +> ++ edgeCasePlusMinusComments] + +> ,Group "adhoc postgres lexertests" $ +> -- need more tests for */ to make sure it is caught if it is in the middle of a +> -- sequence of symbol letters +> [LexFails postgres "*/" +> ,LexFails postgres ":::" +> ,LexFails postgres "::::" +> ,LexFails postgres ":::::" +> ,LexFails postgres "@*/" +> ,LexFails postgres "-*/" +> ,LexFails postgres "12e3e4" +> ,LexFails postgres "12e3e4" +> ,LexFails postgres "12e3e4" +> ,LexFails postgres "12e3.4" +> ,LexFails postgres "12.4.5" +> ,LexFails postgres "12.4e5.6" +> ,LexFails postgres "12.4e5e7" +> -- special case allow this to lex to 1 .. 2 +> -- this is for 'for loops' in plpgsql +> ,LexTest postgres "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"]] +> ] +> where +> edgeCaseCommentOps = +> [ (x ++ "/* | x <- eccops +> , not (last x == '*') +> ] ++ +> [ (x ++ "-- | x <- eccops +> , not (last x == '-') +> ] +> eccops = someValidPostgresOperators 2 +> edgeCasePlusMinusOps = concat +> [ [ (x ++ "+", [Symbol x, Symbol "+"]) +> , (x ++ "-", [Symbol x, Symbol "-"]) ] +> | x <- somePostgresOpsWhichWontAddTrailingPlusMinus 2 +> ] +> edgeCasePlusMinusComments = +> [("---", [LineComment "---"]) +> ,("+--", [Symbol "+", LineComment "--"]) +> ,("-/**/", [Symbol "-", BlockComment "/**/"]) +> ,("+/**/", [Symbol "+", BlockComment "/**/"]) +> ] + + +> sqlServerLexerTests :: TestItem +> sqlServerLexerTests = Group "sqlServerLexTests" $ +> [ LexTest sqlserver s t | (s,t) <- +> [("@variable", [(PrefixedVariable '@' "variable")]) +> ,("#variable", [(PrefixedVariable '#' "variable")]) +> ,("[quoted identifier]", [(Identifier (Just ("[", "]")) "quoted identifier")]) +> ]] + +> oracleLexerTests :: TestItem +> oracleLexerTests = Group "oracleLexTests" $ +> [] -- nothing oracle specific atm + +> mySqlLexerTests :: TestItem +> mySqlLexerTests = Group "mySqlLexerTests" $ +> [ LexTest mysql s t | (s,t) <- +> [("`quoted identifier`", [(Identifier (Just ("`", "`")) "quoted identifier")]) +> ] +> ] + +> odbcLexerTests :: TestItem +> odbcLexerTests = Group "odbcLexTests" $ +> [ LexTest sqlserver {allowOdbc = True} s t | (s,t) <- +> [("{}", [Symbol "{", Symbol "}"]) +> ]] +> ++ [LexFails sqlserver "{" +> ,LexFails sqlserver "}"] + +> combos :: [a] -> Int -> [[a]] +> combos _ 0 = [[]] +> combos l n = [ x:tl | x <- l, tl <- combos l (n - 1) ] + +figure out a way to do quickcheck testing: +1. generate valid tokens and check they parse + +2. combine two generated tokens together for the combo testing + +this especially will work much better for the postgresql extensible +operator tests which doing exhaustively takes ages and doesn't bring +much benefit over testing a few using quickcheck. diff --git a/tools/Language/SQL/SimpleSQL/MySQL.lhs b/tools/Language/SQL/SimpleSQL/MySQL.lhs --- a/tools/Language/SQL/SimpleSQL/MySQL.lhs +++ b/tools/Language/SQL/SimpleSQL/MySQL.lhs @@ -18,23 +18,23 @@ [LIMIT {[offset,] row_count | row_count OFFSET offset}] > backtickQuotes :: TestItem -> backtickQuotes = Group "backtickQuotes" (map (uncurry (TestValueExpr MySQL)) -> [("`test`", Iden [DQName "`" "`" "test"]) +> backtickQuotes = Group "backtickQuotes" (map (uncurry (TestScalarExpr mysql)) +> [("`test`", Iden [Name (Just ("`","`")) "test"]) > ] -> ++ [ParseValueExprFails SQL2011 "`test`"] +> ++ [ParseScalarExprFails ansi2011 "`test`"] > ) > limit :: TestItem -> limit = Group "queries" ( map (uncurry (TestQueryExpr MySQL)) +> limit = Group "queries" ( map (uncurry (TestQueryExpr mysql)) > [("select * from t limit 5" > ,sel {qeFetchFirst = Just (NumLit "5")} > ) > ] -> ++ [ParseQueryExprFails MySQL "select a from t fetch next 10 rows only;" -> ,ParseQueryExprFails SQL2011 "select * from t limit 5"] +> ++ [ParseQueryExprFails mysql "select a from t fetch next 10 rows only;" +> ,ParseQueryExprFails ansi2011 "select * from t limit 5"] > ) > where > sel = makeSelect > {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] +> ,qeFrom = [TRSimple [Name Nothing "t"]] > } diff --git a/tools/Language/SQL/SimpleSQL/Odbc.lhs b/tools/Language/SQL/SimpleSQL/Odbc.lhs new file mode 100644 --- /dev/null +++ b/tools/Language/SQL/SimpleSQL/Odbc.lhs @@ -0,0 +1,52 @@ + +> module Language.SQL.SimpleSQL.Odbc (odbcTests) where + +> import Language.SQL.SimpleSQL.TestTypes +> import Language.SQL.SimpleSQL.Syntax + +> odbcTests :: TestItem +> odbcTests = Group "odbc" [ +> Group "datetime" [ +> e "{d '2000-01-01'}" (OdbcLiteral OLDate "2000-01-01") +> ,e "{t '12:00:01.1'}" (OdbcLiteral OLTime "12:00:01.1") +> ,e "{ts '2000-01-01 12:00:01.1'}" +> (OdbcLiteral OLTimestamp "2000-01-01 12:00:01.1") +> ] +> ,Group "functions" [ +> e "{fn CHARACTER_LENGTH(string_exp)}" +> $ OdbcFunc (ap "CHARACTER_LENGTH" [iden "string_exp"]) +> ,e "{fn EXTRACT(day from t)}" +> $ OdbcFunc (SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "t"])]) +> ,e "{fn now()}" +> $ OdbcFunc (ap "now" []) +> ,e "{fn CONVERT('2000-01-01', SQL_DATE)}" +> $ OdbcFunc (ap "CONVERT" +> [StringLit "'" "'" "2000-01-01" +> ,iden "SQL_DATE"]) +> ,e "{fn CONVERT({fn CURDATE()}, SQL_DATE)}" +> $ OdbcFunc (ap "CONVERT" +> [OdbcFunc (ap "CURDATE" []) +> ,iden "SQL_DATE"]) +> ] +> ,Group "outer join" [ +> TestQueryExpr ansi2011 {allowOdbc=True} +> "select * from {oj t1 left outer join t2 on expr}" +> $ makeSelect +> {qeSelectList = [(Star,Nothing)] +> ,qeFrom = [TROdbc $ TRJoin (TRSimple [Name Nothing "t1"]) False JLeft (TRSimple [Name Nothing "t2"]) +> (Just $ JoinOn $ Iden [Name Nothing "expr"])]}] +> ,Group "check parsing bugs" [ +> TestQueryExpr ansi2011 {allowOdbc=True} +> "select {fn CONVERT(cint,SQL_BIGINT)} from t;" +> $ makeSelect +> {qeSelectList = [(OdbcFunc (ap "CONVERT" +> [iden "cint" +> ,iden "SQL_BIGINT"]), Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]]}] +> ] +> where +> e = TestScalarExpr ansi2011 {allowOdbc = True} +> --tsql = ParseProcSql defaultParseFlags {pfDialect=sqlServerDialect} +> ap n = App [Name Nothing n] +> iden n = Iden [Name Nothing n] + diff --git a/tools/Language/SQL/SimpleSQL/Oracle.lhs b/tools/Language/SQL/SimpleSQL/Oracle.lhs new file mode 100644 --- /dev/null +++ b/tools/Language/SQL/SimpleSQL/Oracle.lhs @@ -0,0 +1,29 @@ + +Tests for oracle dialect parsing + +> module Language.SQL.SimpleSQL.Oracle (oracleTests) where + +> import Language.SQL.SimpleSQL.TestTypes +> import Language.SQL.SimpleSQL.Syntax + +> oracleTests :: TestItem +> oracleTests = Group "oracle dialect" +> [oracleLobUnits] + + +> oracleLobUnits :: TestItem +> oracleLobUnits = Group "oracleLobUnits" (map (uncurry (TestScalarExpr oracle)) +> [("cast (a as varchar2(3 char))" +> ,Cast (Iden [Name Nothing "a"]) ( +> PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecCharacters))) +> ,("cast (a as varchar2(3 byte))" +> ,Cast (Iden [Name Nothing "a"]) ( +> PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecOctets))) +> ] +> ++ [TestStatement oracle +> "create table t (a varchar2(55 BYTE));" +> $ CreateTable [Name Nothing "t"] +> [TableColumnDef $ ColumnDef (Name Nothing "a") +> (PrecLengthTypeName [Name Nothing "varchar2"] 55 Nothing (Just PrecOctets)) +> Nothing []]] +> ) diff --git a/tools/Language/SQL/SimpleSQL/Postgres.lhs b/tools/Language/SQL/SimpleSQL/Postgres.lhs --- a/tools/Language/SQL/SimpleSQL/Postgres.lhs +++ b/tools/Language/SQL/SimpleSQL/Postgres.lhs @@ -8,7 +8,7 @@ > import Language.SQL.SimpleSQL.TestTypes > postgresTests :: TestItem -> postgresTests = Group "postgresTests" $ map (ParseQueryExpr SQL2011) +> postgresTests = Group "postgresTests" $ map (ParseQueryExpr ansi2011) lexical syntax section diff --git a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs --- a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +++ b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs @@ -28,7 +28,7 @@ > duplicates :: TestItem -> duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr SQL2011)) +> duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a from t" ,ms SQDefault) > ,("select all a from t" ,ms All) > ,("select distinct a from t", ms Distinct) @@ -36,90 +36,90 @@ > where > ms d = makeSelect > {qeSetQuantifier = d -> ,qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} +> ,qeSelectList = [(Iden [Name Nothing "a"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]]} > selectLists :: TestItem -> selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr SQL2011)) +> selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr ansi2011)) > [("select 1", > makeSelect {qeSelectList = [(NumLit "1",Nothing)]}) > ,("select a" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)]}) +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing)]}) > ,("select a,b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) -> ,(Iden [Name "b"],Nothing)]}) +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing) +> ,(Iden [Name Nothing "b"],Nothing)]}) > ,("select 1+2,3+4" > ,makeSelect {qeSelectList = -> [(BinOp (NumLit "1") [Name "+"] (NumLit "2"),Nothing) -> ,(BinOp (NumLit "3") [Name "+"] (NumLit "4"),Nothing)]}) +> [(BinOp (NumLit "1") [Name Nothing "+"] (NumLit "2"),Nothing) +> ,(BinOp (NumLit "3") [Name Nothing "+"] (NumLit "4"),Nothing)]}) > ,("select a as a, /*comment*/ b as b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"], Just $ Name "a") -> ,(Iden [Name "b"], Just $ Name "b")]}) +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a") +> ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]}) > ,("select a a, b b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"], Just $ Name "a") -> ,(Iden [Name "b"], Just $ Name "b")]}) +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a") +> ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]}) > ,("select a + b * c" > ,makeSelect {qeSelectList = -> [(BinOp (Iden [Name "a"]) [Name "+"] -> (BinOp (Iden [Name "b"]) [Name "*"] (Iden [Name "c"])) +> [(BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] +> (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"])) > ,Nothing)]}) > ] > whereClause :: TestItem -> whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr SQL2011)) +> whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a from t where a = 5" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeWhere = Just $ BinOp (Iden [Name "a"]) [Name "="] (NumLit "5")}) +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] +> ,qeWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")}) > ] > having :: TestItem -> having = Group "having" $ map (uncurry (TestQueryExpr SQL2011)) +> having = Group "having" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a,sum(b) from t group by a having sum(b) > 5" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) -> ,(App [Name "sum"] [Iden [Name "b"]],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = [SimpleGroup $ Iden [Name "a"]] -> ,qeHaving = Just $ BinOp (App [Name "sum"] [Iden [Name "b"]]) -> [Name ">"] (NumLit "5") +> ,makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing) +> ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] +> ,qeGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] +> ,qeHaving = Just $ BinOp (App [Name Nothing "sum"] [Iden [Name Nothing "b"]]) +> [Name Nothing ">"] (NumLit "5") > }) > ] > orderBy :: TestItem -> orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr SQL2011)) +> orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a from t order by a" -> ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault]) +> ,ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault]) > ,("select a from t order by a, b" -> ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) DirDefault NullsOrderDefault]) +> ,ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault +> ,SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault]) > ,("select a from t order by a asc" -> ,ms [SortSpec (Iden [Name "a"]) Asc NullsOrderDefault]) +> ,ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault]) > ,("select a from t order by a desc, b desc" -> ,ms [SortSpec (Iden [Name "a"]) Desc NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) Desc NullsOrderDefault]) +> ,ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsOrderDefault +> ,SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault]) > ,("select a from t order by a desc nulls first, b desc nulls last" -> ,ms [SortSpec (Iden [Name "a"]) Desc NullsFirst -> ,SortSpec (Iden [Name "b"]) Desc NullsLast]) +> ,ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsFirst +> ,SortSpec (Iden [Name Nothing "b"]) Desc NullsLast]) > ] > where -> ms o = makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] +> ms o = makeSelect {qeSelectList = [(Iden [Name Nothing "a"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] > ,qeOrderBy = o} > offsetFetch :: TestItem -> offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr SQL2011)) +> offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011)) > [-- ansi standard > ("select a from t offset 5 rows fetch next 10 rows only" > ,ms (Just $ NumLit "5") (Just $ NumLit "10")) @@ -136,74 +136,74 @@ > ] > where > ms o l = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] +> {qeSelectList = [(Iden [Name Nothing "a"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]] > ,qeOffset = o > ,qeFetchFirst = l} > combos :: TestItem -> combos = Group "combos" $ map (uncurry (TestQueryExpr SQL2011)) +> combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011)) > [("select a from t union select b from u" -> ,CombineQueryExpr ms1 Union SQDefault Respectively ms2) +> ,QueryExprSetOp ms1 Union SQDefault Respectively ms2) > ,("select a from t intersect select b from u" -> ,CombineQueryExpr ms1 Intersect SQDefault Respectively ms2) +> ,QueryExprSetOp ms1 Intersect SQDefault Respectively ms2) > ,("select a from t except all select b from u" -> ,CombineQueryExpr ms1 Except All Respectively ms2) +> ,QueryExprSetOp ms1 Except All Respectively ms2) > ,("select a from t union distinct corresponding \ > \select b from u" -> ,CombineQueryExpr ms1 Union Distinct Corresponding ms2) +> ,QueryExprSetOp ms1 Union Distinct Corresponding ms2) > ,("select a from t union select a from t union select a from t" > -- TODO: union should be left associative. I think the others also > -- so this needs to be fixed (new optionSuffix variation which > -- handles this) -> ,CombineQueryExpr ms1 Union SQDefault Respectively -> (CombineQueryExpr ms1 Union SQDefault Respectively ms1)) +> ,QueryExprSetOp ms1 Union SQDefault Respectively +> (QueryExprSetOp ms1 Union SQDefault Respectively ms1)) > ] > where > ms1 = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} +> {qeSelectList = [(Iden [Name Nothing "a"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "t"]]} > ms2 = makeSelect -> {qeSelectList = [(Iden [Name "b"],Nothing)] -> ,qeFrom = [TRSimple [Name "u"]]} +> {qeSelectList = [(Iden [Name Nothing "b"],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing "u"]]} > withQueries :: TestItem -> withQueries = Group "with queries" $ map (uncurry (TestQueryExpr SQL2011)) +> withQueries = Group "with queries" $ map (uncurry (TestQueryExpr ansi2011)) > [("with u as (select a from t) select a from u" -> ,With False [(Alias (Name "u") Nothing, ms1)] ms2) +> ,With False [(Alias (Name Nothing "u") Nothing, ms1)] ms2) > ,("with u(b) as (select a from t) select a from u" -> ,With False [(Alias (Name "u") (Just [Name "b"]), ms1)] ms2) +> ,With False [(Alias (Name Nothing "u") (Just [Name Nothing "b"]), ms1)] ms2) > ,("with x as (select a from t),\n\ > \ u as (select a from x)\n\ > \select a from u" -> ,With False [(Alias (Name "x") Nothing, ms1), (Alias (Name "u") Nothing,ms3)] ms2) +> ,With False [(Alias (Name Nothing "x") Nothing, ms1), (Alias (Name Nothing "u") Nothing,ms3)] ms2) > ,("with recursive u as (select a from t) select a from u" -> ,With True [(Alias (Name "u") Nothing, ms1)] ms2) +> ,With True [(Alias (Name Nothing "u") Nothing, ms1)] ms2) > ] > where > ms c t = makeSelect -> {qeSelectList = [(Iden [Name c],Nothing)] -> ,qeFrom = [TRSimple [Name t]]} +> {qeSelectList = [(Iden [Name Nothing c],Nothing)] +> ,qeFrom = [TRSimple [Name Nothing t]]} > ms1 = ms "a" "t" > ms2 = ms "a" "u" > ms3 = ms "a" "x" > values :: TestItem -> values = Group "values" $ map (uncurry (TestQueryExpr SQL2011)) +> values = Group "values" $ map (uncurry (TestQueryExpr ansi2011)) > [("values (1,2),(3,4)" > ,Values [[NumLit "1", NumLit "2"] > ,[NumLit "3", NumLit "4"]]) > ] > tables :: TestItem -> tables = Group "tables" $ map (uncurry (TestQueryExpr SQL2011)) -> [("table tbl", Table [Name "tbl"]) +> tables = Group "tables" $ map (uncurry (TestQueryExpr ansi2011)) +> [("table tbl", Table [Name Nothing "tbl"]) > ] diff --git a/tools/Language/SQL/SimpleSQL/QueryExprs.lhs b/tools/Language/SQL/SimpleSQL/QueryExprs.lhs --- a/tools/Language/SQL/SimpleSQL/QueryExprs.lhs +++ b/tools/Language/SQL/SimpleSQL/QueryExprs.lhs @@ -8,11 +8,11 @@ > import Language.SQL.SimpleSQL.Syntax > queryExprsTests :: TestItem -> queryExprsTests = Group "query exprs" $ map (uncurry (TestQueryExprs SQL2011)) +> queryExprsTests = Group "query exprs" $ map (uncurry (TestStatements ansi2011)) > [("select 1",[ms]) > ,("select 1;",[ms]) > ,("select 1;select 1",[ms,ms]) > ,(" select 1;select 1; ",[ms,ms]) > ] > where -> ms = makeSelect {qeSelectList = [(NumLit "1",Nothing)]} +> ms = SelectStatement $ makeSelect {qeSelectList = [(NumLit "1",Nothing)]} diff --git a/tools/Language/SQL/SimpleSQL/SQL2011.lhs b/tools/Language/SQL/SimpleSQL/SQL2011.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/SQL2011.lhs +++ /dev/null @@ -1,4309 +0,0 @@ - -This file goes through the grammar for SQL 2011 (using the draft standard). - -We are only looking at the query syntax, and no other parts. - -The goal is to create some example tests for each bit of grammar, with -some areas getting more comprehensive coverage tests, and also to note -which parts aren't currently supported. - -> module Language.SQL.SimpleSQL.SQL2011 (sql2011Tests) where -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - -> sql2011Tests :: TestItem -> sql2011Tests = Group "sql 2011 tests" -> [literals -> ,identifiers -> ,typeNameTests -> ,fieldDefinition -> ,valueExpressions -> ,queryExpressions -> ,scalarSubquery -> ,predicates -> ,intervalQualifier -> ,collateClause -> ,aggregateFunction -> ,sortSpecificationList -> ] - -= 5 Lexical elements - -The tests don't make direct use of these definitions. - -== 5.1 - -Function - -Define the terminal symbols of the SQL language and the elements of -strings. - - ::= - - ::= - - | - | - - ::= - - | - - ::= - A | B | C | D | E | F | G | H | I | J | K | L | M | N | O - | P | Q | R | S | T | U | V | W | X | Y | Z - - ::= - a | b | c | d | e | f | g | h | i | j | k | l | m | n | o - | p | q | r | s | t | u | v | w | x | y | z - - ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 - - ::= - - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - - ::= !! See the Syntax Rules. - - ::= " - - ::= % - - ::= & - - ::= ' - - ::= ( - - ::= ) - - ::= * - - ::= + - - ::= , - - ::= - - - ::= . - - ::= / - - ::= \ - - ::= : - - ::= ; - - ::= < - - ::= = - - ::= > - - ::= ? - - ::= | - - ::= | - - ::= [ - - ::= ??( - - ::= ] - - ::= ??) - - ::= ^ - - ::= _ - - ::= | - - ::= { - - ::= } - -== 5.2 and - -Function - -Specify lexical units (tokens and separators) that participate in SQL -language. - - ::= | - - ::= - - | - | - | - | - | - | - | - | - - ::= - - ::= [ ... ] - - ::= | - - ::= !! See the Syntax Rules. - - ::= !! See the Syntax Rules. - - ::= ... - - ::= K | M | G | T | P - - ::= - - - ::= ... - - ::= - - | - - ::= - U - - - ::= - [ UESCAPE ] - - ::= ... - - ::= - - | - - ::= - - | - | - - ::= - - - ::= - - - - ::= - - - ::= !! See the Syntax Rules. - - ::= !! See the Syntax Rules. - - ::= ""!! two consecutive double quote characters - - ::= - - | - |