diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Jake Wheat +Copyright 2013 - 2024, Jake Wheat and the simple-sql-parser contributors. All rights reserved. diff --git a/Language/SQL/SimpleSQL/Combinators.lhs b/Language/SQL/SimpleSQL/Combinators.lhs deleted file mode 100644 --- a/Language/SQL/SimpleSQL/Combinators.lhs +++ /dev/null @@ -1,109 +0,0 @@ - -> -- | This module contains some generic combinators used in the -> -- parser. None of the parsing which relies on the local lexers is -> -- in this module. Some of these combinators have been taken from -> -- other parser combinator libraries other than Parsec. - -> module Language.SQL.SimpleSQL.Combinators -> (optionSuffix -> ,() -> ,() -> ,() -> ,(<$$>) -> ,(<$$$>) -> ,(<$$$$>) -> ,(<$$$$$>) -> ) where - -> import Control.Applicative ((<$>), (<*>), (<**>), pure, Applicative) -> import Text.Parsec (option,many) -> import Text.Parsec.Prim (Parsec) - -> 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 -all these uses and figure out if any should be right associative -instead, and create an alternative suffix parser - -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 p a = option a (p a) - - -parses an optional postfix element and applies its result to its left -hand result, taken from uu-parsinglib - -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 -> p q = p <**> option id q - - -Help with left factored parsers. <$$> is like an analogy with <**>: - -f <$> a <*> b - -is like - -a <**> (b <$$> f) - -f <$> a <*> b <*> c - -is like - -a <**> (b <**> (c <$$$> f)) - -> (<$$>) :: Applicative f => -> f b -> (a -> b -> c) -> f (a -> c) -> (<$$>) pa c = pa <**> pure (flip c) - -> (<$$$>) :: Applicative f => -> f c -> (a -> b -> c -> t) -> f (b -> a -> t) -> p <$$$> c = p <**> pure (flip3 c) - -> (<$$$$>) :: Applicative f => -> f d -> (a -> b -> c -> d -> t) -> f (c -> b -> a -> t) -> p <$$$$> c = p <**> pure (flip4 c) - -> (<$$$$$>) :: Applicative f => -> f e -> (a -> b -> c -> d -> e -> t) -> f (d -> c -> b -> a -> t) -> p <$$$$$> c = p <**> pure (flip5 c) - -Surely no-one would write code like this seriously? - - -composing suffix parsers, not sure about the name. This is used to add -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) -> () pa pb = (.) `c` pa <*> option id pb -> -- todo: fix this mess -> where c = (<$>) . flip - - -0 to many repeated applications of suffix parser - -> () :: Parser s a -> Parser s (a -> a) -> Parser s a -> p q = foldr ($) <$> p <*> (reverse <$> many q) - - -These are to help with left factored parsers: - -a <**> (b <**> (c <**> pure (flip3 ctor))) - -Not sure the names are correct, but they follow a pattern with flip -a <**> (b <**> pure (flip ctor)) - -> flip3 :: (a -> b -> c -> t) -> c -> b -> a -> t -> flip3 f a b c = f c b a - -> flip4 :: (a -> b -> c -> d -> t) -> d -> c -> b -> a -> t -> flip4 f a b c d = f d c b a - -> flip5 :: (a -> b -> c -> d -> e -> t) -> e -> d -> c -> b -> a -> t -> flip5 f a b c d e = f e d c b a diff --git a/Language/SQL/SimpleSQL/Dialect.hs b/Language/SQL/SimpleSQL/Dialect.hs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Dialect.hs @@ -0,0 +1,564 @@ + + +-- Data types to represent different dialect options + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Dialect + (Dialect(..) + ,ansi2011 + ,mysql + ,postgres + ,oracle + ,sqlserver + ) where + +import Data.Text (Text) +import Data.Data (Data,Typeable) + +-- | Used to set the dialect used for parsing and pretty printing, +-- very unfinished at the moment. +-- +-- The keyword handling works as follows: +-- +-- There is a list of reserved keywords. These will never parse as +-- anything other than as a keyword, unless they are in one of the +-- other lists. +-- +-- There is a list of \'identifier\' keywords. These are reserved +-- keywords, with an exception that they will parse as an +-- identifier in a scalar expression. They won't parse as +-- identifiers in other places, e.g. column names or aliases. +-- +-- There is a list of \'app\' keywords. These are reserved keywords, +-- with an exception that they will also parse in an \'app-like\' +-- construct - a regular function call, or any of the aggregate and +-- window variations. +-- +-- There is a list of special type names. This list serves two +-- purposes - it is a list of the reserved keywords which are also +-- type names, and it is a list of all the multi word type names. +-- +-- Every keyword should appear in the keywords lists, and then you can +-- add them to the other lists if you want exceptions. Most things +-- that refer to functions, types or variables that are keywords in +-- the ansi standard, can be removed from the keywords lists +-- completely with little effect. With most of the actual SQL +-- keywords, removing them from the keyword list will result in +-- lots of valid syntax no longer parsing (and probably bad parse +-- error messages too). +-- +-- In the code, all special syntax which looks identical to regular +-- identifiers or function calls (apart from the name), is treated +-- like a regular identifier or function call. +-- +-- It's easy to break the parser by removing the wrong words from +-- the keywords list or adding the wrong words to the other lists. + +data Dialect = Dialect + { -- | reserved keywords + diKeywords :: [Text] + -- | keywords with identifier exception + ,diIdentifierKeywords :: [Text] + -- | keywords with app exception + ,diAppKeywords :: [Text] + -- | keywords with type exception plus all the type names which + -- are multiple words + ,diSpecialTypeNames :: [Text] + -- | allow ansi fetch first syntax + ,diFetchFirst :: Bool + -- | allow limit keyword (mysql, postgres, + -- ...) + ,diLimit :: Bool + -- | allow parsing ODBC syntax + ,diOdbc :: Bool + -- | allow quoting identifiers with \`backquotes\` + ,diBackquotedIden :: Bool + -- | allow quoting identifiers with [square brackets] + ,diSquareBracketQuotedIden :: Bool + -- | allow identifiers with a leading at @example + ,diAtIdentifier :: Bool + -- | allow identifiers with a leading \# \#example + ,diHashIdentifier :: Bool + -- | allow positional identifiers like this: $1 + ,diPositionalArg :: Bool + -- | allow postgres style dollar strings + ,diDollarString :: Bool + -- | allow strings with an e - e"example" + ,diEString :: Bool + -- | allow postgres style symbols + ,diPostgresSymbols :: Bool + -- | allow sql server style symbols + ,diSqlServerSymbols :: Bool + -- | allow sql server style for CONVERT function in format CONVERT(data_type(length), expression, style) + ,diConvertFunction :: Bool + -- | allow creating autoincrement columns + ,diAutoincrement :: Bool + -- | allow omitting the comma between constraint clauses + ,diNonCommaSeparatedConstraints :: Bool + -- | allow marking tables as "without rowid" + ,diWithoutRowidTables :: Bool + -- | allow omitting types for columns + ,diOptionalColumnTypes :: Bool + -- | allow mixing in DEFAULT clauses with other constraints + ,diDefaultClausesAsConstraints :: Bool + } + deriving (Eq,Show,Read,Data,Typeable) + +-- | ansi sql 2011 dialect +ansi2011 :: Dialect +ansi2011 = Dialect {diKeywords = ansi2011ReservedKeywords + ,diIdentifierKeywords = [] + ,diAppKeywords = ["set"] + ,diSpecialTypeNames = ansi2011TypeNames + ,diFetchFirst = True + ,diLimit = False + ,diOdbc = False + ,diBackquotedIden = False + ,diSquareBracketQuotedIden = False + ,diAtIdentifier = False + ,diHashIdentifier = False + ,diPositionalArg = False + ,diDollarString = False + ,diEString = False + ,diPostgresSymbols = False + ,diSqlServerSymbols = False + ,diConvertFunction = False + ,diAutoincrement = False + ,diNonCommaSeparatedConstraints = False + ,diWithoutRowidTables = False + ,diOptionalColumnTypes = False + ,diDefaultClausesAsConstraints = False + } + +-- | mysql dialect +mysql :: Dialect +mysql = addLimit ansi2011 {diFetchFirst = False + ,diBackquotedIden = True + } + +-- | postgresql dialect +postgres :: Dialect +postgres = addLimit ansi2011 {diPositionalArg = True + ,diDollarString = True + ,diEString = True + ,diPostgresSymbols = True} + +-- | oracle dialect +oracle :: Dialect +oracle = ansi2011 -- {} + +-- | microsoft sql server dialect +sqlserver :: Dialect +sqlserver = ansi2011 {diSquareBracketQuotedIden = True + ,diAtIdentifier = True + ,diHashIdentifier = True + ,diOdbc = True + ,diSqlServerSymbols = True + ,diConvertFunction = True} + +addLimit :: Dialect -> Dialect +addLimit d = d {diKeywords = "limit": diKeywords d + ,diLimit = True} + + +{- +The keyword handling is quite strong - an alternative way to do it +would be to have as few keywords as possible, and only require them +to be quoted when this is needed to resolve a parsing ambiguity. + +I don't think this is a good idea for genuine keywords (it probably is +for all the 'fake' keywords in the standard - things which are +essentially function names, or predefined variable names, or type +names, eetc.). + +1. working out exactly when each keyword would need to be quoted is +quite error prone, and might change as the parser implementation is +maintained - which would be terrible for users + +2. it's not user friendly for the user to deal with a whole load of +special cases - either something is a keyword, then you know you must +always quote it, or it isn't, then you know you never need to quote +it + +3. I think not having exceptions makes for better error messages for +the user, and a better sql code maintenance experience. + +This might not match actual existing SQL products that well, some of +which I think have idiosyncratic rules about when a keyword must be +quoted. If you want to match one of these dialects exactly with this +parser, I think it will be a lot of work. +-} + +ansi2011ReservedKeywords :: [Text] +ansi2011ReservedKeywords = + [--"abs" -- function + "all" -- keyword only? + ,"allocate" -- keyword + ,"alter" -- keyword + ,"and" -- keyword + --,"any" -- keyword? and function + ,"are" -- keyword + ,"array" -- keyword, and used in some special places, like array[...], and array(subquery) + --,"array_agg" -- function + -- ,"array_max_cardinality" -- function + ,"as" -- keyword + ,"asensitive" -- keyword + ,"asymmetric" -- keyword + ,"at" -- keyword + ,"atomic" -- keyword + ,"authorization" -- keyword + --,"avg" -- function + ,"begin" -- keyword + --,"begin_frame" -- identifier + --,"begin_partition" -- identifier + ,"between" -- keyword + ,"bigint" -- type + ,"binary" -- type + ,"blob" -- type + ,"boolean" -- type + ,"both" -- keyword + ,"by" -- keyword + ,"call" -- keyword + ,"called" -- keyword + -- ,"cardinality" -- function + identifier? + ,"cascaded" -- keyword + ,"case" -- keyword + ,"cast" -- special function + -- ,"ceil" -- function + -- ,"ceiling" -- function + ,"char" -- type (+ keyword?) + --,"char_length" -- function + ,"character" -- type + --,"character_length" -- function + ,"check" -- keyword + ,"clob" -- type + ,"close" -- keyword + -- ,"coalesce" -- function + ,"collate" -- keyword + --,"collect" -- function + ,"column" -- keyword + ,"commit" -- keyword + ,"condition" -- keyword + ,"connect" -- keyword + ,"constraint" --keyword + --,"contains" -- keyword? + --,"convert" -- function? + --,"corr" -- function + ,"corresponding" --keyword + --,"count" --function + --,"covar_pop" -- function + --,"covar_samp" --function + ,"create" -- keyword + ,"cross" -- keyword + ,"cube" -- keyword + --,"cume_dist" -- function + ,"current" -- keyword + -- ,"current_catalog" --identifier? + --,"current_date" -- identifier + --,"current_default_transform_group" -- identifier + --,"current_path" -- identifier + --,"current_role" -- identifier + -- ,"current_row" -- identifier + -- ,"current_schema" -- identifier + -- ,"current_time" -- identifier + --,"current_timestamp" -- identifier + --,"current_transform_group_for_type" -- identifier, or keyword? + --,"current_user" -- identifier + ,"cursor" -- keyword + ,"cycle" --keyword + ,"date" -- type + --,"day" -- keyword? - the parser needs it to not be a keyword to parse extract at the moment + ,"deallocate" -- keyword + ,"dec" -- type + ,"decimal" -- type + ,"declare" -- keyword + --,"default" -- identifier + keyword + ,"delete" -- keyword + --,"dense_rank" -- functino + ,"deref" -- keyword + ,"describe" -- keyword + ,"deterministic" + ,"disconnect" + ,"distinct" + ,"double" + ,"drop" + ,"dynamic" + ,"each" + --,"element" + ,"else" + ,"end" + -- ,"end_frame" -- identifier + -- ,"end_partition" -- identifier + ,"end-exec" -- no idea what this is + ,"equals" + ,"escape" + --,"every" + ,"except" + ,"exec" + ,"execute" + ,"exists" + ,"exp" + ,"external" + ,"extract" + --,"false" + ,"fetch" + ,"filter" + -- ,"first_value" + ,"float" + --,"floor" + ,"for" + ,"foreign" + -- ,"frame_row" -- identifier + ,"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" + ] + + +ansi2011TypeNames :: [Text] +ansi2011TypeNames = + ["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" + ] diff --git a/Language/SQL/SimpleSQL/Errors.lhs b/Language/SQL/SimpleSQL/Errors.lhs deleted file mode 100644 --- a/Language/SQL/SimpleSQL/Errors.lhs +++ /dev/null @@ -1,51 +0,0 @@ - -> -- | helpers to work with parsec errors more nicely -> module Language.SQL.SimpleSQL.Errors -> (ParseError(..) -> --,formatError -> ,convParseError -> ) where - -> import Text.Parsec (sourceColumn,sourceLine,sourceName,errorPos) -> import qualified Text.Parsec as P (ParseError) - -> -- | Type to represent parse errors. -> data ParseError = ParseError -> {peErrorString :: String -> -- ^ contains the error message -> ,peFilename :: FilePath -> -- ^ filename location for the error -> ,pePosition :: (Int,Int) -> -- ^ line number and column number location for the error -> ,peFormattedError :: String -> -- ^ formatted error with the position, error -> -- message and source context -> } deriving (Eq,Show) - -> convParseError :: String -> P.ParseError -> ParseError -> convParseError src e = -> ParseError -> {peErrorString = show e -> ,peFilename = sourceName p -> ,pePosition = (sourceLine p, sourceColumn p) -> ,peFormattedError = formatError src e} -> where -> p = errorPos e - -format the error more nicely: emacs format for positioning, plus -context - -> formatError :: String -> P.ParseError -> String -> formatError src e = -> sourceName p ++ ":" ++ show (sourceLine p) -> ++ ":" ++ show (sourceColumn p) ++ ":" -> ++ context -> ++ show e -> where -> context = -> let lns = take 1 $ drop (sourceLine p - 1) $ lines src -> in case lns of -> [x] -> "\n" ++ x ++ "\n" -> ++ replicate (sourceColumn p - 1) ' ' ++ "^\n" -> _ -> "" -> p = errorPos e diff --git a/Language/SQL/SimpleSQL/Lex.hs b/Language/SQL/SimpleSQL/Lex.hs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Lex.hs @@ -0,0 +1,1034 @@ + +{- +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. + +TODO: + +optimisations: + +check for left factor opportunities +check for places where it parses a few substrings from the source, + then puts them back together with a concatenate of some flavour + -> this is better if can find a way to parse the entire string + from the source and lift it in one go into the lexical token +before this is done, a smaller optimisation is when any code matches + a constant string in the lexer, use that constant string instead + of the string from the parser, it might make a small difference in + a few places +maybe every token should carry the exact source as well as any fields + it's been broken into - so pretty printing is trivial + + +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 + +-} + +-- | Lexer for SQL. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Language.SQL.SimpleSQL.Lex + (Token(..) + ,WithPos(..) + ,lexSQL + ,lexSQLWithPositions + ,prettyToken + ,prettyTokens + ,ParseError + ,prettyError + ,tokenListWillPrintAndLex + ,ansi2011 + ,SQLStream(..) + ) where + +import Language.SQL.SimpleSQL.Dialect + (Dialect(..) + ,ansi2011 + ) + +import Text.Megaparsec + (Parsec + ,runParser' + + ,PosState(..) + ,TraversableStream(..) + ,VisualStream(..) + + ,ParseErrorBundle(..) + ,errorBundlePretty + + ,SourcePos(..) + ,getSourcePos + ,getOffset + ,pstateSourcePos + ,statePosState + ,mkPos + ,hidden + ,setErrorOffset + + ,choice + ,satisfy + ,takeWhileP + ,takeWhile1P + ,eof + ,many + ,try + ,option + ,(<|>) + ,notFollowedBy + ,lookAhead + ,match + ,optional + ,label + ,chunk + ,region + ,anySingle + ) +import qualified Text.Megaparsec as M +import Text.Megaparsec.Char + (string + ,char + ) +import Text.Megaparsec.State (initialState) + +import qualified Data.List as DL +import qualified Data.List.NonEmpty as NE +import Data.Proxy (Proxy(..)) +import Data.Void (Void) + +import Data.Char + (isAlphaNum + ,isAlpha + ,isSpace + ,isDigit + ) +import Control.Monad (void) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Maybe (fromMaybe) +--import Text.Megaparsec.Debug (dbg) + +------------------------------------------------------------------------------ + +-- syntax + +-- | Represents a lexed token +data Token + -- | A symbol (in ansi dialect) is one of the following + -- + -- * multi char symbols <> \<= \>= != || + -- * single char symbols: * + - < > ^ / % ~ & | ? ( ) [ ] , ; ( ) + -- + = Symbol Text + -- | 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 (Text,Text)) Text + -- | This is a prefixed variable symbol, such as :var, @var or #var + -- (only :var is used in ansi dialect) + | PrefixedVariable Char Text + -- | 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 Text Text Text + -- | A number literal (integral or otherwise), stored in original format + -- unchanged + | SqlNumber Text + -- | Whitespace, one or more of space, tab or newline. + | Whitespace Text + -- | 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 Text + -- | A block comment, \/* stuff *\/, includes the comment delimiters + | BlockComment Text + -- | Used for generating better error messages when using the + -- output of the lexer in a parser + | InvalidToken Text + deriving (Eq,Show,Ord) + +------------------------------------------------------------------------------ + +-- main api functions + +-- | Lex some SQL to a list of tokens. The invalid token setting +-- changes the behaviour so that if there's a parse error at the start +-- of parsing an invalid token, it adds a final InvalidToken with the +-- character to the result then stop parsing. This can then be used to +-- produce a parse error with more context in the parser. Parse errors +-- within tokens still produce Left errors. +lexSQLWithPositions + :: Dialect + -- ^ dialect of SQL to use + -> Bool + -- ^ produce InvalidToken + -> Text + -- ^ 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 + -> Text + -- ^ the SQL source to lex + -> Either ParseError [WithPos Token] +lexSQLWithPositions dialect pit fn p src = myParse fn p (tokens dialect pit) src + +-- | Lex some SQL to a list of tokens. +lexSQL + :: Dialect + -- ^ dialect of SQL to use + -> Bool + -- ^ produce InvalidToken, see lexSQLWithPositions + -> Text + -- ^ 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 + -> Text + -- ^ the SQL source to lex + -> Either ParseError [Token] +lexSQL dialect pit fn p src = + map tokenVal <$> lexSQLWithPositions dialect pit fn p src + +myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a +myParse name sp' p s = + let sp = fromMaybe (1,1) sp' + ps = SourcePos (T.unpack name) (mkPos $ fst sp) (mkPos $ snd sp) + is = initialState (T.unpack name) s + sps = (statePosState is) {pstateSourcePos = ps} + is' = is {statePosState = sps} + in snd $ runParser' p is' + +prettyError :: ParseError -> Text +prettyError = T.pack . errorBundlePretty + +------------------------------------------------------------------------------ + +-- parsing boilerplate + +type ParseError = ParseErrorBundle Text Void + +type Parser = Parsec Void Text + +-- | Positional information added to tokens to preserve source positions +-- for the parser +data WithPos a = WithPos + { startPos :: SourcePos + , endPos :: SourcePos + , tokenLength :: Int + , tokenVal :: a + } deriving (Eq, Ord, Show) + +------------------------------------------------------------------------------ + +-- pretty print + +-- | Pretty printing, if you lex a bunch of tokens, then pretty +-- print them, should should get back exactly the same string +prettyToken :: Dialect -> Token -> Text +prettyToken _ (Symbol s) = s +prettyToken _ (Identifier Nothing t) = t +prettyToken _ (Identifier (Just (q1,q2)) t) = q1 <> t <> q2 +prettyToken _ (PrefixedVariable c p) = T.cons c p +prettyToken _ (PositionalArg p) = T.cons '$' $ T.pack $ 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 +prettyToken _ (InvalidToken t) = t + +prettyTokens :: Dialect -> [Token] -> Text +prettyTokens d ts = T.concat $ map (prettyToken d) ts + +------------------------------------------------------------------------------ + +-- token parsers + +-- | parser for a sql token +sqlToken :: Dialect -> Parser (WithPos Token) +sqlToken d = + withPos $ hidden $ choice $ + [sqlString d + ,identifier d + ,lineComment d + ,blockComment d + ,sqlNumber d + ,positionalArg d + ,dontParseEndBlockComment d + ,prefixedVariable d + ,symbol d + ,sqlWhitespace d] + +--fakeSourcePos :: SourcePos +--fakeSourcePos = SourcePos "" (mkPos 1) (mkPos 1) + +-------------------------------------- + +-- position and error helpers + +withPos :: Parser a -> Parser (WithPos a) +withPos p = do + sp <- getSourcePos + off <- getOffset + a <- p + off1 <- getOffset + ep <- getSourcePos + pure $ WithPos sp ep (off1 - off) a + +{- + +TODO: extend this idea, to recover to parsing regular tokens after an +invalid one. This can then support resumption after error in the parser. +This would also need something similar being done for parse errors +within lexical tokens. + +-} +invalidToken :: Dialect -> Parser (WithPos Token) +invalidToken _ = + withPos $ (hidden eof *> fail "") <|> (InvalidToken . T.singleton <$> anySingle) + +tokens :: Dialect -> Bool -> Parser [WithPos Token] +tokens d pit = do + x <- many (sqlToken d) + if pit + then choice [x <$ hidden eof + ,(\y -> x ++ [y]) <$> hidden (invalidToken d)] + else x <$ hidden eof + +-------------------------------------- + +{- +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 = + (if (diDollarString d) + then (dollarString <|>) + else id) csString <|> normalString + where + dollarString = do + -- use try because of ambiguity with symbols and with + -- positional arg + delim <- fstMatch (try (char '$' *> hoptional_ identifierString <* char '$')) + let moreDollarString = + label (T.unpack delim) $ takeWhileP_ Nothing (/='$') *> checkDollar + checkDollar = label (T.unpack delim) $ + choice + [lookAhead (chunk_ delim) *> pure () -- would be nice not to parse it twice? + -- but makes the whole match trick much less neat + ,char_ '$' *> moreDollarString] + str <- fstMatch moreDollarString + chunk_ delim + pure $ SqlString delim delim str + lq = label "'" $ char_ '\'' + normalString = SqlString "'" "'" <$> (lq *> normalStringSuffix False) + normalStringSuffix allowBackslash = label "'" $ do + let regularChar = if allowBackslash + then (\x -> x /= '\'' && x /='\\') + else (\x -> x /= '\'') + nonQuoteStringChar = takeWhileP_ Nothing regularChar + nonRegularContinue = + (hchunk_ "''" <|> hchunk_ "\\'" <|> hchar_ '\\') + moreChars = nonQuoteStringChar + *> (option () (nonRegularContinue *> moreChars)) + fstMatch moreChars <* lq + + -- 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 + | diEString d = + choice [SqlString <$> try (string "e'" <|> string "E'") + <*> pure "'" <*> normalStringSuffix True + ,csString'] + | otherwise = csString' + csString' = SqlString + <$> try cs + <*> pure "'" + <*> normalStringSuffix False + csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"] + cs :: Parser Text + cs = choice $ map string csPrefixes + +-------------------------------------- + +{- +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] + ++ [mySqlQuotedIden | diBackquotedIden d] + ++ [sqlServerQuotedIden | diSquareBracketQuotedIden d] + where + regularIden = Identifier Nothing <$> identifierString + quotedIden = Identifier (Just ("\"","\"")) <$> qiden + failEmptyIden c = failOnThis (char_ c) "empty identifier" + mySqlQuotedIden = + Identifier (Just ("`","`")) <$> + (char_ '`' *> + (failEmptyIden '`' + <|> (takeWhile1P Nothing (/='`') <* char_ '`'))) + sqlServerQuotedIden = + Identifier (Just ("[","]")) <$> + (char_ '[' *> + (failEmptyIden ']' + <|> (takeWhileP Nothing (`notElemChar` "[]") + <* choice [char_ ']' + -- should probably do this error message as + -- a proper unexpected message + ,failOnThis (char_ '[') "unexpected ["]))) + -- 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 "&")) + <*> qiden + where f x = Just (T.cons x "&\"", "\"") + qiden = + char_ '"' *> (failEmptyIden '"' <|> fstMatch moreQIden <* char_ '"') + moreQIden = + label "\"" + (takeWhileP_ Nothing (/='"') + *> hoptional_ (chunk "\"\"" *> moreQIden)) + +identifierString :: Parser Text +identifierString = label "identifier" $ do + c <- satisfy isFirstLetter + choice + [T.cons c <$> takeWhileP Nothing isIdentifierChar + ,pure $ T.singleton c] + where + isFirstLetter c = c == '_' || isAlpha c + +isIdentifierChar :: Char -> Bool +isIdentifierChar c = c == '_' || isAlphaNum c + +-------------------------------------- + +lineComment :: Dialect -> Parser Token +lineComment _ = LineComment <$> fstMatch (do + hidden (string_ "--") + takeWhileP_ Nothing (/='\n') + -- can you optionally read the \n to terminate the takewhilep without reparsing it? + hoptional_ $ char_ '\n') + +-------------------------------------- + +-- TODO: the parser before the switch to megaparsec parsed nested block comments +-- I don't know any dialects that use this, but I think it's useful, if needed, +-- add it back in under a dialect flag? +blockComment :: Dialect -> Parser Token +blockComment _ = BlockComment <$> fstMatch bc + where + bc = chunk_ "/*" *> moreBlockChars + regularBlockCommentChars = label "*/" $ + takeWhileP_ Nothing (\x -> x /= '*' && x /= '/') + continueBlockComment = label "*/" (char_ '*' <|> char_ '/') *> moreBlockChars + endComment = label "*/" $ chunk_ "*/" + moreBlockChars = label "*/" $ + regularBlockCommentChars + *> (endComment + <|> (label "*/" bc *> moreBlockChars) -- nest + <|> continueBlockComment) + +{- +This is to improve user experience: provide an error if we see */ +outside a comment. This could potentially break postgres ops with */ +in them (it is not sensible to use operators that contain this as a +substring). In other cases, the user should write * / instead (I can't +think of any cases when this would be valid syntax). +-} + +dontParseEndBlockComment :: Dialect -> Parser Token +dontParseEndBlockComment _ = + failOnThis (chunk_ "*/") "comment end without comment start" + +-------------------------------------- + +{- +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. + + +algorithm: +either + parse 1 or more digits + then an optional dot which isn't two dots + then optional digits + or: parse a dot which isn't two dots + then digits +followed by an optional exponent +-} + +sqlNumber :: Dialect -> Parser Token +sqlNumber d = + SqlNumber <$> fstMatch + ((numStartingWithDigits <|> numStartingWithDot) + *> hoptional_ expo *> trailingCheck) + where + numStartingWithDigits = digits_ *> hoptional_ (safeDot *> hoptional_ digits_) + -- use try, so we don't commit to a number when there's a . with no following digit + numStartingWithDot = try (safeDot *> digits_) + expo = (char_ 'e' <|> char_ 'E') *> optional_ (char_ '-' <|> char_ '+') *> digits_ + digits_ = label "digits" $ takeWhile1P_ Nothing isDigit + -- if there's a '..' next to the number, and it's a dialect that has .. as a + -- lexical token, parse what we have so far and leave the dots in the chamber + -- otherwise, give an error + safeDot = + if diPostgresSymbols d + then try (char_ '.' <* notFollowedBy (char_ '.')) + else char_ '.' <* notFollowedBy (char_ '.') + -- additional check to give an error if the number is immediately + -- followed by e, E or . with an exception for .. if this symbol is supported + trailingCheck = + if diPostgresSymbols d + then -- special case to allow e.g. 1..2 + void (lookAhead $ hidden $ chunk_ "..") + <|> void (notFollowedBy (oneOf "eE.")) + else notFollowedBy (oneOf "eE.") + +digits :: Parser Text +digits = label "digits" $ takeWhile1P Nothing isDigit + +-------------------------------------- + +positionalArg :: Dialect -> Parser Token +positionalArg d = + -- use try to avoid ambiguities with other syntax which starts with dollar + choice [PositionalArg <$> + try (char_ '$' *> (read . T.unpack <$> digits)) | diPositionalArg d] + +-------------------------------------- + +-- todo: I think the try here should read a prefix char, then a single valid +-- identifier char, then commit +prefixedVariable :: Dialect -> Parser Token +prefixedVariable d = try $ choice $ + [PrefixedVariable <$> char ':' <*> identifierString] + ++ [PrefixedVariable <$> char '@' <*> identifierString | diAtIdentifier d] + ++ [PrefixedVariable <$> char '#' <*> identifierString | diHashIdentifier d] + +-------------------------------------- + +{- +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 diPostgresSymbols d + then postgresExtraSymbols + else [] + ,miscSymbol + ,if diOdbc d then odbcSymbol else [] + ,if diPostgresSymbols d + then generalizedPostgresqlOperator + else basicAnsiOps + ]) + where + dots = [takeWhile1P Nothing (=='.')] + odbcSymbol = [string "{", string "}"] + postgresExtraSymbols = + [try (string ":=") + -- parse :: and : and avoid allowing ::: or more + ,try (string "::" <* notFollowedBy (char ':')) + ,try (string ":" <* notFollowedBy (char ':'))] + miscSymbol = map (string . T.singleton) $ + case () of + _ | diSqlServerSymbols d -> ",;():?" + | diPostgresSymbols d -> "[],;()" + | otherwise -> "[],;():?" + +{- +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 . T.singleton) "+-^*/%~&<>=" + ++ 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 '|') + ,pure "|"]] + +{- +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 Text] +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 + pure $ T.singleton 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 (`notElemChar` "-/*") 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 '/')) + T.cons c <$> option "" moreOpCharsException + + opMoreChars = choice + [-- parse an exception char, now we can finish with a + - + T.cons + <$> oneOf exceptionOpSymbols + <*> option "" moreOpCharsException + ,T.cons + <$> (-- 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 <$> takeWhile1P Nothing isSpace + +---------------------------------------------------------------------------- + +-- parser helpers + +char_ :: Char -> Parser () +char_ = void . char + +hchar_ :: Char -> Parser () +hchar_ = void . hidden . char + +string_ :: Text -> Parser () +string_ = void . string + +oneOf :: [Char] -> Parser Char +oneOf = M.oneOf + +notElemChar :: Char -> [Char] -> Bool +notElemChar a b = a `notElem` (b :: [Char]) + +fstMatch :: Parser () -> Parser Text +fstMatch x = fst <$> match x + +hoptional_ :: Parser a -> Parser () +hoptional_ = void . hoptional + +hoptional :: Parser a -> Parser (Maybe a) +hoptional = hidden . optional + +optional_ :: Parser a -> Parser () +optional_ = void . optional + +--hoption :: a -> Parser a -> Parser a +--hoption a p = hidden $ option a p + +takeWhileP_ :: Maybe String -> (Char -> Bool) -> Parser () +takeWhileP_ m p = void $ takeWhileP m p + +takeWhile1P_ :: Maybe String -> (Char -> Bool) -> Parser () +takeWhile1P_ m p = void $ takeWhile1P m p + +chunk_ :: Text -> Parser () +chunk_ = void . chunk + +hchunk_ :: Text -> Parser () +hchunk_ = void . hidden . chunk + +failOnThis :: Parser () -> Text -> Parser a +failOnThis p msg = do + o <- getOffset + hidden p + region (setErrorOffset o) $ fail $ T.unpack msg + +---------------------------------------------------------------------------- + + +{- +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 `T.elem` ":=") = False + +{- +two symbols next to eachother will fail if the symbols can combine and +(possibly just the prefix) look like a different symbol +-} + + | diPostgresSymbols d + , Symbol a' <- a + , Symbol b' <- b + , b' `notElem` ["+", "-"] || any (`T.elem` a') ("~!@#%^&|`?" :: [Char]) = 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 = + case (T.unsnoc prettya, T.uncons prettyb) of + (Just (_,la), Just (fb,_)) -> f la fb + _ -> False + checkFirstBChar f = case T.uncons prettyb of + Just (b',_) -> f b' + _ -> False + checkLastAChar f = case T.unsnoc prettya of + Just (_,la) -> f la + _ -> False + +------------------------------------------------------------------------------ + +-- megaparsec stream boilerplate + +-- | Wrapper to allow using the lexer as input to a megaparsec parser. +data SQLStream = SQLStream + { sqlStreamInput :: String + , unSQLStream :: [WithPos Token] + } + +instance M.Stream SQLStream where + type Token SQLStream = WithPos Token + type Tokens SQLStream = [WithPos Token] + + tokenToChunk Proxy x = [x] + tokensToChunk Proxy xs = xs + chunkToTokens Proxy = id + chunkLength Proxy = length + chunkEmpty Proxy = null + take1_ (SQLStream _ []) = Nothing + take1_ (SQLStream str (t:ts)) = Just + ( t + , SQLStream (drop (tokensLength pxy (t NE.:|[])) str) ts + ) + takeN_ n (SQLStream str s) + | n <= 0 = Just ([], SQLStream str s) + | null s = Nothing + | otherwise = + let (x, s') = splitAt n s + in case NE.nonEmpty x of + Nothing -> Just (x, SQLStream str s') + Just nex -> Just (x, SQLStream (drop (tokensLength pxy nex) str) s') + takeWhile_ f (SQLStream str s) = + let (x, s') = DL.span f s + in case NE.nonEmpty x of + Nothing -> (x, SQLStream str s') + Just nex -> (x, SQLStream (drop (tokensLength pxy nex) str) s') + +instance VisualStream SQLStream where + showTokens Proxy = DL.intercalate " " + . NE.toList + . fmap (showMyToken . tokenVal) + tokensLength Proxy xs = sum (tokenLength <$> xs) + +instance TraversableStream SQLStream where + -- I have no idea what all this is doing + reachOffset o _x@(M.PosState {..}) = + ( Just $ actualLine + , PosState + { pstateInput = SQLStream + { sqlStreamInput = postStr + , unSQLStream = post + } + , pstateOffset = max pstateOffset o + , pstateSourcePos = newSourcePos + , pstateTabWidth = pstateTabWidth + , pstateLinePrefix = prefix + } + ) + where + maybeitsthefullsource = sqlStreamInput pstateInput + targetLineNo = M.unPos $ sourceLine newSourcePos + actualLine = case drop (targetLineNo - 1) $ lines maybeitsthefullsource of + (x:_) -> x + [] -> "" + prefix = + if sameLine + then pstateLinePrefix ++ preLine + else preLine + sameLine = sourceLine newSourcePos == sourceLine pstateSourcePos + newSourcePos = + case post of + [] -> case unSQLStream pstateInput of + [] -> pstateSourcePos + xs -> endPos (last xs) + (x:_) -> startPos x + (pre, post) = splitAt (o - pstateOffset) (unSQLStream pstateInput) + (preStr, postStr) = splitAt tokensConsumed (sqlStreamInput pstateInput) + preLine = reverse . takeWhile (/= '\n') . reverse $ preStr + tokensConsumed = + case NE.nonEmpty pre of + Nothing -> 0 + Just nePre -> tokensLength pxy nePre + +pxy :: Proxy SQLStream +pxy = Proxy + +showMyToken :: Token -> String +-- todo: how to do this properly? +showMyToken = T.unpack . prettyToken ansi2011 diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Parse.hs @@ -0,0 +1,2487 @@ + +{- += 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.hs, 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 #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This is the module with the parser functions. +module Language.SQL.SimpleSQL.Parse + (parseQueryExpr + ,parseScalarExpr + ,parseStatement + ,parseStatements + ,ParseError(..) + ,prettyError + ,ansi2011 + ) where + +import Text.Megaparsec + (ParsecT + ,runParserT + + ,ParseErrorBundle(..) + ,errorBundlePretty + ,hidden + ,failure + ,ErrorItem(..) + + ,(<|>) + ,token + ,choice + ,eof + ,try + ,sepBy + ,sepBy1 + ,optional + ,option + ,some + ,many + ,between + ,lookAhead + ) +import qualified Control.Monad.Combinators.Expr as E +import qualified Control.Monad.Permutations as P +import qualified Text.Megaparsec as M + +import Control.Monad.Reader + (Reader + ,runReader + ,ask + ,asks + ) + +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NE +import Data.Void (Void) + +import Control.Monad (guard, void) +import Control.Applicative ((<**>)) +import Data.Char (isDigit) +import Data.List (sort,groupBy) +import Data.Function (on) +import Data.Maybe (catMaybes, isJust, mapMaybe, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.Dialect +import qualified Language.SQL.SimpleSQL.Lex as L +--import Text.Megaparsec.Debug (dbg) +import Text.Read (readMaybe) + +------------------------------------------------------------------------------ + +-- = Public API + +-- | Parses a query expr, trailing semicolon optional. +parseQueryExpr + :: Dialect + -- ^ dialect of SQL to use + -> Text + -- ^ 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 + -> Text + -- ^ the SQL source to parse + -> Either ParseError QueryExpr +parseQueryExpr = wrapParse topLevelQueryExpr + +-- | Parses a statement, trailing semicolon optional. +parseStatement + :: Dialect + -- ^ dialect of SQL to use + -> Text + -- ^ 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 + -> Text + -- ^ 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 + -> Text + -- ^ 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 + -> Text + -- ^ the SQL source to parse + -> Either ParseError [Statement] +parseStatements = wrapParse statements + +-- | Parses a scalar expression. +parseScalarExpr + :: Dialect + -- ^ dialect of SQL to use + -> Text + -- ^ 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 + -> Text + -- ^ the SQL source to parse + -> Either ParseError ScalarExpr +parseScalarExpr = wrapParse scalarExpr + +-- Megaparsec is too clever, so have to create a new type to represent +-- either a lex error or a parse error + +data ParseError + = LexError L.ParseError + | ParseError (ParseErrorBundle L.SQLStream Void) + +prettyError :: ParseError -> Text +prettyError (LexError e) = T.pack $ errorBundlePretty e +prettyError (ParseError e) = T.pack $ errorBundlePretty e + +{- +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 + -> Text + -> Maybe (Int,Int) + -> Text + -> Either ParseError a +wrapParse parser d f p src = do + lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d True f p src + either (Left . ParseError) Right $ + runReader (runParserT (parser <* (hidden eof)) (T.unpack f) + $ L.SQLStream (T.unpack src) $ filter notSpace lx) d + where + notSpace = notSpace' . L.tokenVal + notSpace' (L.Whitespace {}) = False + notSpace' (L.LineComment {}) = False + notSpace' (L.BlockComment {}) = False + notSpace' _ = True + +------------------------------------------------------------------------------ + +-- parsing code + +type Parser = ParsecT Void L.SQLStream (Reader Dialect) + +{- +------------------------------------------------ + += 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 :: Text -> Parser Name +name lbl = label lbl $ do + bl <- askDialect diKeywords + uncurry Name <$> identifierTok bl + +-- todo: replace (:[]) with a named function all over + +names :: Text -> Parser [Name] +names lbl = + label lbl (reverse <$> (((:[]) <$> name lbl) `chainrSuffix` 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 ((:) <$> (hidden (symbol "." *> name lbl))) + +{- += 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. + +the hideArg is used when the typename is used as part of a typed +literal expression, to hide what comes after the paren in +'typename('. This is so 'arbitrary_fn(' gives an 'expecting expression', +instead of 'expecting expression or number', which is odd. + +-} + +typeName :: Parser TypeName +typeName = typeName' False + +typeName' :: Bool -> Parser TypeName +typeName' hideArg = + label "typename" ( + (rowTypeName <|> intervalTypeName <|> otherTypeName) + `chainrSuffix` tnSuffix) + where + rowTypeName = + RowTypeName <$> (hidden (keyword_ "row") *> parens (commaSep1 rowField)) + rowField = (,) <$> name "type name" <*> typeName + ---------------------------- + intervalTypeName = + hidden (keyword_ "interval") *> + (uncurry IntervalTypeName <$> intervalQualifier) + ---------------------------- + otherTypeName = + nameOfType <**> + (typeNameWithParens + <|> pure Nothing <**> (hidden timeTypeName <|> hidden charTypeName) + <|> pure TypeName) + nameOfType = reservedTypeNames <|> names "type name" + charTypeName = charSet <**> (option [] tcollate <**> pure (flip4 CharTypeName)) + <|> pure [] <**> (tcollate <**> pure (flip4 CharTypeName)) + typeNameWithParens = + (hidden openParen *> (if hideArg then hidden unsignedInteger else unsignedInteger)) + <**> (closeParen *> hidden precMaybeSuffix + <|> hidden (precScaleTypeName <|> precLengthTypeName) <* closeParen) + precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName) + <|> pure (flip PrecTypeName) + precScaleTypeName = + (hidden comma *> (if hideArg then hidden unsignedInteger else unsignedInteger)) + <**> pure (flip3 PrecScaleTypeName) + precLengthTypeName = + Just <$> lobPrecSuffix + <**> (optional lobUnits <**> pure (flip4 PrecLengthTypeName)) + <|> pure Nothing <**> ((Just <$> lobUnits) <**> pure (flip4 PrecLengthTypeName)) + timeTypeName = tz <**> pure (flip3 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 "character set name" + tcollate = keyword_ "collate" *> names "collation name" + ---------------------------- + tnSuffix = multiset <|> array + multiset = MultisetTypeName <$ keyword_ "multiset" + array = keyword_ "array" *> + (optional (brackets unsignedInteger) <**> pure (flip ArrayTypeName)) + ---------------------------- + -- this parser handles the fixed set of multi word + -- type names, plus all the type names which are + -- reserved words + reservedTypeNames = do + stn <- askDialect diSpecialTypeNames + (:[]) . Name Nothing . T.unwords <$> makeKeywordTree stn + + +{- += 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 makes an attempt to not parse star in +most contexts, to provide better experience when the user makes a mistake +in an expression containing * meaning multiple. It will parse a * +at the top level of a select item, or in arg in a app argument list. +-} + +star :: Parser ScalarExpr +star = + hidden $ choice + [Star <$ symbol "*" + -- much easier to use try here than to left factor where + -- this is allowed and not allowed + ,try (QStar <$> (names "qualified star" <* symbol "." <* 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 + <*> hoptional (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 + -- no parens here used for nested parens expressions + -- this could be fixed to be general with some refactoring, but at + -- the moment, you can't use additional redundant parens in a + -- subqueryexpr + [SubQueryExpr SqSq <$> queryExprNoParens + ,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" *> optional scalarExpr) + <*> some whenClause + <*> optional 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)) + +{- +=== convert + +convertSqlServer: SqlServer dialect CONVERT(data_type(length), expression, style) +-} + +convertSqlServer :: Parser ScalarExpr +convertSqlServer = guardDialect diConvertFunction + *> keyword_ "convert" *> + parens (Convert <$> typeName <*> (comma *> scalarExpr) + <*> optional (comma *> unsignedInteger)) + +{- +=== 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 "sequence generator name" + +{- +=== 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 = + label "interval literal" $ try (keyword_ "interval" >> do + s <- hoptional $ choice [Plus <$ symbol_ "+" + ,Minus <$ symbol_ "-"] + lit <- singleQuotesOnlyStringTok + q <- hoptional 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: try reversing these + -- then if it parses as a typename as part of a typed literal + -- and not a regularapplike, then you'll get a better error message + try typedLiteral <|> regularAppLike + where + -- parse regular iden or app + -- if it could potentially be a typed literal typename 'literaltext' + -- optionally try to parse that + regularAppLike = do + e <- (keywordFunctionOrIden + <|> (names "identifier" <**> (hidden app <|> pure Iden))) + let getInt s = readMaybe (T.unpack s) + case e of + Iden nm -> tryTypedLiteral (TypeName nm) <|> pure e + App nm [NumLit prec] + | Just prec' <- getInt prec -> + tryTypedLiteral (PrecTypeName nm prec') <|> pure e + App nm [NumLit prec,NumLit scale] + | Just prec' <- getInt prec + , Just scale' <- getInt scale -> + tryTypedLiteral (PrecScaleTypeName nm prec' scale') <|> pure e + _ -> pure e + tryTypedLiteral tn = + TypedLit tn <$> hidden singleQuotesOnlyStringTok + typedLiteral = + TypedLit <$> hidden (typeName' True) <*> singleQuotesOnlyStringTok + keywordFunctionOrIden = do + d <- askDialect id + x <- hidden (keywordTok (diIdentifierKeywords d ++ diAppKeywords d)) + let i = T.toLower x `elem` diIdentifierKeywords d + a = T.toLower x `elem` diAppKeywords d + case () of + _ | i && a -> pure [Name Nothing x] <**> (hidden app <|> pure Iden) + | i -> pure (Iden [Name Nothing x]) + | a -> pure [Name Nothing x] <**> app + | otherwise -> -- shouldn't get here + fail $ "unexpected keyword: " <> T.unpack x + +{- +=== 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 :: Text -- name of the operator + -> SpecialOpKFirstArg -- has a first arg without a keyword + -> [(Text,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,_):_) + | T.toLower i == k -> + fail $ "unexpected " ++ T.unpack i + _ -> pure () + pure e + fa <- case firstArg of + SOKNone -> pure Nothing + SOKOptional -> optional (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 optional (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 = + hidden openParen *> choice + [hidden duplicates + <**> (commaSep1 scalarExprOrStar + <**> ((hoption [] orderBy <* closeParen) + <**> (hoptional afilter <**> pure (flip5 AggregateApp)))) + -- separate cases with no all or distinct which must have at + -- least one scalar expr + ,commaSep1 scalarExprOrStar + <**> choice + [closeParen *> hidden (choice + [window + ,withinGroup + ,(Just <$> afilter) <**> pure (flip3 aggAppWithoutDupeOrd) + ,pure (flip App)]) + ,hidden orderBy <* closeParen + <**> (hoptional afilter <**> pure (flip4 aggAppWithoutDupe))] + -- no scalarExprs: duplicates and order by not allowed + ,([] <$ closeParen) <**> choice + [window + ,withinGroup + ,pure $ flip App] + ] + 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) <**> pure (flip3 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 + <**> ((optional frameClause <* closeParen) <**> pure (flip5 WindowApp))) + where + partitionBy = + label "partition by" $ + keywords_ ["partition","by"] *> commaSep1 scalarExpr + frameClause = + label "frame clause" $ + frameRowsRange -- TODO: this 'and' could be an issue + <**> choice [(keyword_ "between" *> frameLimit True) + <**> ((keyword_ "and" *> frameLimit True) + <**> pure (flip3 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'] -> pure c' + _ -> fail "escape char must be single char" +-} + +-- === collate + +collateSuffix:: Parser (ScalarExpr -> ScalarExpr) +collateSuffix = do + keyword_ "collate" + i <- names "collation name" + 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 = + braces (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 Parser ScalarExpr]] +opTable bExpr = + [-- parse match and quantified comparisons as postfix ops + -- todo: left factor the quantified comparison with regular + -- binary comparison, somehow + [postfix $ try quantifiedComparisonSuffix + ,postfix matchPredicateSuffix] + + ,[binarySymL "."] + + ,[postfix arraySuffix + ,postfix collateSuffix] + + ,[prefixSym "+", prefixSym "-"] + + ,[binarySymL "^"] + + ,[binarySymL "*" + ,binarySymL "/" + ,binarySymL "%"] + + ,[binarySymL "+" + ,binarySymL "-"] + + ,[binarySymR "||" + ,prefixSym "~" + ,binarySymR "&" + ,binarySymR "|"] + + ,[binaryKeywordN "overlaps"] + + ,[binaryKeywordN "like" + -- 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 + ,postfix $ try inSuffix + ,postfix betweenSuffix] + -- todo: figure out where to put the try? + ++ [binaryKeywordsN $ makeKeywordTree + ["not like" + ,"is similar to" + ,"is not similar to"]] + ++ [multisetBinOp] + + ,[binarySymN "<" + ,binarySymN ">" + ,binarySymN ">=" + ,binarySymN "<=" + ,binarySymR "!=" + ,binarySymR "<>" + ,binarySymR "="] + + ,[postfixKeywords $ makeKeywordTree + ["is null" + ,"is not null" + ,"is true" + ,"is not true" + ,"is false" + ,"is not false" + ,"is unknown" + ,"is not unknown"]] + ++ [binaryKeywordsN $ makeKeywordTree + ["is distinct from" + ,"is not distinct from"]] + + ,[prefixKeyword "not"] + + ,[binaryKeywordL "and" | not bExpr] + + ,[binaryKeywordL "or"] + + ] + where + binarySymL nm = E.InfixL (hidden $ mkBinOp nm <$ symbol_ nm) + binarySymR nm = E.InfixR (hidden $ mkBinOp nm <$ symbol_ nm) + binarySymN nm = E.InfixN (hidden $ mkBinOp nm <$ symbol_ nm) + binaryKeywordN nm = E.InfixN (hidden $ mkBinOp nm <$ keyword_ nm) + binaryKeywordL nm = E.InfixL (hidden $ mkBinOp nm <$ keyword_ nm) + mkBinOp nm a b = BinOp a (mkNm nm) b + prefixSym nm = prefix (hidden $ PrefixOp (mkNm nm) <$ symbol_ nm) + prefixKeyword nm = prefix (hidden $ PrefixOp (mkNm nm) <$ keyword_ nm) + mkNm nm = [Name Nothing nm] + binaryKeywordsN p = + E.InfixN (hidden $ do + o <- try p + pure (\a b -> BinOp a [Name Nothing $ T.unwords o] b)) + multisetBinOp = E.InfixL (hidden $ do + keyword_ "multiset" + o <- choice [Union <$ keyword_ "union" + ,Intersect <$ keyword_ "intersect" + ,Except <$ keyword_ "except"] + d <- hoption SQDefault duplicates + pure (\a b -> MultisetBinOp a o d b)) + postfixKeywords p = + postfix $ hidden $ do + o <- try p + pure $ PostfixOp [Name Nothing $ T.unwords o] + -- parse repeated prefix or postfix operators + postfix p = E.Postfix $ foldr1 (flip (.)) <$> some (hidden p) + prefix p = E.Prefix $ foldr1 (.) <$> some (hidden p) + +{- +== 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 = expressionLabel $ E.makeExprParser term (opTable False) + +-- used when parsing contexts where a * or x.* is allowed +-- currently at the top level of a select item or top level of +-- argument passed to an app-like. This list may need to be extended. + +scalarExprOrStar :: Parser ScalarExpr +scalarExprOrStar = star <|> scalarExpr + +-- use this to get a nice unexpected keyword error which doesn't also +-- mangle other errors +expressionLabel :: Parser a -> Parser a +expressionLabel p = label "expression" p <|> failOnKeyword + +term :: Parser ScalarExpr +term = expressionLabel $ + choice + [simpleLiteral + ,parameter + ,positionalArg + ,parensExpr + ,caseExpr + ,cast + ,convertSqlServer + ,arrayCtor + ,multisetCtor + ,nextValueFor + ,subquery + ,intervalLit + ,specialOpKs + ,idenExpr + ,odbcExpr] + +-- expose the b expression for window frame clause range between + +scalarExprB :: Parser ScalarExpr +scalarExprB = label "expression" $ E.makeExprParser term (opTable True) + +{- +== helper parsers + +This is used in interval literals and in interval type names. +-} + +intervalQualifier :: Parser (IntervalTypeField,Maybe IntervalTypeField) +intervalQualifier = + (,) <$> intervalField + <*> optional (keyword_ "to" *> intervalField) + where + intervalField = + Itf + <$> datetimeField + <*> optional + (parens ((,) <$> unsignedInteger + <*> optional (comma *> unsignedInteger))) + +{- +TODO: use datetime field in extract also +use a data type for the datetime field? +-} + +datetimeField :: Parser Text +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 = + label "select item" $ choice + [(,Nothing) <$> star + ,(,) <$> scalarExpr <*> optional als] + where + als = label "alias" $ optional (keyword_ "as") *> name "alias" + +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 = label "from" (keyword_ "from" *> commaSep1 tref) + where + tref = nonJoinTref <**> (hidden (chainl tjoin) <|> pure id) + nonJoinTref = + label "table ref" $ choice + [hidden $ parens $ choice + -- will be tricky to figure out how to support mixes of nested + -- query expr parens and table ref parens + [TRQueryExpr <$> queryExprNoParens + ,TRParens <$> tref] + ,TRLateral <$> (hidden (keyword_ "lateral") *> nonJoinTref) + ,do + n <- names "table name" + choice [TRFunction n <$> hidden (parens (commaSep scalarExpr)) + ,pure $ TRSimple n] + -- todo: I think you can only have outer joins inside the oj, + -- not sure. + ,TROdbc <$> (hidden (braces (keyword_ "oj" *> tref))) + ] <**> (talias <|> pure id) + talias = fromAlias <**> pure (flip TRAlias) + tjoin = + (\jn jt tr1 jc tr0 -> TRJoin tr0 jn jt tr1 jc) + <$> option False (True <$ keyword_ "natural") + <*> joinType + <*> nonJoinTref + <*> hoptional joinCondition + chainl p = foldr (.) id . reverse <$> some p + + +{- +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 "column name"))] + +fromAlias :: Parser Alias +fromAlias = Alias <$> tableAlias <*> columnAliases + where + tableAlias = hoptional (keyword_ "as") *> name "alias" + columnAliases = hoptional $ parens $ commaSep1 (name "column name") + +{- +== simple other parts + +Parsers for where, group by, having, order by and limit, which are +pretty trivial. +-} + +whereClause :: Parser ScalarExpr +whereClause = label "where" (keyword_ "where" *> scalarExpr) + +groupByClause :: Parser [GroupingExpr] +groupByClause = + label "group by" (keywords_ ["group","by"] *> commaSep1 groupingExpression) + where + groupingExpression = + label "grouping expression" $ + 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 = label "having" (keyword_ "having" *> scalarExpr) + +orderBy :: Parser [SortSpec] +orderBy = label "order by" (keywords_ ["order","by"] *> commaSep1 ob) + where + ob = SortSpec + <$> scalarExpr + <*> hoption DirDefault (choice [Asc <$ keyword_ "asc" + ,Desc <$ keyword_ "desc"]) + <*> hoption 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 = + P.runPermutation $ (,) <$> maybePermutation offset <*> maybePermutation fetch + where + maybePermutation p = P.toPermutationWithDefault Nothing (Just <$> p) + +offset :: Parser ScalarExpr +offset = label "offset" (keyword_ "offset" *> scalarExpr + <* option () (choice [keyword_ "rows" + ,keyword_ "row"])) + +fetch :: Parser ScalarExpr +fetch = fetchFirst <|> limit + where + fetchFirst = guardDialect diFetchFirst + *> fs *> scalarExpr <* ro + fs = makeKeywordTree ["fetch first", "fetch next"] + ro = makeKeywordTree ["rows only", "row only"] + -- todo: not in ansi sql dialect + limit = guardDialect diLimit *> + keyword_ "limit" *> scalarExpr + +-- == common table expressions + +with :: Parser QueryExpr +with = keyword_ "with" >> + With <$> hoption False (True <$ keyword_ "recursive") + <*> commaSep1 withQuery <*> queryExpr + where + withQuery = (,) <$> (withAlias <* keyword_ "as") + <*> parens queryExpr + withAlias = Alias <$> name "alias" <*> columnAliases + columnAliases = hoptional $ parens $ commaSep1 (name "column alias") + + +{- +== query expression + +This parser parses any query expression variant: normal select, cte, +and union, etc.. +-} + +queryExpr :: Parser QueryExpr +queryExpr = queryExpr' True +queryExprNoParens :: Parser QueryExpr +queryExprNoParens = queryExpr' False + +queryExpr' :: Bool -> Parser QueryExpr +queryExpr' allowParens = label "query expr" $ E.makeExprParser qeterm qeOpTable + where + qeterm + | allowParens = + label "query expr" (with <|> select <|> table <|> values <|> qeParens) + | otherwise = + label "query expr" (with <|> select <|> table <|> values) + + select = keyword_ "select" >> + mkSelect + <$> hoption SQDefault duplicates + <*> selectList + <*> optional tableExpression + mkSelect d sl Nothing = + toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = 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 "table name" + qeParens = QueryExprParens <$> parens queryExpr + + qeOpTable = + [[E.InfixL $ setOp Intersect "intersect"] + ,[E.InfixL $ setOp Except "except" + ,E.InfixL $ setOp Union "union"]] + setOp :: SetOperatorName -> Text -> Parser (QueryExpr -> QueryExpr -> QueryExpr) + setOp ctor opName = hidden (cq + <$> (ctor <$ keyword_ opName) + <*> hoption SQDefault duplicates + <*> corr) + cq o d c q0 q1 = QueryExprSetOp q0 o d c q1 + corr = hoption Respectively (Corresponding <$ keyword_ "corresponding") + + +{- +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 = + label "from" $ + mkTe + <$> from + <*> optional whereClause + <*> option [] groupByClause + <*> optional having + <*> option [] orderBy + <*> (hidden offsetFetch) + where + mkTe f w g h od (ofs,fe) = + TableExpression f w g h od ofs fe + +{- +wrapper for query expr which ignores optional trailing semicolon. + +TODO: change style +-} + +topLevelQueryExpr :: Parser QueryExpr +topLevelQueryExpr = queryExpr (id <$ semi) + +topLevelStatement :: Parser Statement +topLevelStatement = statement + +{- +------------------------- + += Statements +-} + +statementWithoutSemicolon :: Parser Statement +statementWithoutSemicolon = + label "statement" $ choice + [keyword_ "create" *> choice [createSchema + ,createTable + ,createIndex + ,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 + ] + +statement :: Parser Statement +statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ hidden semi + +createSchema :: Parser Statement +createSchema = keyword_ "schema" >> + CreateSchema <$> names "schema name" + +createTable :: Parser Statement +createTable = do + d <- askDialect id + let + parseColumnDef = TableColumnDef <$> columnDef + parseConstraintDef = uncurry TableConstraintDef <$> tableConstraintDef + separator = if diNonCommaSeparatedConstraints d + then optional comma + else Just <$> comma + constraints = sepBy parseConstraintDef (hidden separator) + entries = ((:) <$> parseColumnDef <*> ((comma >> entries) <|> pure [])) <|> constraints + withoutRowid = if diWithoutRowidTables d + then fromMaybe False <$> optional (keywords_ ["without", "rowid"] >> pure True) + else pure False + + keyword_ "table" >> + CreateTable + <$> names "table name" + <*> parens entries + <*> withoutRowid + +createIndex :: Parser Statement +createIndex = + CreateIndex + <$> ((keyword_ "index" >> pure False) <|> + (keywords_ ["unique", "index"] >> pure True)) + <*> names "index name" + <*> (keyword_ "on" >> names "table name") + <*> parens (commaSep1 (name "column name")) + +columnDef :: Parser ColumnDef +columnDef = do + optionalType <- askDialect diOptionalColumnTypes + ColumnDef <$> name "column name" + <*> (if optionalType then optional typeName else Just <$> typeName) + <*> option [] (some colConstraintDef) + +tableConstraintDef :: Parser (Maybe [Name], TableConstraint) +tableConstraintDef = + label "table constraint" $ + (,) + <$> optional (keyword_ "constraint" *> names "constraint name") + <*> (unique <|> primaryKey <|> check <|> references) + where + unique = keyword_ "unique" >> + TableUniqueConstraint <$> parens (commaSep1 $ name "column name") + primaryKey = keywords_ ["primary", "key"] >> + TablePrimaryKeyConstraint <$> parens (commaSep1 $ name "column 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 "column name") + <*> (keyword_ "references" *> names "table name") + <*> hoptional (parens $ commaSep1 $ name "column name") + <*> refMatch + <*> refActions + +refMatch :: Parser ReferenceMatch +refMatch = hoption DefaultReferenceMatch + (keyword_ "match" *> + choice [MatchFull <$ keyword_ "full" + ,MatchPartial <$ keyword_ "partial" + ,MatchSimple <$ keyword_ "simple"]) +refActions :: Parser (ReferentialAction,ReferentialAction) +refActions = + P.runPermutation $ (,) + <$> P.toPermutationWithDefault DefaultReferentialAction onUpdate + <*> P.toPermutationWithDefault 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 + <$> optional (keyword_ "constraint" *> names "constraint name") + <*> (nullable + <|> notNull + <|> unique + <|> primaryKey + <|> check + <|> references + <|> defaultClause + ) + where + nullable = ColNullableConstraint <$ keyword "null" + notNull = ColNotNullConstraint <$ keywords_ ["not", "null"] + unique = ColUniqueConstraint <$ keyword_ "unique" + primaryKey = do + keywords_ ["primary", "key"] + d <- askDialect id + autoincrement <- if diAutoincrement d + then optional (keyword_ "autoincrement") + else pure Nothing + pure $ ColPrimaryKeyConstraint $ isJust autoincrement + check = keyword_ "check" >> ColCheckConstraint <$> parens scalarExpr + references = keyword_ "references" >> + (\t c m (ou,od) -> ColReferencesConstraint t c m ou od) + <$> names "table name" + <*> optional (parens $ name "column name") + <*> refMatch + <*> refActions + defaultClause = label "column default clause" $ + ColDefaultClause <$> 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)) + ] + +-- 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 + P.runPermutation ((\a b c d e f g h j k -> catMaybes [a,b,c,d,e,f,g,h,j,k]) + <$> maybePermutation startWith + <*> maybePermutation dataType + <*> maybePermutation restart + <*> maybePermutation incrementBy + <*> maybePermutation maxValue + <*> maybePermutation noMaxValue + <*> maybePermutation minValue + <*> maybePermutation noMinValue + <*> maybePermutation scycle + <*> maybePermutation noCycle + ) + where + maybePermutation p = P.toPermutationWithDefault Nothing (Just <$> p) + startWith = keywords_ ["start", "with"] >> + SGOStartWith <$> signedInteger + dataType = keyword_ "as" >> + SGODataType <$> typeName + restart = keyword_ "restart" >> + SGORestart <$> optional (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 "table name" + <*> choice [addConstraint + ,dropConstraint + ,addColumnDef + ,alterColumn + ,dropColumn + ] + where + addColumnDef = try (keyword_ "add" + *> optional (keyword_ "column")) >> + AddColumnDef <$> columnDef + alterColumn = keyword_ "alter" >> optional (keyword_ "column") >> + name "column name" + <**> choice [setDefault + ,dropDefault + ,setNotNull + ,dropNotNull + ,setDataType] + setDefault :: Parser (Name -> AlterTableAction) + -- todo: left factor + setDefault = try (keywords_ ["set","default"]) >> + scalarExpr <**> pure (flip 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 <**> pure (flip AlterColumnSetDataType) + dropColumn = try (keyword_ "drop" *> optional (keyword_ "column")) >> + DropColumn <$> name "column name" <*> dropBehaviour + -- todo: left factor, this try is especially bad + addConstraint = try (keyword_ "add" >> + uncurry AddTableConstraintDef <$> tableConstraintDef) + dropConstraint = try (keywords_ ["drop","constraint"]) >> + DropTableConstraintDef <$> names "constraint name" <*> dropBehaviour + + +dropSchema :: Parser Statement +dropSchema = keyword_ "schema" >> + DropSchema <$> names "schema name" <*> dropBehaviour + +dropTable :: Parser Statement +dropTable = keyword_ "table" >> + DropTable <$> names "table name" <*> dropBehaviour + +createView :: Parser Statement +createView = + CreateView + <$> (hoption False (True <$ keyword_ "recursive") <* keyword_ "view") + <*> names "view name" + <*> optional (parens (commaSep1 $ name "column name")) + <*> (keyword_ "as" *> queryExpr) + <*> hoptional (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 "view name" <*> dropBehaviour + +createDomain :: Parser Statement +createDomain = keyword_ "domain" >> + CreateDomain + <$> names "domain name" + <*> ((optional (keyword_ "as") *> typeName) "alias") + <*> optional (keyword_ "default" *> scalarExpr) + <*> many con + where + con = (,) <$> optional (keyword_ "constraint" *> names "constraint name") + <*> (keyword_ "check" *> parens scalarExpr) + +alterDomain :: Parser Statement +alterDomain = keyword_ "domain" >> + AlterDomain + <$> names "domain name" + <*> (setDefault <|> constraint + <|> (keyword_ "drop" *> (dropDefault <|> dropConstraint))) + where + setDefault = keywords_ ["set", "default"] >> ADSetDefault <$> scalarExpr + constraint = keyword_ "add" >> + ADAddConstraint + <$> optional (keyword_ "constraint" *> names "constraint name") + <*> (keyword_ "check" *> parens scalarExpr) + dropDefault = ADDropDefault <$ keyword_ "default" + dropConstraint = keyword_ "constraint" >> ADDropConstraint <$> names "constraint name" + +dropDomain :: Parser Statement +dropDomain = keyword_ "domain" >> + DropDomain <$> names "domain name" <*> dropBehaviour + +createSequence :: Parser Statement +createSequence = keyword_ "sequence" >> + CreateSequence + <$> names "sequence name" + <*> sequenceGeneratorOptions + +alterSequence :: Parser Statement +alterSequence = keyword_ "sequence" >> + AlterSequence + <$> names "sequence name" + <*> sequenceGeneratorOptions + +dropSequence :: Parser Statement +dropSequence = keyword_ "sequence" >> + DropSequence <$> names "sequence name" <*> dropBehaviour + +createAssertion :: Parser Statement +createAssertion = keyword_ "assertion" >> + CreateAssertion + <$> names "assertion name" + <*> (keyword_ "check" *> parens scalarExpr) + + +dropAssertion :: Parser Statement +dropAssertion = keyword_ "assertion" >> + DropAssertion <$> names "assertion name" <*> dropBehaviour + +{- +----------------- + += dml +-} + +delete :: Parser Statement +delete = keywords_ ["delete","from"] >> + Delete + <$> names "table name" + <*> optional (hoptional (keyword_ "as") *> name "alias") + <*> optional (keyword_ "where" *> scalarExpr) + +truncateSt :: Parser Statement +truncateSt = keywords_ ["truncate", "table"] >> + Truncate + <$> names "table name" + <*> hoption DefaultIdentityRestart + (ContinueIdentity <$ keywords_ ["continue","identity"] + <|> RestartIdentity <$ keywords_ ["restart","identity"]) + +insert :: Parser Statement +insert = keywords_ ["insert", "into"] >> + Insert + <$> names "table name" + <*> (hoptional (parens $ commaSep1 $ name "column name")) + <*> + -- slight hack + (DefaultInsertValues <$ label "values" (keywords_ ["default", "values"]) + <|> InsertQuery <$> queryExpr) + +update :: Parser Statement +update = keywords_ ["update"] >> + Update + <$> names "table name" + <*> label "alias" (optional (optional (keyword_ "as") *> name "alias")) + <*> (keyword_ "set" *> commaSep1 setClause) + <*> optional (keyword_ "where" *> scalarExpr) + where + setClause = label "set clause" (multipleSet <|> singleSet) + multipleSet = SetMultiple + <$> parens (commaSep1 $ names "column name") + <*> (symbol "=" *> parens (commaSep1 scalarExpr)) + singleSet = Set + <$> names "column name" + <*> (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 "savepoint name" + +releaseSavepoint :: Parser Statement +releaseSavepoint = keywords_ ["release","savepoint"] >> + ReleaseSavepoint <$> name "savepoint name" + +commit :: Parser Statement +commit = Commit <$ keyword_ "commit" <* hoptional (keyword_ "work") + +rollback :: Parser Statement +rollback = keyword_ "rollback" >> hoptional (keyword_ "work") >> + Rollback <$> optional (keywords_ ["to", "savepoint"] *> name "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 "role name")) + <*> option WithoutGrantOption + (WithGrantOption <$ keywords_ ["with","grant","option"]) + role = GrantRole + <$> commaSep (name "role name") + <*> (keyword_ "to" *> commaSep (name "role name")) + <*> option WithoutAdminOption + (WithAdminOption <$ keywords_ ["with","admin","option"]) + +createRole :: Parser Statement +createRole = keyword_ "role" >> + CreateRole <$> name "role name" + +dropRole :: Parser Statement +dropRole = keyword_ "role" >> + DropRole <$> name "role 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 "role name")) + <*> dropBehaviour + role = RevokeRole + <$> option NoAdminOptionFor + (AdminOptionFor <$ keywords_ ["admin","option", "for"]) + <*> commaSep (name "role name") + <*> (keyword_ "from" *> commaSep (name "role name")) + <*> dropBehaviour + +privilegeAction :: Parser PrivilegeAction +privilegeAction = choice + [PrivAll <$ keywords_ ["all","privileges"] + ,keyword_ "select" >> + PrivSelect <$> option [] (parens $ commaSep $ name "column name") + ,PrivDelete <$ keyword_ "delete" + ,PrivUsage <$ keyword_ "usage" + ,PrivTrigger <$ keyword_ "trigger" + ,PrivExecute <$ keyword_ "execute" + ,keyword_ "insert" >> + PrivInsert <$> option [] (parens $ commaSep $ name "column name") + ,keyword_ "update" >> + PrivUpdate <$> option [] (parens $ commaSep $ name "column name") + ,keyword_ "references" >> + PrivReferences <$> option [] (parens $ commaSep $ name "column name") + ] + +privilegeObject :: Parser PrivilegeObject +privilegeObject = choice + [keyword_ "domain" >> PrivDomain <$> names "domain name" + ,keyword_ "type" >> PrivType <$> names "type name" + ,keyword_ "sequence" >> PrivSequence <$> names "sequence name" + ,keywords_ ["specific","function"] >> PrivFunction <$> names "function name" + ,optional (keyword_ "table") >> PrivTable <$> names "table name" + ] + + +{- +---------------------------- + +wrapper to parse a series of statements. They must be separated by +semicolon, but for the last statement, the trailing semicolon is +optional. +-} + +statements :: Parser [Statement] +statements = many statement + +{- +---------------------------------------------- + += 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 :: [Text] -> Parser [Text] +makeKeywordTree sets = + label (T.intercalate ", " sets) $ + parseTrees (sort $ map T.words sets) + where + parseTrees :: [[Text]] -> Parser [Text] + parseTrees ws = do + let gs :: [[[Text]]] + gs = groupBy ((==) `on` safeHead) ws + choice $ map parseGroup gs + parseGroup :: [[Text]] -> Parser [Text] + parseGroup l@((k:_):_) = do + keyword_ k + let tls = mapMaybe safeTail l + pr = (k:) <$> parseTrees tls + if any null tls + then pr <|> pure [k] + else pr + parseGroup _ = guard False >> fail "impossible" + safeHead (x:_) = Just x + safeHead [] = Nothing + safeTail (_:x) = Just x + safeTail [] = Nothing + +------------------------------------------------------------------------------ + +-- parser helpers + +{- +parses an optional postfix element and applies its result to its left +hand result, taken from uu-parsinglib + +TODO: make sure the precedence higher than <|> and lower than the +other operators so it can be used nicely + +TODO: this name is not so good because it's similar to which does +something completely different +-} + +() :: Parser a -> Parser (a -> a) -> Parser a +p q = p <**> hoption id q + +-- 0 to many repeated applications of suffix parser + +chainrSuffix :: Parser a -> Parser (a -> a) -> Parser a +chainrSuffix p q = foldr ($) <$> p <*> (reverse <$> many (hidden q)) + +{- +These are to help with left factored parsers: + +a <**> (b <**> (c <**> pure (flip3 ctor))) + +Not sure the names are correct, but they follow a pattern with flip +a <**> (b <**> pure (flip ctor)) +-} + +flip3 :: (a -> b -> c -> t) -> c -> b -> a -> t +flip3 f a b c = f c b a + +flip4 :: (a -> b -> c -> d -> t) -> d -> c -> b -> a -> t +flip4 f a b c d = f d c b a + +flip5 :: (a -> b -> c -> d -> e -> t) -> e -> d -> c -> b -> a -> t +flip5 f a b c d e = f e d c b a + +-------------------------------------- + +unsignedInteger :: Parser Integer +unsignedInteger = read . T.unpack <$> sqlNumberTok True "natural number" + +-- todo: work out the symbol parsing better + +symbol :: Text -> Parser Text +symbol s = symbolTok (Just s) s + +singleCharSymbol :: Char -> Parser Char +singleCharSymbol c = c <$ symbol (T.singleton c) + +questionMark :: Parser Char +questionMark = singleCharSymbol '?' "question mark" + +openParen :: Parser () +openParen = void $ singleCharSymbol '(' + +closeParen :: Parser () +closeParen = void $ singleCharSymbol ')' + +comma :: Parser Char +comma = singleCharSymbol ',' + +semi :: Parser Char +semi = singleCharSymbol ';' + +-- = helper functions + +keyword :: Text -> Parser Text +keyword k = keywordTok [k] k + +-- helper function to improve error messages + +keywords_ :: [Text] -> Parser () +keywords_ ks = label (T.unwords ks) $ mapM_ keyword_ ks + +parens :: Parser a -> Parser a +parens = between openParen closeParen + +brackets :: Parser a -> Parser a +brackets = between (singleCharSymbol '[') (singleCharSymbol ']') + +braces :: Parser a -> Parser a +braces = between (singleCharSymbol '{') (singleCharSymbol '}') + +commaSep :: Parser a -> Parser [a] +commaSep = (`sepBy` hidden comma) + +keyword_ :: Text -> Parser () +keyword_ = void . keyword + +symbol_ :: Text -> Parser () +symbol_ = void . symbol + +commaSep1 :: Parser a -> Parser [a] +commaSep1 = (`sepBy1` hidden comma) + +hoptional :: Parser a -> Parser (Maybe a) +hoptional = hidden . optional + +hoption :: a -> Parser a -> Parser a +hoption a p = hidden $ option a p + +label :: Text -> Parser a -> Parser a +label x = M.label (T.unpack x) + +() :: Parser a -> Text -> Parser a +() p a = (M.) p (T.unpack a) + +------------------------------------------------------------------------------ + +-- interfacing with the lexing +{- +TODO: push checks into here: +keyword blacklists +unsigned integer match +symbol matching +keyword matching + +-} +stringTok :: Parser (Text,Text,Text) +stringTok = token test Set.empty "string literal" + where + test (L.WithPos _ _ _ (L.SqlString s e t)) = Just (s,e,t) + test _ = Nothing + +singleQuotesOnlyStringTok :: Parser Text +singleQuotesOnlyStringTok = token test Set.empty "string literal" + where + test (L.WithPos _ _ _ (L.SqlString "'" "'" t)) = Just t + test _ = 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. + +TODO: move this to the lexer? +-} + +stringTokExtend :: Parser (Text,Text,Text) +stringTokExtend = do + (s,e,x) <- stringTok + choice [ + do + guard (s == "'" && e == "'") + (s',e',y) <- stringTokExtend + guard (s' == "'" && e' == "'") + pure (s,e,x <> y) + ,pure (s,e,x) + ] + +hostParamTok :: Parser Text +hostParamTok = token test Set.empty "host param" + where + test (L.WithPos _ _ _ (L.PrefixedVariable c p)) = Just $ T.cons c p + test _ = Nothing + +positionalArgTok :: Parser Int +positionalArgTok = token test Set.empty "positional arg" + where + test (L.WithPos _ _ _ (L.PositionalArg p)) = Just p + test _ = Nothing + +sqlNumberTok :: Bool -> Parser Text +sqlNumberTok intOnly = token test Set.empty "number" + where + test (L.WithPos _ _ _ (L.SqlNumber p)) | not intOnly || T.all isDigit p = Just p + test _ = Nothing + +symbolTok :: Maybe Text -> Parser Text +symbolTok sym = token test Set.empty lbl + where + test (L.WithPos _ _ _ (L.Symbol p)) = + case sym of + Nothing -> Just p + Just sym' | sym' == p -> Just p + _ -> Nothing + test _ = Nothing + lbl = case sym of + Nothing -> "symbol" + Just p -> p + +{- +The 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 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). + +The current approach tries to have everything which is a keyword only +in the keyword list - so it can only be used in some other context if +quoted. If something is a 'ansi keyword', but appears only as an +identifier or function name for instance in the syntax (or something +that looks identical to this), then it isn't treated as a keyword at +all. When there is some overlap (e.g. 'set'), then there is either +special case parsing code to handle this (in the case of set), or it +is not treated as a keyword (not perfect, but if it more or less +works, ok for now). + +An exception to this is the standard type names are considered as +keywords at the moment, with a special case in the type parser to +make this work. Maybe this isn't necessary or is a bad idea. + +It is possible to have a problem if you remove something which is a +keyword from this list, and still want to parse statements using it +as a keyword - for instance, removing things like 'from' or 'as', +will likely mean many things don't parse anymore. + +-} + +identifierTok :: [Text] -> Parser (Maybe (Text,Text), Text) +identifierTok blackList = do + token test Set.empty "identifier" + where + test (L.WithPos _ _ _ (L.Identifier q@(Just {}) p)) = Just (q,p) + test (L.WithPos _ _ _ (L.Identifier q@Nothing p)) + | T.toLower p `notElem` blackList = Just (q,p) + test _ = Nothing + +keywordTok :: [Text] -> Parser Text +keywordTok allowed = do + token test Set.empty where + test (L.WithPos _ _ _ (L.Identifier Nothing p)) + | T.toLower p `elem` allowed = Just p + test _ = Nothing + + +unexpectedKeywordError :: Text -> Parser a +unexpectedKeywordError kw = + failure (Just $ Label (NE.fromList $ T.unpack $ "keyword " <> kw)) Set.empty + +failOnKeyword :: Parser a +failOnKeyword = do + kws <- asks diKeywords + i <- lookAhead $ keywordTok kws + unexpectedKeywordError i + +------------------------------------------------------------------------------ + +-- dialect + +guardDialect :: (Dialect -> Bool) -> Parser () +guardDialect p = guard . p =<< ask + +askDialect :: (Dialect -> a) -> Parser a +askDialect = asks + 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.hs b/Language/SQL/SimpleSQL/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Pretty.hs @@ -0,0 +1,895 @@ + +-- | These is the pretty printing functions, which produce SQL +-- source from ASTs. The code attempts to format the output in a +-- readable way. +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module Language.SQL.SimpleSQL.Pretty + (prettyQueryExpr + ,prettyScalarExpr + ,prettyStatement + ,prettyStatements + ) where + +{- +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 Prettyprinter (Doc + ,nest + ,punctuate + ,comma + ,squotes + ,vsep + ,layoutPretty + ,defaultLayoutOptions + ,brackets + ,align + ,hcat + ,line + ) +import qualified Prettyprinter as P +import Prettyprinter.Internal.Type (Doc(Empty)) + +import Prettyprinter.Render.Text (renderStrict) + +import Data.Maybe (maybeToList, catMaybes) + +import qualified Data.Text as T +import Data.Text (Text) + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.Dialect + + +-- | Convert a query expr ast to Text. +prettyQueryExpr :: Dialect -> QueryExpr -> Text +prettyQueryExpr d = render . queryExpr d + +-- | Convert a value expr ast to Text. +prettyScalarExpr :: Dialect -> ScalarExpr -> Text +prettyScalarExpr d = render . scalarExpr d + +-- | A terminating semicolon. +terminator :: Doc a +terminator = pretty ";" <> line + +-- | Convert a statement ast to Text. +prettyStatement :: Dialect -> Statement -> Text +prettyStatement _ EmptyStatement = render terminator +prettyStatement d s = render (statement d s) + +-- | Convert a list of statements to Text. A semicolon +-- is inserted after each statement. +prettyStatements :: Dialect -> [Statement] -> Text +prettyStatements d = render . vsep . map prettyStatementWithSemicolon + where + prettyStatementWithSemicolon :: Statement -> Doc a + prettyStatementWithSemicolon s = statement d s <> terminator + +render :: Doc a -> Text +render = renderStrict . layoutPretty defaultLayoutOptions + +-- = scalar expressions + +scalarExpr :: Dialect -> ScalarExpr -> Doc a +scalarExpr _ (StringLit s e t) = pretty s <> pretty t <> pretty e + +scalarExpr _ (NumLit s) = pretty s +scalarExpr _ (IntervalLit s v f t) = + pretty "interval" + <+> me (\x -> pretty $ case x of + Plus -> "+" + Minus -> "-") s + <+> squotes (pretty v) + <+> intervalTypeField f + <+> me (\x -> pretty "to" <+> intervalTypeField x) t +scalarExpr _ (Iden i) = names i +scalarExpr _ Star = pretty "*" +scalarExpr _ (QStar nms) = names nms <> pretty ".*" +scalarExpr _ Parameter = pretty "?" +scalarExpr _ (PositionalArg n) = pretty $ T.cons '$' $ showText n +scalarExpr _ (HostParameter p i) = + pretty p + <+> me (\i' -> pretty "indicator" <+> pretty i') i + +scalarExpr d (App f es) = names f <> parens (commaSep (map (scalarExpr d) es)) + +scalarExpr dia (AggregateApp f d es od fil) = + (names f + <> parens ((case d of + Distinct -> pretty "distinct" + All -> pretty "all" + SQDefault -> mempty) + <+> commaSep (map (scalarExpr dia) es) + <+> orderBy dia od)) + <+> me (\x -> pretty "filter" + <+> parens (pretty "where" <+> scalarExpr dia x)) fil + +scalarExpr d (AggregateAppGroup f es od) = + names f + <> parens (commaSep (map (scalarExpr d) es)) + <+> if null od + then mempty + else pretty "within group" <+> parens (orderBy d od) + +scalarExpr d (WindowApp f es pb od fr) = + names f <> parens (commaSep $ map (scalarExpr d) es) + <+> pretty "over" + <+> parens ((case pb of + [] -> mempty + _ -> pretty "partition by" <+> align + (commaSep $ map (scalarExpr d) pb)) + <+> orderBy d od + <+> me frd fr) + where + frd (FrameFrom rs fp) = rsd rs <+> fpd fp + frd (FrameBetween rs fps fpe) = + rsd rs <+> pretty "between" <+> fpd fps + <+> pretty "and" <+> fpd fpe + rsd rs = case rs of + FrameRows -> pretty "rows" + FrameRange -> pretty "range" + fpd UnboundedPreceding = pretty "unbounded preceding" + fpd UnboundedFollowing = pretty "unbounded following" + fpd Current = pretty "current row" + fpd (Preceding e) = scalarExpr d e <+> pretty "preceding" + fpd (Following e) = scalarExpr d e <+> pretty "following" + +scalarExpr dia (SpecialOp nm [a,b,c]) + | nm `elem` [[Name Nothing "between"] + ,[Name Nothing "not between"]] = + sep [scalarExpr dia a + ,names nm <+> nest (T.length (unnames nm) - 3) (sep + [scalarExpr dia b + ,pretty "and" <+> scalarExpr dia c])] + +scalarExpr d (SpecialOp [Name Nothing "rowctor"] as) = + parens $ commaSep $ map (scalarExpr d) as + +scalarExpr d (SpecialOp nm es) = + names nm <+> parens (commaSep $ map (scalarExpr d) es) + +scalarExpr d (SpecialOpK nm fs as) = + names nm <> parens (sep $ catMaybes + (fmap (scalarExpr d) fs + : map (\(n,e) -> Just (pretty n <+> scalarExpr d e)) as)) + +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 vsep them + -- nicely + case ands e of + (e':es) -> vsep (scalarExpr d e' + : map ((names op <+>) . scalarExpr d) es) + [] -> mempty -- 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 +scalarExpr d (BinOp e0 [Name Nothing "."] e1) = + scalarExpr d e0 <> pretty "." <> scalarExpr d e1 +scalarExpr d (BinOp e0 f e1) = + scalarExpr d e0 <+> names f <+> scalarExpr d e1 + +scalarExpr dia (Case t ws els) = + sep $ [pretty "case" <+> me (scalarExpr dia) t] + <> map w ws + <> maybeToList (fmap e els) + <> [pretty "end"] + where + w (t0,t1) = + pretty "when" <+> align (sep [commaSep $ map (scalarExpr dia) t0 + ,pretty "then" <+> align (scalarExpr dia t1)]) + e el = pretty "else" <+> align (scalarExpr dia el) +scalarExpr d (Parens e) = + parens (scalarExpr d e) +scalarExpr d (Cast e tn) = + pretty "cast" <> parens (sep [scalarExpr d e + ,pretty "as" + ,typeName tn]) + +scalarExpr _ (TypedLit tn s) = + typeName tn <+> squotes (pretty s) + +scalarExpr d (SubQueryExpr ty qe) = + (case ty of + SqSq -> mempty + SqExists -> pretty "exists" + SqUnique -> pretty "unique" + ) <+> parens (queryExpr d qe) + +scalarExpr d (QuantifiedComparison v c cp sq) = + scalarExpr d v + <+> names c + <+> pretty (case cp of + CPAny -> "any" + CPSome -> "some" + CPAll -> "all") + <+> parens (queryExpr d sq) + +scalarExpr d (Match v u sq) = + scalarExpr d v + <+> pretty "match" + <+> (if u then pretty "unique" else mempty) + <+> parens (queryExpr d sq) + +scalarExpr d (In b se x) = + scalarExpr d se <+> + (if b then mempty else pretty "not") + <+> pretty "in" + <+> parens (case x of + InList es -> commaSep $ map (scalarExpr d) es + InQueryExpr qe -> queryExpr d qe) + +scalarExpr d (Array v es) = + scalarExpr d v <> brackets (commaSep $ map (scalarExpr d) es) + +scalarExpr d (ArrayCtor q) = + pretty "array" <> parens (queryExpr d q) + +scalarExpr d (MultisetCtor es) = + pretty "multiset" <> brackets (commaSep $ map (scalarExpr d) es) + +scalarExpr d (MultisetQueryCtor q) = + pretty "multiset" <> parens (queryExpr d q) + +scalarExpr d (MultisetBinOp a c q b) = + sep + [scalarExpr d a + ,pretty "multiset" + ,pretty $ case c of + Union -> "union" + Intersect -> "intersect" + Except -> "except" + ,case q of + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" + ,scalarExpr d b] + +{-scalarExpr d (Escape v e) = + scalarExpr d v <+> pretty "escape" <+> pretty [e] + +scalarExpr d (UEscape v e) = + scalarExpr d v <+> pretty "uescape" <+> pretty [e]-} + +scalarExpr d (Collate v c) = + scalarExpr d v <+> pretty "collate" <+> names c + +scalarExpr _ (NextValueFor ns) = + pretty "next value for" <+> names ns + +scalarExpr d (VEComment cmt v) = + vsep $ map comment cmt <> [scalarExpr d v] + +scalarExpr _ (OdbcLiteral t s) = + pretty "{" <> lt t <+> squotes (pretty s) <> pretty "}" + where + lt OLDate = pretty "d" + lt OLTime = pretty "t" + lt OLTimestamp = pretty "ts" + +scalarExpr d (OdbcFunc e) = + pretty "{fn" <+> scalarExpr d e <> pretty "}" + +scalarExpr d (Convert t e Nothing) = + pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty ")" +scalarExpr d (Convert t e (Just i)) = + pretty "convert(" <> typeName t <> pretty "," <+> scalarExpr d e <> pretty "," <+> pretty (showText i) <> pretty ")" + +unname :: Name -> Text +unname (Name Nothing n) = n +unname (Name (Just (s,e)) n) = + s <> n <> e + +unnames :: [Name] -> Text +unnames ns = T.intercalate "." $ map unname ns + + +name :: Name -> Doc a +name (Name Nothing n) = pretty n +name (Name (Just (s,e)) n) = pretty s <> pretty n <> pretty e + +names :: [Name] -> Doc a +names ns = hcat $ punctuate (pretty ".") $ map name ns + +typeName :: TypeName -> Doc a +typeName (TypeName t) = names t +typeName (PrecTypeName t a) = names t <+> parens (pretty $ showText a) +typeName (PrecScaleTypeName t a b) = + names t <+> parens (pretty (showText a) <+> comma <+> pretty (showText b)) +typeName (PrecLengthTypeName t i m u) = + names t + <> parens (pretty (showText i) + <> me (\case + PrecK -> pretty "K" + PrecM -> pretty "M" + PrecG -> pretty "G" + PrecT -> pretty "T" + PrecP -> pretty "P") m + <+> me (\case + PrecCharacters -> pretty "CHARACTERS" + PrecOctets -> pretty "OCTETS") u) +typeName (CharTypeName t i cs col) = + (names t + <> me (\x -> parens (pretty $ showText x)) i) + <+> (if null cs + then mempty + else pretty "character set" <+> names cs) + <+> (if null col + then mempty + else pretty "collate" <+> names col) +typeName (TimeTypeName t i tz) = + (names t + <> me (\x -> parens (pretty $ showText x)) i) + <+> pretty (if tz + then "with time zone" + else "without time zone") +typeName (RowTypeName cs) = + pretty "row" <> parens (commaSep $ map f cs) + where + f (n,t) = name n <+> typeName t +typeName (IntervalTypeName f t) = + pretty "interval" + <+> intervalTypeField f + <+> me (\x -> pretty "to" <+> intervalTypeField x) t + +typeName (ArrayTypeName tn sz) = + typeName tn <+> pretty "array" <+> me (brackets . pretty . showText) sz + +typeName (MultisetTypeName tn) = + typeName tn <+> pretty "multiset" + +intervalTypeField :: IntervalTypeField -> Doc a +intervalTypeField (Itf n p) = + pretty n + <+> me (\(x,x1) -> + parens (pretty (showText x) + <+> me (\y -> sep [comma,pretty (showText y)]) x1)) p + + +-- = query expressions + +queryExpr :: Dialect -> QueryExpr -> Doc a +queryExpr dia (Select d sl fr wh gb hv od off fe) = + sep [pretty "select" <+> align (sep + [case d of + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" + ,selectList dia sl]) + ,from dia fr + ,maybeScalarExpr dia "where" wh + ,grpBy dia gb + ,maybeScalarExpr dia "having" hv + ,orderBy dia od + ,me (\e -> pretty "offset" <+> scalarExpr dia e <+> pretty "rows") off + ,fetchFirst + ] + where + fetchFirst = + me (\e -> if diLimit dia + then pretty "limit" <+> scalarExpr dia e + else pretty "fetch first" <+> scalarExpr dia e + <+> pretty "rows only") fe + +queryExpr dia (QueryExprSetOp q1 ct d c q2) = + sep [queryExpr dia q1 + ,pretty (case ct of + Union -> "union" + Intersect -> "intersect" + Except -> "except") + <+> case d of + SQDefault -> mempty + All -> pretty "all" + Distinct -> pretty "distinct" + <+> case c of + Corresponding -> pretty "corresponding" + Respectively -> mempty + ,queryExpr dia q2] +queryExpr d (With rc withs qe) = + pretty "with" <+> (if rc then pretty "recursive" else mempty) + <+> vsep [nest 5 + (vsep $ punctuate comma $ flip map withs $ \(n,q) -> + withAlias n <+> pretty "as" <+> parens (queryExpr d q)) + ,queryExpr d qe] + where + withAlias (Alias nm cols) = name nm + <+> me (parens . commaSep . map name) cols + + +queryExpr d (Values vs) = + pretty "values" + <+> nest 7 (commaSep (map (parens . commaSep . map (scalarExpr d)) vs)) +queryExpr _ (Table t) = pretty "table" <+> names t +queryExpr d (QueryExprParens qe) = parens (queryExpr d qe) +queryExpr d (QEComment cmt v) = + vsep $ map comment cmt <> [queryExpr d v] + + +alias :: Alias -> Doc a +alias (Alias nm cols) = + pretty "as" <+> name nm + <+> me (parens . commaSep . map name) cols + +selectList :: Dialect -> [(ScalarExpr,Maybe Name)] -> Doc a +selectList d is = commaSep $ map si is + where + si (e,al) = scalarExpr d e <+> me als al + als al = pretty "as" <+> name al + +from :: Dialect -> [TableRef] -> Doc a +from _ [] = mempty +from d ts = + pretty "from" <+> align (vsep (punctuate comma $ map tr ts)) + where + tr (TRSimple t) = names t + tr (TRLateral t) = pretty "lateral" <+> tr t + tr (TRFunction f 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 + tr (TRJoin t0 b jt t1 jc) = + sep [tr t0 + ,if b then pretty "natural" else mempty + ,joinText jt <+> tr t1 + ,joinCond jc] + tr (TROdbc t) = pretty "{oj" <+> tr t <+> pretty "}" + joinText jt = + sep [case jt of + JInner -> pretty "inner" + JLeft -> pretty "left" + JRight -> pretty "right" + JFull -> pretty "full" + JCross -> pretty "cross" + ,pretty "join"] + joinCond (Just (JoinOn e)) = pretty "on" <+> scalarExpr d e + joinCond (Just (JoinUsing es)) = + pretty "using" <+> parens (commaSep $ map name es) + joinCond Nothing = mempty + +maybeScalarExpr :: Dialect -> Text -> Maybe ScalarExpr -> Doc a +maybeScalarExpr d k = me + (\e -> pretty k <+> align (scalarExpr d e)) + +grpBy :: Dialect -> [GroupingExpr] -> Doc a +grpBy _ [] = mempty +grpBy d gs = pretty "group by" <+> align (commaSep $ map ge gs) + where + ge (SimpleGroup e) = scalarExpr d e + ge (GroupingParens g) = parens (commaSep $ map ge g) + ge (Cube es) = pretty "cube" <> parens (commaSep $ map ge es) + ge (Rollup es) = pretty "rollup" <> parens (commaSep $ map ge es) + ge (GroupingSets es) = pretty "grouping sets" <> parens (commaSep $ map ge es) + +orderBy :: Dialect -> [SortSpec] -> Doc a +orderBy _ [] = mempty +orderBy dia os = pretty "order by" <+> align (commaSep $ map f os) + where + f (SortSpec e d n) = + scalarExpr dia e + <+> (case d of + Asc -> pretty "asc" + Desc -> pretty "desc" + DirDefault -> mempty) + <+> (case n of + NullsOrderDefault -> mempty + NullsFirst -> pretty "nulls" <+> pretty "first" + NullsLast -> pretty "nulls" <+> pretty "last") + +-- = statements + +statement :: Dialect -> Statement -> Doc a + + +-- == ddl + +statement _ (CreateSchema nm) = + pretty "create" <+> pretty "schema" <+> names nm + +statement d (CreateTable nm cds withoutRowid) = + pretty "create" <+> pretty "table" <+> names nm + <+> parens (commaSep $ map cd cds) + <+> (if withoutRowid then texts [ "without", "rowid" ] else mempty) + where + cd (TableConstraintDef n con) = + maybe mempty (\s -> pretty "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) = + pretty "drop" <+> pretty "schema" <+> names nm <+> dropBehav db + +statement d (CreateDomain nm ty def cs) = + pretty "create" <+> pretty "domain" <+> names nm + <+> typeName ty + <+> maybe mempty (\def' -> pretty "default" <+> scalarExpr d def') def + <+> sep (map con cs) + where + con (cn, e) = + maybe mempty (\cn' -> pretty "constraint" <+> names cn') cn + <+> pretty "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) = + pretty "add" + <+> maybe mempty (\cnm' -> pretty "constraint" <+> names cnm') cnm + <+> pretty "check" <> parens (scalarExpr d e) + a (ADDropConstraint cnm) = texts ["drop", "constraint"] + <+> names cnm + + +statement _ (DropDomain nm db) = + pretty "drop" <+> pretty "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) = + pretty "drop" <+> pretty "sequence" <+> names nm <+> dropBehav db + + +statement d (CreateAssertion nm ex) = + texts ["create","assertion"] <+> names nm + <+> pretty "check" <+> parens (scalarExpr d ex) + +statement _ (DropAssertion nm db) = + pretty "drop" <+> pretty "assertion" <+> names nm <+> dropBehav db + +statement _ (CreateIndex un nm tbl cols) = + texts (if un + then ["create","unique","index"] + else ["create","index"]) + <+> names nm + <+> pretty "on" + <+> names tbl + <+> parens (commaSep $ map name cols) + +-- == dml + +statement d (SelectStatement q) = queryExpr d q + +statement d (Delete t a w) = + pretty "delete" <+> pretty "from" + <+> names t <+> maybe mempty (\x -> pretty "as" <+> name x) a + <+> maybeScalarExpr d "where" w + +statement _ (Truncate t ir) = + pretty "truncate" <+> pretty "table" <+> names t + <+> case ir of + DefaultIdentityRestart -> mempty + ContinueIdentity -> pretty "continue" <+> pretty "identity" + RestartIdentity -> pretty "restart" <+> pretty "identity" + +statement d (Insert t cs s) = + pretty "insert" <+> pretty "into" <+> names t + <+> maybe mempty (\cs' -> parens (commaSep $ map name cs')) cs + <+> case s of + DefaultInsertValues -> pretty "default" <+> pretty "values" + InsertQuery q -> queryExpr d q + +statement d (Update t a sts whr) = + pretty "update" <+> names t + <+> maybe mempty (\x -> pretty "as" <+> name x) a + <+> pretty "set" <+> commaSep (map sc sts) + <+> maybeScalarExpr d "where" whr + where + sc (Set tg v) = names tg <+> pretty "=" <+> scalarExpr d v + sc (SetMultiple ts vs) = parens (commaSep $ map names ts) <+> pretty "=" + <+> parens (commaSep $ map (scalarExpr d) vs) + +statement _ (DropTable n b) = + pretty "drop" <+> pretty "table" <+> names n <+> dropBehav b + +statement d (CreateView r nm al q co) = + pretty "create" <+> (if r then pretty "recursive" else mempty) + <+> pretty "view" <+> names nm + <+> maybe mempty (parens . commaSep . map name) al + <+> pretty "as" + <+> queryExpr d q + <+> case co of + Nothing -> mempty + Just DefaultCheckOption -> texts ["with", "check", "option"] + Just CascadedCheckOption -> texts ["with", "cascaded", "check", "option"] + Just LocalCheckOption -> texts ["with", "local", "check", "option"] + +statement _ (DropView n b) = + pretty "drop" <+> pretty "view" <+> names n <+> dropBehav b + + +-- == transactions + +statement _ StartTransaction = + texts ["start", "transaction"] + +statement _ (Savepoint nm) = + pretty "savepoint" <+> name nm + +statement _ (ReleaseSavepoint nm) = + texts ["release", "savepoint"] <+> name nm + +statement _ Commit = + pretty "commit" + +statement _ (Rollback mn) = + pretty "rollback" + <+> maybe mempty (\n -> texts ["to","savepoint"] <+> name n) mn + +-- == access control + +statement _ (GrantPrivilege pas po rs go) = + pretty "grant" <+> commaSep (map privAct pas) + <+> pretty "on" <+> privObj po + <+> pretty "to" <+> commaSep (map name rs) + <+> grantOpt go + where + grantOpt WithGrantOption = texts ["with","grant","option"] + grantOpt WithoutGrantOption = mempty + +statement _ (GrantRole rs trs ao) = + pretty "grant" <+> commaSep (map name rs) + <+> pretty "to" <+> commaSep (map name trs) + <+> adminOpt ao + where + adminOpt WithAdminOption = texts ["with","admin","option"] + adminOpt WithoutAdminOption = mempty + +statement _ (CreateRole nm) = + texts ["create","role"] <+> name nm + +statement _ (DropRole nm) = + texts ["drop","role"] <+> name nm + +statement _ (RevokePrivilege go pas po rs db) = + pretty "revoke" + <+> grantOptFor go + <+> commaSep (map privAct pas) + <+> pretty "on" <+> privObj po + <+> pretty "from" <+> commaSep (map name rs) + <+> dropBehav db + where + grantOptFor GrantOptionFor = texts ["grant","option","for"] + grantOptFor NoGrantOptionFor = mempty + +statement _ (RevokeRole ao rs trs db) = + pretty "revoke" + <+> adminOptFor ao + <+> commaSep (map name rs) + <+> pretty "from" <+> commaSep (map name trs) + <+> dropBehav db + where + adminOptFor AdminOptionFor = texts ["admin","option","for"] + adminOptFor NoAdminOptionFor = mempty + + +statement _ (StatementComment cs) = vsep $ map comment cs +statement _ EmptyStatement = mempty + + +{- +== sessions + + +== extras +-} + +dropBehav :: DropBehaviour -> Doc a +dropBehav DefaultDropBehaviour = mempty +dropBehav Cascade = pretty "cascade" +dropBehav Restrict = pretty "restrict" + +columnDef :: Dialect -> ColumnDef -> Doc a +columnDef d (ColumnDef n t cons) = + name n <+> maybe mempty typeName t + <+> sep (map cdef cons) + where + cdef (ColConstraintDef cnm con) = + maybe mempty (\s -> pretty "constraint" <+> names s) cnm + <+> pcon con + pcon ColNotNullConstraint = texts ["not","null"] + pcon ColNullableConstraint = texts ["null"] + pcon ColUniqueConstraint = pretty "unique" + pcon (ColPrimaryKeyConstraint autoincrement) = + texts $ ["primary","key"] <> ["autoincrement"|autoincrement] + --pcon ColPrimaryKeyConstraint = texts ["primary","key"] + pcon (ColCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v) + pcon (ColReferencesConstraint tb c m u del) = + pretty "references" + <+> names tb + <+> maybe mempty (parens . name) c + <+> refMatch m + <+> refAct "update" u + <+> refAct "delete" del + pcon (ColDefaultClause clause) = case clause of + DefaultClause def -> + pretty "default" <+> scalarExpr d def + GenerationClause e -> + texts ["generated","always","as"] <+> parens (scalarExpr d e) + IdentityColumnSpec w o -> + pretty "generated" + <+> (case w of + GeneratedAlways -> pretty "always" + GeneratedByDefault -> pretty "by" <+> pretty "default") + <+> pretty "as" <+> pretty "identity" + <+> (case o of + [] -> mempty + os -> parens (sep $ map sequenceGeneratorOption os)) + +sequenceGeneratorOption :: SequenceGeneratorOption -> Doc a +sequenceGeneratorOption (SGODataType t) = + pretty "as" <+> typeName t +sequenceGeneratorOption (SGORestart mi) = + pretty "restart" <+> maybe mempty (\mi' -> texts ["with", showText mi']) mi +sequenceGeneratorOption (SGOStartWith i) = texts ["start", "with", showText i] +sequenceGeneratorOption (SGOIncrementBy i) = texts ["increment", "by", showText i] +sequenceGeneratorOption (SGOMaxValue i) = texts ["maxvalue", showText i] +sequenceGeneratorOption SGONoMaxValue = texts ["no", "maxvalue"] +sequenceGeneratorOption (SGOMinValue i) = texts ["minvalue", showText i] +sequenceGeneratorOption SGONoMinValue = texts ["no", "minvalue"] +sequenceGeneratorOption SGOCycle = pretty "cycle" +sequenceGeneratorOption SGONoCycle = pretty "no cycle" + +refMatch :: ReferenceMatch -> Doc a +refMatch m = case m of + DefaultReferenceMatch -> mempty + MatchFull -> texts ["match", "full"] + MatchPartial -> texts ["match","partial"] + MatchSimple -> texts ["match", "simple"] + +refAct :: Text -> ReferentialAction -> Doc a +refAct t a = case a of + DefaultReferentialAction -> mempty + 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 a +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) = + pretty "add" + <+> maybe mempty (\s -> pretty "constraint" <+> names s) n + <+> tableConstraint d con + +alterTableAction _ (DropTableConstraintDef n b) = + texts ["drop", "constraint"] + <+> names n + <+> dropBehav b + + +tableConstraint :: Dialect -> TableConstraint -> Doc a +tableConstraint _ (TableUniqueConstraint ns) = + pretty "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) + <+> pretty "references" + <+> names t + <+> maybe mempty (\c' -> parens (commaSep $ map name c')) tcs + <+> refMatch m + <+> refAct "update" u + <+> refAct "delete" del +tableConstraint d (TableCheckConstraint v) = pretty "check" <+> parens (scalarExpr d v) + + +privAct :: PrivilegeAction -> Doc a +privAct PrivAll = texts ["all","privileges"] +privAct (PrivSelect cs) = pretty "select" <+> maybeColList cs +privAct (PrivInsert cs) = pretty "insert" <+> maybeColList cs +privAct (PrivUpdate cs) = pretty "update" <+> maybeColList cs +privAct (PrivReferences cs) = pretty "references" <+> maybeColList cs +privAct PrivDelete = pretty "delete" +privAct PrivUsage = pretty "usage" +privAct PrivTrigger = pretty "trigger" +privAct PrivExecute = pretty "execute" + +maybeColList :: [Name] -> Doc a +maybeColList cs = + if null cs + then mempty + else parens (commaSep $ map name cs) + +privObj :: PrivilegeObject -> Doc a +privObj (PrivTable nm) = names nm +privObj (PrivDomain nm) = pretty "domain" <+> names nm +privObj (PrivType nm) = pretty "type" <+> names nm +privObj (PrivSequence nm) = pretty "sequence" <+> names nm +privObj (PrivFunction nm) = texts ["specific", "function"] <+> names nm + +-- = utils + +commaSep :: [Doc a] -> Doc a +commaSep ds = sep $ punctuate comma ds + +me :: (b -> Doc a) -> Maybe b -> Doc a +me = maybe mempty + +comment :: Comment -> Doc a +comment (BlockComment str) = pretty "/*" <+> pretty str <+> pretty "*/" + +texts :: [Text] -> Doc a +texts ts = sep $ map pretty ts + +-- regular pretty completely defeats the type checker when you want +-- to change the ast and get type errors, instead it just produces +-- incorrect code. +pretty :: Text -> Doc a +pretty = P.pretty + +showText :: Show a => a -> Text +showText = T.pack . show + +-- restore the correct behaviour of mempty +-- this doesn't quite work when you chain <> and <+> together, +-- so use parens in those cases + +sep :: [Doc a] -> Doc a +sep = P.sep . filter isEmpty + where + isEmpty Empty = False + isEmpty _ = True + +(<+>) :: Doc a -> Doc a -> Doc a +(<+>) a b = case (a,b) of + (Empty, Empty) -> Empty + (Empty, x) -> x + (x, Empty) -> x + _ -> a P.<+> b + +parens :: Doc a -> Doc a +parens a = P.parens (align a) diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs deleted file mode 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ /dev/null @@ -1,456 +0,0 @@ - -> {-# 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 -> ) where - -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 Text.PrettyPrint (render, vcat, text, (<>), (<+>), empty, parens, -> nest, Doc, punctuate, comma, sep, quotes, -> doubleQuotes, 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 - -> -- | 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) - -= value expressions - -> valueExpr :: Dialect -> ValueExpr -> Doc -> valueExpr _ (StringLit s) = quotes $ text $ doubleUpQuotes s - -> valueExpr _ (NumLit s) = text s -> valueExpr _ (IntervalLit s v f t) = -> text "interval" -> <+> me (\x -> if x then text "+" else text "-") 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 - -> valueExpr d (App f es) = names f <> parens (commaSep (map (valueExpr d) es)) - -> valueExpr 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) -> <+> orderBy dia od) -> <+> me (\x -> text "filter" -> <+> parens (text "where" <+> valueExpr dia x)) fil - -> valueExpr d (AggregateAppGroup f es od) = -> names f -> <> parens (commaSep (map (valueExpr 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) -> <+> text "over" -> <+> parens ((case pb of -> [] -> empty -> _ -> text "partition by" -> <+> nest 13 (commaSep $ map (valueExpr d) pb)) -> <+> orderBy d od -> <+> me frd fr) -> where -> frd (FrameFrom rs fp) = rsd rs <+> fpd fp -> frd (FrameBetween rs fps fpe) = -> rsd rs <+> text "between" <+> fpd fps -> <+> text "and" <+> fpd fpe -> rsd rs = case rs of -> FrameRows -> text "rows" -> FrameRange -> text "range" -> 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" - -> 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] - -> valueExpr d (SpecialOp [Name "rowctor"] as) = -> parens $ commaSep $ map (valueExpr d) as - -> valueExpr d (SpecialOp nm es) = -> names nm <+> parens (commaSep $ map (valueExpr d) es) - -> valueExpr d (SpecialOpK nm fs as) = -> names nm <> parens (sep $ catMaybes -> (fmap (valueExpr d) fs -> : map (\(n,e) -> Just (text n <+> valueExpr 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"]] = -> -- 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) -> [] -> 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 - -> valueExpr dia (Case t ws els) = -> sep $ [text "case" <+> me (valueExpr 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 "as" -> ,typeName tn]) - -> valueExpr _ (TypedLit tn s) = -> typeName tn <+> quotes (text s) - -> valueExpr 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 -> <+> names c -> <+> (text $ case cp of -> CPAny -> "any" -> CPSome -> "some" -> CPAll -> "all") -> <+> parens (queryExpr d sq) - -> valueExpr d (Match v u sq) = -> valueExpr d v -> <+> text "match" -> <+> (if u then text "unique" else empty) -> <+> parens (queryExpr d sq) - -> valueExpr d (In b se x) = -> valueExpr 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 -> InQueryExpr qe -> queryExpr d qe) - -> valueExpr d (Array v es) = -> valueExpr d v <> brackets (commaSep $ map (valueExpr d) es) - -> valueExpr d (ArrayCtor q) = -> text "array" <> parens (queryExpr d q) - -> valueExpr d (MultisetCtor es) = -> text "multiset" <> brackets (commaSep $ map (valueExpr d) es) - -> valueExpr d (MultisetQueryCtor q) = -> text "multiset" <> parens (queryExpr d q) - -> valueExpr d (MultisetBinOp a c q b) = -> sep -> [valueExpr d a -> ,text "multiset" -> ,text $ case c of -> Union -> "union" -> Intersect -> "intersect" -> Except -> "except" -> ,case q of -> SQDefault -> empty -> All -> text "all" -> Distinct -> text "distinct" -> ,valueExpr d b] - - - -> valueExpr _ (CSStringLit cs st) = -> text cs <> quotes (text $ doubleUpQuotes st) - -> valueExpr d (Escape v e) = -> valueExpr d v <+> text "escape" <+> text [e] - -> valueExpr d (UEscape v e) = -> valueExpr d v <+> text "uescape" <+> text [e] - -> valueExpr d (Collate v c) = -> valueExpr d v <+> text "collate" <+> names c - -> valueExpr _ (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 - - - -> 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 - -> 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 - -> names :: [Name] -> Doc -> names ns = hcat $ punctuate (text ".") $ map name ns - -> typeName :: TypeName -> Doc -> typeName (TypeName t) = names t -> typeName (PrecTypeName t a) = names t <+> parens (text $ show a) -> typeName (PrecScaleTypeName t a b) = -> names t <+> parens (text (show a) <+> comma <+> text (show b)) -> typeName (PrecLengthTypeName t i m u) = -> names t -> <> parens (text (show i) -> <> me (\x -> case x of -> PrecK -> text "K" -> PrecM -> text "M" -> PrecG -> text "G" -> PrecT -> text "T" -> PrecP -> text "P") m -> <+> me (\x -> case x of -> PrecCharacters -> text "CHARACTERS" -> PrecOctets -> text "OCTETS") u) -> typeName (CharTypeName t i cs col) = -> names t -> <> me (\x -> parens (text $ show x)) i -> <+> (if null cs -> then empty -> else text "character set" <+> names cs) -> <+> (if null col -> then empty -> else text "collate" <+> names col) -> typeName (TimeTypeName t i tz) = -> names t -> <> me (\x -> parens (text $ show x)) i -> <+> text (if tz -> then "with time zone" -> else "without time zone") -> typeName (RowTypeName cs) = -> text "row" <> parens (commaSep $ map f cs) -> where -> f (n,t) = name n <+> typeName t -> typeName (IntervalTypeName f t) = -> text "interval" -> <+> intervalTypeField f -> <+> me (\x -> text "to" <+> intervalTypeField x) t - -> typeName (ArrayTypeName tn sz) = -> typeName tn <+> text "array" <+> me (brackets . text . show) sz - -> typeName (MultisetTypeName tn) = -> typeName tn <+> text "multiset" - -> intervalTypeField :: IntervalTypeField -> Doc -> intervalTypeField (Itf n p) = -> text n -> <+> me (\(x,x1) -> -> parens (text (show x) -> <+> me (\y -> (sep [comma,text (show y)])) x1)) p - - -= query expressions - -> queryExpr :: Dialect -> QueryExpr -> Doc -> queryExpr dia (Select d sl fr wh gb hv od off fe) = -> sep [text "select" -> ,case d of -> SQDefault -> empty -> All -> text "all" -> Distinct -> text "distinct" -> ,nest 7 $ sep [selectList dia sl] -> ,from dia fr -> ,maybeValueExpr dia "where" wh -> ,grpBy dia gb -> ,maybeValueExpr dia "having" hv -> ,orderBy dia od -> ,me (\e -> text "offset" <+> valueExpr 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 -> <+> text "rows only") fe - -> queryExpr dia (CombineQueryExpr q1 ct d c q2) = -> sep [queryExpr dia q1 -> ,text (case ct of -> Union -> "union" -> Intersect -> "intersect" -> Except -> "except") -> <+> case d of -> SQDefault -> empty -> All -> text "all" -> Distinct -> text "distinct" -> <+> case c of -> Corresponding -> text "corresponding" -> Respectively -> empty -> ,queryExpr dia q2] -> queryExpr d (With rc withs qe) = -> text "with" <+> (if rc then text "recursive" else empty) -> <+> vcat [nest 5 -> (vcat $ punctuate comma $ flip map withs $ \(n,q) -> -> alias n <+> text "as" <+> parens (queryExpr d q)) -> ,queryExpr d qe] -> queryExpr d (Values vs) = -> text "values" -> <+> nest 7 (commaSep (map (parens . commaSep . map (valueExpr d)) vs)) -> queryExpr _ (Table t) = text "table" <+> names t -> queryExpr d (QEComment cmt v) = -> vcat $ map comment cmt ++ [queryExpr d v] - - -> alias :: Alias -> Doc -> alias (Alias nm cols) = -> text "as" <+> name nm -> <+> me (parens . commaSep . map name) cols - -> selectList :: Dialect -> [(ValueExpr,Maybe Name)] -> Doc -> selectList d is = commaSep $ map si is -> where -> si (e,al) = valueExpr d e <+> me als al -> als al = text "as" <+> name al - -> from :: Dialect -> [TableRef] -> Doc -> from _ [] = empty -> from d ts = -> sep [text "from" -> ,nest 5 $ vcat $ punctuate comma $ map tr ts] -> where -> tr (TRSimple t) = names t -> tr (TRLateral t) = text "lateral" <+> tr t -> tr (TRFunction f as) = -> names f <> parens (commaSep $ map (valueExpr d) as) -> tr (TRAlias t a) = sep [tr t, alias a] -> tr (TRParens t) = parens $ tr t -> tr (TRQueryExpr q) = parens $ queryExpr d q -> tr (TRJoin t0 b jt t1 jc) = -> sep [tr t0 -> ,if b then text "natural" else empty -> ,joinText jt <+> tr t1 -> ,joinCond jc] -> joinText jt = -> sep [case jt of -> JInner -> text "inner" -> JLeft -> text "left" -> JRight -> text "right" -> JFull -> text "full" -> JCross -> text "cross" -> ,text "join"] -> joinCond (Just (JoinOn e)) = text "on" <+> valueExpr 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 -> (\e -> sep [text k -> ,nest (length k + 1) $ valueExpr 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 (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) -> ge (GroupingSets es) = text "grouping sets" <> parens (commaSep $ map ge es) - -> orderBy :: Dialect -> [SortSpec] -> Doc -> orderBy _ [] = empty -> orderBy dia os = sep [text "order by" -> ,nest 9 $ commaSep $ map f os] -> where -> f (SortSpec e d n) = -> valueExpr dia e -> <+> (case d of -> Asc -> text "asc" -> Desc -> text "desc" -> DirDefault -> empty) -> <+> (case n of -> NullsOrderDefault -> empty -> NullsFirst -> text "nulls" <+> text "first" -> NullsLast -> text "nulls" <+> text "last") - -= utils - -> commaSep :: [Doc] -> Doc -> commaSep ds = sep $ punctuate comma ds - -> me :: (a -> Doc) -> Maybe a -> Doc -> me = maybe empty - -> comment :: Comment -> Doc -> comment (BlockComment str) = text "/*" <+> text str <+> text "*/" diff --git a/Language/SQL/SimpleSQL/Syntax.hs b/Language/SQL/SimpleSQL/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/SQL/SimpleSQL/Syntax.hs @@ -0,0 +1,774 @@ + +-- | The AST for SQL. +{-# LANGUAGE DeriveDataTypeable #-} +module Language.SQL.SimpleSQL.Syntax + (-- * Scalar expressions + ScalarExpr(..) + ,Name(..) + ,TypeName(..) + ,IntervalTypeField(..) + ,Sign(..) + ,PrecMultiplier(..) + ,PrecUnits(..) + ,SetQuantifier(..) + ,SortSpec(..) + ,Direction(..) + ,NullsOrder(..) + ,InPredValue(..) + ,SubQueryExprType(..) + ,CompPredQuantifier(..) + ,Frame(..) + ,FrameRows(..) + ,FramePos(..) + ,OdbcLiteralType(..) + -- * Query expressions + ,QueryExpr(..) + ,SetOperatorName(..) + ,Corresponding(..) + ,Alias(..) + ,GroupingExpr(..) + -- ** From + ,TableRef(..) + ,JoinType(..) + ,JoinCondition(..) + -- * Statements + ,Statement(..) + ,DropBehaviour(..) + ,IdentityRestart(..) + ,InsertSource(..) + ,SetClause(..) + ,TableElement(..) + ,ColumnDef(..) + ,DefaultClause(..) + ,IdentityWhen(..) + ,SequenceGeneratorOption(..) + ,ColConstraintDef(..) + ,AutoincrementClause + ,ColConstraint(..) + ,TableConstraint(..) + ,ReferenceMatch(..) + ,ReferentialAction(..) + ,AlterTableAction(..) + ,CheckOption(..) + ,AlterDomainAction(..) + ,AdminOption(..) + ,GrantOption(..) + ,PrivilegeObject(..) + ,PrivilegeAction(..) + ,AdminOptionFor(..) + ,GrantOptionFor(..) + -- * Comment + ,Comment(..) + + ,makeSelect + ,toQueryExpr + ,MakeSelect(..) + ) where + +import Data.Text (Text) + +import Data.Data (Data, Typeable) + +-- | 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 ScalarExpr + = -- | a numeric literal optional decimal point, e+- + -- integral exponent, e.g + -- + -- * 10 + -- + -- * 10. + -- + -- * .1 + -- + -- * 10.1 + -- + -- * 1e5 + -- + -- * 12.34e-6 + NumLit Text + -- | string literal, with the start and end quote + -- e.g. 'test' -> TextLit "'" "'" "test" + | StringLit Text Text Text + -- | text of interval literal, units of interval precision, + -- e.g. interval 3 days (3) + | IntervalLit + {ilSign :: Maybe Sign -- ^ if + or - used + ,ilLiteral :: Text -- ^ literal text + ,ilFrom :: IntervalTypeField + ,ilTo :: Maybe IntervalTypeField + } + + -- | prefix 'typed literal', e.g. int '42' + | TypedLit TypeName Text + + -- | identifier with parts separated by dots + | Iden [Name] + -- | star, as in select *, count(*) + | Star + -- | qualified star, as in a.*, b.c.* + | QStar [Name] + + | Parameter -- ^ Represents a ? in a parameterized query + | PositionalArg Int -- ^ Represents an e.g. $1 in a parameterized query + | HostParameter Text (Maybe Text) -- ^ represents a host + -- parameter, e.g. :a. The + -- Maybe Text 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] [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 :: [ScalarExpr]-- ^ args + ,aggOrderBy :: [SortSpec] -- ^ order by + ,aggFilter :: Maybe ScalarExpr -- ^ filter + } + -- | aggregates with within group + | AggregateAppGroup + {aggName :: [Name] -- ^ aggregate function name + ,aggArgs :: [ScalarExpr] -- ^ args + ,aggGroup :: [SortSpec] -- ^ within group + } + -- | window application, which adds over (partition by a order + -- by b) to regular function application. Explicit frames are + -- not currently supported + | WindowApp + {wnName :: [Name] -- ^ window function name + ,wnArgs :: [ScalarExpr] -- ^ args + ,wnPartition :: [ScalarExpr] -- ^ partition by + ,wnOrderBy :: [SortSpec] -- ^ order by + ,wnFrame :: Maybe Frame -- ^ frame clause + } + + -- | 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 ScalarExpr) [(Text,ScalarExpr)] + + -- | cast(a as typename) + | Cast ScalarExpr TypeName + + -- | convert expression to given datatype @CONVERT(data_type(length), expression, style)@ + | Convert TypeName ScalarExpr (Maybe Integer) + + -- | case expression. both flavours supported + | Case + {caseTest :: Maybe ScalarExpr -- ^ test value + ,caseWhens :: [([ScalarExpr],ScalarExpr)] -- ^ when branches + ,caseElse :: Maybe ScalarExpr -- ^ else value + } + + | 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 ScalarExpr InPredValue + + -- | exists, all, any, some subqueries + | SubQueryExpr SubQueryExprType QueryExpr + + | QuantifiedComparison + ScalarExpr + [Name] -- operator + CompPredQuantifier + QueryExpr + + | Match ScalarExpr Bool -- true if unique + QueryExpr + | Array ScalarExpr [ScalarExpr] -- ^ represents an array + -- access expression, or an array ctor + -- e.g. a[3]. The first + -- 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) + +{- +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] ScalarExpr + | OdbcLiteral OdbcLiteralType Text + -- ^ 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. +-- examples: +-- +-- * test -> Name Nothing "test" +-- * "test" -> Name (Just "\"","\"") "test" +-- * `something` -> Name (Just ("`","`") "something" +-- * [ms] -> Name (Just ("[","]") "ms" +data Name = Name (Maybe (Text,Text)) Text + deriving (Eq,Show,Read,Data,Typeable) + +-- | Represents a type name, used in casts. +data TypeName + = TypeName [Name] + | PrecTypeName [Name] Integer + | PrecScaleTypeName [Name] Integer Integer + | PrecLengthTypeName [Name] Integer (Maybe PrecMultiplier) (Maybe PrecUnits) + -- precision, characterset, collate + | CharTypeName [Name] (Maybe Integer) [Name] [Name] + | TimeTypeName [Name] (Maybe Integer) Bool -- true == with time zone + | RowTypeName [(Name,TypeName)] + | IntervalTypeName IntervalTypeField (Maybe IntervalTypeField) + | ArrayTypeName TypeName (Maybe Integer) + | MultisetTypeName TypeName + deriving (Eq,Show,Read,Data,Typeable) + +data IntervalTypeField = Itf Text (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 (scalar expression list)', and 'expr in +-- (subquery)' syntax. +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 scalar expression. +data SubQueryExprType + = -- | exists (query expr) + SqExists + -- | unique (query expr) + | SqUnique + -- | a scalar subquery + | SqSq + deriving (Eq,Show,Read,Data,Typeable) + +data CompPredQuantifier + = CPAny + | CPSome + | CPAll + deriving (Eq,Show,Read,Data,Typeable) + +-- | Represents one field in an order by list. +data SortSpec = SortSpec ScalarExpr Direction NullsOrder + deriving (Eq,Show,Read,Data,Typeable) + +-- | Represents 'nulls first' or 'nulls last' in an order by clause. +data NullsOrder = NullsOrderDefault + | NullsFirst + | NullsLast + deriving (Eq,Show,Read,Data,Typeable) + +-- | Represents the frame clause of a window +-- this can be [range | rows] frame_start +-- or [range | rows] between frame_start and frame_end +data Frame = FrameFrom FrameRows FramePos + | FrameBetween FrameRows FramePos FramePos + deriving (Eq,Show,Read,Data,Typeable) + +-- | Represents whether a window frame clause is over rows or ranges. +data FrameRows = FrameRows | FrameRange + deriving (Eq,Show,Read,Data,Typeable) + +-- | represents the start or end of a frame +data FramePos = UnboundedPreceding + | Preceding ScalarExpr + | Current + | 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; +-- +-- * a set operator (union, except, intersect); +-- +-- * a common table expression (with); +-- +-- * a table value constructor (values (1,2),(3,4)); or +-- +-- * an explicit table (table t). +data QueryExpr + = Select + {qeSetQuantifier :: SetQuantifier + ,qeSelectList :: [(ScalarExpr,Maybe Name)] + -- ^ the expressions and the column aliases + +{- +TODO: consider breaking this up. The SQL grammar has +queryexpr = select [] -table expression = [where] [groupby] [having] ... - -This would make some things a bit cleaner? - -> ,qeFrom :: [TableRef] -> ,qeWhere :: Maybe ValueExpr -> ,qeGroupBy :: [GroupingExpr] -> ,qeHaving :: Maybe ValueExpr -> ,qeOrderBy :: [SortSpec] -> ,qeOffset :: Maybe ValueExpr -> ,qeFetchFirst :: Maybe ValueExpr -> } -> | CombineQueryExpr -> {qe0 :: QueryExpr -> ,qeCombOp :: CombineOp -> ,qeSetQuantifier :: SetQuantifier -> ,qeCorresponding :: Corresponding -> ,qe1 :: QueryExpr -> } -> | With -> {qeWithRecursive :: Bool -> ,qeViews :: [(Alias,QueryExpr)] -> ,qeQueryExpression :: QueryExpr} -> | Values [[ValueExpr]] -> | Table [Name] -> | QEComment [Comment] QueryExpr -> deriving (Eq,Show,Read,Data,Typeable) - -TODO: add queryexpr parens to deal with e.g. -(select 1 union select 2) union select 3 -I'm not sure if this is valid syntax or not. - -> -- | Helper/'default' value for query exprs to make creating query -> -- expr values a little easier. It is defined like this: -> -- -> -- > makeSelect :: QueryExpr -> -- > makeSelect = Select {qeSetQuantifier = SQDefault -> -- > ,qeSelectList = [] -> -- > ,qeFrom = [] -> -- > ,qeWhere = Nothing -> -- > ,qeGroupBy = [] -> -- > ,qeHaving = Nothing -> -- > ,qeOrderBy = [] -> -- > ,qeOffset = Nothing -> -- > ,qeFetchFirst = Nothing} - -> makeSelect :: QueryExpr -> makeSelect = Select {qeSetQuantifier = SQDefault -> ,qeSelectList = [] -> ,qeFrom = [] -> ,qeWhere = Nothing -> ,qeGroupBy = [] -> ,qeHaving = Nothing -> ,qeOrderBy = [] -> ,qeOffset = Nothing -> ,qeFetchFirst = Nothing} - -> -- | Represents the Distinct or All keywords, which can be used -> -- before a select list, in an aggregate/window function -> -- application, or in a query expression set operator. -> data SetQuantifier = SQDefault | Distinct | All deriving (Eq,Show,Read,Data,Typeable) - -> -- | 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) -> -- | Corresponding, an option for the set operators. -> data Corresponding = Corresponding | Respectively deriving (Eq,Show,Read,Data,Typeable) - -> -- | Represents an item in a group by clause. -> data GroupingExpr -> = GroupingParens [GroupingExpr] -> | Cube [GroupingExpr] -> | Rollup [GroupingExpr] -> | GroupingSets [GroupingExpr] -> | SimpleGroup ValueExpr -> deriving (Eq,Show,Read,Data,Typeable) - -> -- | Represents a entry in the csv of tables in the from clause. -> data TableRef = -- | from t / from s.t -> TRSimple [Name] -> -- | from a join b, the bool is true if natural was used -> | TRJoin TableRef Bool JoinType TableRef (Maybe JoinCondition) -> -- | from (a) -> | TRParens TableRef -> -- | from a as b(c,d) -> | TRAlias TableRef Alias -> -- | from (query expr) -> | TRQueryExpr QueryExpr -> -- | from function(args) -> | TRFunction [Name] [ValueExpr] -> -- | from lateral t -> | TRLateral TableRef -> deriving (Eq,Show,Read,Data,Typeable) - -> -- | Represents an alias for a table valued expression, used in with -> -- queries and in from alias, e.g. select a from t u, select a from t u(b), -> -- with a(c) as select 1, select * from a. -> data Alias = Alias Name (Maybe [Name]) -> deriving (Eq,Show,Read,Data,Typeable) - -> -- | The type of a join. -> data JoinType = JInner | JLeft | JRight | JFull | JCross -> deriving (Eq,Show,Read,Data,Typeable) - -> -- | The join condition. -> data JoinCondition = JoinOn ValueExpr -- ^ 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) - - -> -- | Comment. Useful when generating SQL code programmatically. -> data Comment = BlockComment String -> deriving (Eq,Show,Read,Data,Typeable) - diff --git a/README b/README --- a/README +++ b/README @@ -1,5 +1,5 @@ -A parser for SQL queries in Haskell. +A parser for SQL in Haskell. Homepage: http://jakewheat.github.io/simple-sql-parser/latest -Contact: jakewheatmail@gmail.com +Contact: jakewheat@tutanota.com diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,11 +1,86 @@ -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.8.0 lexer has new option to output an invalid token on some kinds of + parse errors + switch tests to hspec + improve parse error messages + * and x.* changed to only parse in some expression contexts - + select items and function application argument lists + support sqlite 'without rowid' + make types in columndefs optional + allow column constraints and defaults to be in arbitrary order + partially support parentheses at query expression level (some nested parens don't parse yet) +0.7.1 fix error message source quoting +0.7.0 support autoincrement for sqlite + support table constraints without separating comma for sqlite + switch source from literate to regular haskell + use megaparsec instead of parsec + use prettyprinter lib instead of pretty + parsing nested block comments regressed - post a bug if you need this + fixed fixity parsing of union, except and intersect (matches postgres docs now) + removed the Errors module - the pretty printer function for errors is in the Parse module + parses from and pretty prints to strict Text + use strict Text instead of String everywhere + tested with latest three main ghc releases (9.8.1, 9.6.4, and 9.4.8) and stack lts 22.5 + the makeSelect helper is now a distinct type, code using it will need some trivial + tweaks, this is change so that code using makeSelect doesn't emit warnings + overhaul website +0.6.1 added odbc handling to sqlsqerver dialect + added sqlserver dialect case for convert function +0.6.0 + tested with ghc 8.8.1 also + change the dialect handling - now a dialect is a bunch of flags + plus a keyword list, and custom dialects are now feasible + (still incomplete) + fix parsing for a lot of things which are keywords in the standard + fix bug with cte pretty printing an extra 'as', which the parser + also incorrectly accepted + bug fix: allow keywords that are quoted to be parsed as identifiers + +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/examples/SimpleSQLParserTool.hs b/examples/SimpleSQLParserTool.hs new file mode 100644 --- /dev/null +++ b/examples/SimpleSQLParserTool.hs @@ -0,0 +1,106 @@ + +{- +Simple command line tool to experiment with simple-sql-parser + +Commands: + +parse: parse sql from file, stdin or from command line +lex: lex sql same +indent: parse then pretty print sql + +TODO: this is supposed to be a simple example, but it's a total mess +write some simple helpers so it's all in text? + +-} + +{-# LANGUAGE TupleSections #-} +import System.Environment (getArgs) +import Control.Monad (forM_, when) +import Data.Maybe (isJust) +import System.Exit (exitFailure) +import Data.List (intercalate) +import Text.Show.Pretty (ppShow) +--import Control.Applicative + +import qualified Data.Text as T + +import Language.SQL.SimpleSQL.Pretty + (prettyStatements) +import Language.SQL.SimpleSQL.Parse + (parseStatements + ,prettyError) +import qualified Language.SQL.SimpleSQL.Lex as L +import Language.SQL.SimpleSQL.Dialect (ansi2011) + + +main :: IO () +main = do + args <- getArgs + case args of + [] -> do + -- exit with 0 in this case + showHelp Nothing -- $ Just "no command given" + (c:as) -> do + let cmd = lookup c commands + maybe (showHelp (Just "command not recognised")) + (\(_,cmd') -> cmd' as) + cmd + +commands :: [(String, (String,[String] -> IO ()))] +commands = + [("help", helpCommand) + ,("parse", parseCommand) + ,("lex", lexCommand) + ,("format", formatCommand)] + +showHelp :: Maybe String -> IO () +showHelp msg = do + maybe (return ()) (\e -> putStrLn $ "Error: " ++ e) msg + putStrLn "Usage:\n SimpleSQLParserTool command args" + forM_ commands $ \(c, (h,_)) -> do + putStrLn $ c ++ "\t" ++ h + when (isJust msg) $ exitFailure + +helpCommand :: (String,[String] -> IO ()) +helpCommand = + ("show help for this progam", \_ -> showHelp Nothing) + +getInput :: [String] -> IO (FilePath,String) +getInput as = + case as of + ["-"] -> ("",) <$> getContents + ("-c":as') -> return ("", unwords as') + [filename] -> (filename,) <$> readFile filename + _ -> showHelp (Just "arguments not recognised") >> error "" + +parseCommand :: (String,[String] -> IO ()) +parseCommand = + ("parse SQL from file/stdin/command line (use -c to parse from command line)" + ,\args -> do + (f,src) <- getInput args + either (error . T.unpack . prettyError) + (putStrLn . ppShow) + $ parseStatements ansi2011 (T.pack f) Nothing (T.pack src) + ) + +lexCommand :: (String,[String] -> IO ()) +lexCommand = + ("lex SQL from file/stdin/command line (use -c to parse from command line)" + ,\args -> do + (f,src) <- getInput args + either (error . T.unpack . L.prettyError) + (putStrLn . intercalate ",\n" . map show) + $ L.lexSQL ansi2011 False (T.pack f) Nothing (T.pack src) + ) + + +formatCommand :: (String,[String] -> IO ()) +formatCommand = + ("parse then pretty print SQL from file/stdin/command line (use -c to parse from command line)" + ,\args -> do + (f,src) <- getInput args + either (error . T.unpack . prettyError) + (putStrLn . T.unpack . prettyStatements ansi2011) + $ parseStatements ansi2011 (T.pack f) Nothing (T.pack src) + + ) diff --git a/simple-sql-parser.cabal b/simple-sql-parser.cabal --- a/simple-sql-parser.cabal +++ b/simple-sql-parser.cabal @@ -1,100 +1,106 @@ +cabal-version: 2.2 + name: simple-sql-parser -version: 0.4.4 -synopsis: A parser for SQL queries +version: 0.8.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 -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Jake Wheat -maintainer: jakewheatmail@gmail.com -copyright: Copyright Jake Wheat 2013, 2014 +maintainer: jakewheat@tutanota.com +copyright: Copyright 2013 - 2024, Jake Wheat and the simple-sql-parser contributors. category: Database,Language build-type: Simple -extra-source-files: README,LICENSE,changelog -cabal-version: >=1.10 +extra-doc-files: README,LICENSE,changelog bug-reports: https://github.com/JakeWheat/simple-sql-parser/issues source-repository head 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.Syntax - Other-Modules: Language.SQL.SimpleSQL.Errors, - Language.SQL.SimpleSQL.Combinators - other-extensions: TupleSections - build-depends: base >=4 && <5, - parsec >=3.1 && <3.2, - mtl >=2.1 && <2.3, - pretty >= 1.1 && < 1.2 - -- hs-source-dirs: +common shared-properties default-language: Haskell2010 + build-depends: base >=4 && <5, + megaparsec >=9.6 && <9.7, + parser-combinators >= 1.3 && < 1.4, + mtl >=2.1 && <2.4, + prettyprinter >= 1.7 && < 1.8, + text >= 2.0 && < 2.2, + containers >= 0.6 && < 0.8 ghc-options: -Wall - other-extensions: TupleSections,DeriveDataTypeable + +library + import: shared-properties + exposed-modules: Language.SQL.SimpleSQL.Pretty, + Language.SQL.SimpleSQL.Parse, + Language.SQL.SimpleSQL.Lex, + Language.SQL.SimpleSQL.Syntax, + Language.SQL.SimpleSQL.Dialect Test-Suite Tests + import: shared-properties type: exitcode-stdio-1.0 - main-is: RunTests.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, - - HUnit >= 1.2 && < 1.7, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4 - - Other-Modules: Language.SQL.SimpleSQL.Pretty, - Language.SQL.SimpleSQL.Parser, - Language.SQL.SimpleSQL.Syntax, - Language.SQL.SimpleSQL.Errors, - Language.SQL.SimpleSQL.Combinators + main-is: RunTests.hs + hs-source-dirs: tests + Build-Depends: simple-sql-parser, + hspec, + hspec-megaparsec, + hspec-expectations, + raw-strings-qq, + hspec-golden, + filepath, + pretty-show, - --Language.SQL.SimpleSQL.ErrorMessages, + Other-Modules: 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.QueryExprParens, + 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 - - other-extensions: TupleSections,DeriveDataTypeable - default-language: Haskell2010 - ghc-options: -Wall + Language.SQL.SimpleSQL.ScalarExprs, + Language.SQL.SimpleSQL.LexerTests, + Language.SQL.SimpleSQL.CustomDialect, + Language.SQL.SimpleSQL.EmptyStatement, + Language.SQL.SimpleSQL.CreateIndex + Language.SQL.SimpleSQL.Expectations + Language.SQL.SimpleSQL.TestRunners + + ghc-options: -threaded -executable SQLIndent - main-is: SQLIndent.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 - other-extensions: TupleSections,DeriveDataTypeable - default-language: Haskell2010 - ghc-options: -Wall - if flag(sqlindent) +-- this is a testing tool, do some dumb stuff to hide the dependencies in hackage +Test-Suite SimpleSQLParserTool + import: shared-properties + type: exitcode-stdio-1.0 + main-is: SimpleSQLParserTool.hs + hs-source-dirs: examples + Build-Depends: simple-sql-parser, + pretty-show >= 1.6 && < 1.10 + if flag(parserexe) buildable: True else buildable: False + diff --git a/tests/Language/SQL/SimpleSQL/CreateIndex.hs b/tests/Language/SQL/SimpleSQL/CreateIndex.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/CreateIndex.hs @@ -0,0 +1,22 @@ + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.CreateIndex where + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +createIndexTests :: TestItem +createIndexTests = Group "create index tests" + [s "create index a on tbl(c1)" + $ CreateIndex False [nm "a"] [nm "tbl"] [nm "c1"] + ,s "create index a.b on sc.tbl (c1, c2)" + $ CreateIndex False [nm "a", nm "b"] [nm "sc", nm "tbl"] [nm "c1", nm "c2"] + ,s "create unique index a on tbl(c1)" + $ CreateIndex True [nm "a"] [nm "tbl"] [nm "c1"] + ] + where + nm = Name Nothing + s :: HasCallStack => Text -> Statement -> TestItem + s src ast = testStatement ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/CustomDialect.hs b/tests/Language/SQL/SimpleSQL/CustomDialect.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/CustomDialect.hs @@ -0,0 +1,32 @@ + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.CustomDialect (customDialectTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +customDialectTests :: TestItem +customDialectTests = Group "custom dialect tests" $ + [q ansi2011 "SELECT a b" + ,q noDateKeyword "SELECT DATE('2000-01-01')" + ,q noDateKeyword "SELECT DATE" + ,q dateApp "SELECT DATE('2000-01-01')" + ,q dateIden "SELECT DATE" + ,f ansi2011 "SELECT DATE('2000-01-01')" + ,f ansi2011 "SELECT DATE" + ,f dateApp "SELECT DATE" + ,f dateIden "SELECT DATE('2000-01-01')" + -- show this never being allowed as an alias + ,f ansi2011 "SELECT a date" + ,f dateApp "SELECT a date" + ,f dateIden "SELECT a date" + ] + where + noDateKeyword = ansi2011 {diKeywords = filter (/="date") (diKeywords ansi2011)} + dateIden = ansi2011 {diIdentifierKeywords = "date" : diIdentifierKeywords ansi2011} + dateApp = ansi2011 {diAppKeywords = "date" : diAppKeywords ansi2011} + q :: HasCallStack => Dialect -> Text -> TestItem + q d src = testParseQueryExpr d src + f :: HasCallStack => Dialect -> Text -> TestItem + f d src = testParseQueryExprFails d src diff --git a/tests/Language/SQL/SimpleSQL/EmptyStatement.hs b/tests/Language/SQL/SimpleSQL/EmptyStatement.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/EmptyStatement.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.EmptyStatement where + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +emptyStatementTests :: TestItem +emptyStatementTests = Group "empty statement" + [ s ";" EmptyStatement + , t ";" [EmptyStatement] + , t ";;" [EmptyStatement, EmptyStatement] + , t ";;;" [EmptyStatement, EmptyStatement, EmptyStatement] + , s "/* comment */ ;" EmptyStatement + , t "" [] + , t "/* comment */" [] + , t "/* comment */ ;" [EmptyStatement] + , t "/* comment */ ; /* comment */ ;" + [EmptyStatement, EmptyStatement] + , t "/* comment */ ; /* comment */ ; /* comment */ ;" + [EmptyStatement, EmptyStatement, EmptyStatement] + ] + where + s :: HasCallStack => Text -> Statement -> TestItem + s src a = testStatement ansi2011 src a + t :: HasCallStack => Text -> [Statement] -> TestItem + t src a = testStatements ansi2011 src a diff --git a/tests/Language/SQL/SimpleSQL/ErrorMessages.hs b/tests/Language/SQL/SimpleSQL/ErrorMessages.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/ErrorMessages.hs @@ -0,0 +1,697 @@ + +{- + +Quick tests for error messages, all the tests use the entire formatted +output of parse failures to compare, it's slightly fragile. Most of +the tests use a huge golden file which contains tons of parse error +examples. + +-} + + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Language.SQL.SimpleSQL.ErrorMessages + (errorMessageTests + ) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Parse +import qualified Language.SQL.SimpleSQL.Lex as L +import Language.SQL.SimpleSQL.TestRunners +--import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.Expectations +import Test.Hspec (it) +import Debug.Trace + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Test.Hspec.Golden + (Golden(..) + ) + +import qualified Text.RawString.QQ as R +import System.FilePath (()) +import Text.Show.Pretty (ppShow) + +errorMessageTests :: TestItem +errorMessageTests = Group "error messages" + [gp (parseQueryExpr ansi2011 "" Nothing) prettyError [R.r| + +select +a +from t +where + something +order by 1,2,3 where + + |] + [R.r|8:16: + | +8 | order by 1,2,3 where + | ^^^^^ +unexpected where +|] + ,gp (L.lexSQL ansi2011 False "" Nothing) L.prettyError [R.r| + +select +a +from t +where + something +order by 1,2,3 $@ + + |] + [R.r|8:16: + | +8 | order by 1,2,3 $@ + | ^ +unexpected '$' +|] + ,let fn = "expected-parse-errors" + got = generateParseResults parseErrorData + in GoldenErrorTest fn parseErrorData $ it "parse error regressions" $ myGolden (T.unpack fn) got + ] + where + gp :: (Show a, HasCallStack) => (Text -> Either e a) -> (e -> Text) -> Text -> Text -> TestItem + gp parse pret src err = + GeneralParseFailTest src err $ + it (T.unpack src) $ + let f1 = parse src + ex = shouldFailWith pret + quickTrace = + case f1 of + Left f | pret f /= err -> + trace (T.unpack ("check\n[" <> pret f <>"]\n["<> err <> "]\n")) + _ -> id + in quickTrace (f1 `ex` err) + +------------------------------------------------------------------------------ + +-- golden parse error tests + +myGolden :: String -> Text -> Golden Text +myGolden name actualOutput = + Golden { + output = actualOutput, + encodePretty = show, + writeToFile = T.writeFile, + readFromFile = T.readFile, + goldenFile = name "golden", + actualFile = Just (name "actual"), + failFirstTime = False + } + +parseErrorData :: [(Text,Text,Text)] +parseErrorData = + concat + [simpleExpressions1 + ,pgExprs + ,sqlServerIden + ,mysqliden + ,paramvariations + ,odbcexpr + ,odbcqexpr + ,queryExprExamples + ,statementParseErrorExamples] + +generateParseResults :: [(Text,Text,Text)] -> Text +generateParseResults dat = + let testLine (parser,dialect,src) = + let d = case dialect of + "ansi2011" -> ansi2011 + "postgres" -> postgres + "sqlserver" -> sqlserver + "mysql" -> mysql + "params" -> ansi2011{diAtIdentifier=True, diHashIdentifier= True} + "odbc" -> ansi2011{diOdbc=True} + _ -> error $ "unknown dialect: " <> T.unpack dialect + res = case parser of + "queryExpr" -> + either prettyError (T.pack . ppShow) + $ parseQueryExpr d "" Nothing src + "scalarExpr" -> + either prettyError (T.pack . ppShow) + $ parseScalarExpr d "" Nothing src + "statement" -> + either prettyError (T.pack . ppShow) + $ parseStatement d "" Nothing src + _ -> error $ "unknown parser: " <> T.unpack parser + -- prepend a newline to multi line fields, so they show + -- nice in a diff in meld or similar + resadj = if '\n' `T.elem` res + then T.cons '\n' res + else res + in T.unlines [parser, dialect, src, resadj] + in T.unlines $ map testLine dat + +parseExampleStrings :: Text -> [Text] +parseExampleStrings = filter (not . T.null) . map T.strip . T.splitOn ";" + +simpleExpressions1 :: [(Text,Text,Text)] +simpleExpressions1 = + concat $ flip map (parseExampleStrings simpleExprData) $ \e -> + [("scalarExpr", "ansi2011", e) + ,("queryExpr", "ansi2011", "select " <> e) + ,("queryExpr", "ansi2011", "select " <> e <> ",") + ,("queryExpr", "ansi2011", "select " <> e <> " from")] + where + simpleExprData = [R.r| +'test +; +'test''t +; +'test'' +; +3.23e- +; +. +; +3.23e +; +a.3 +; +3.a +; +3.2a +; +4iden +; +4iden. +; +iden.4iden +; +4iden.* +; +from +; +from.a +; +a.from +; +not +; +4 + +; +4 + from +; +(5 +; +(5 + +; +(5 + 6 +; +(5 + from) +; +case +; +case a +; +case a when b c end +; +case a when b then c +; +case a else d end +; +case a from c end +; +case a when from then to end +; +/* blah +; +/* blah /* stuff */ +; +/* * +; +/* / +; +$$something$ +; +$$something +; +$$something +x +; +$a$something$b$ +; +$a$ +; +''' +; +''''' +; +"a +; +"a"" +; +""" +; +""""" +; +"" +; +*/ +; +:3 +; +@3 +; +#3 +; +::: +; +||| +; +... +; +" +; +] +; +) +; +[test +; +[] +; +[[test]] +; +`open +; +``` +; +`` +; +} +; +mytype(4 '4'; +; +app(3 +; +app( +; +app(something +; +app(something, +; +count(* +; +count(* filter (where something > 5) +; +count(*) filter (where something > 5 +; +count(*) filter ( +; +sum(a over (order by b) +; +sum(a) over (order by b +; +sum(a) over ( +; +rank(a,c within group (order by b) +; +rank(a,c) within group (order by b +; +rank(a,c) within group ( +; +array[ +; +(a +; +( +; +a >* +; +a >* b +; +( ( a +; +( ( a ) +; +( ( a + ) +|] + +pgExprs :: [(Text,Text,Text)] +pgExprs = flip map (parseExampleStrings src) $ \e -> + ("scalarExpr", "postgres", e) + where src = [R.r| +$$something$ +; +$$something +; +$$something +x +; +$a$something$b$ +; +$a$ +; +::: +; +||| +; +... +; + +|] + +sqlServerIden :: [(Text,Text,Text)] +sqlServerIden = flip map (parseExampleStrings src) $ \e -> + ("scalarExpr", "sqlserver", e) + where src = [R.r| +] +; +[test +; +[] +; +[[test]] + +|] + +mysqliden :: [(Text,Text,Text)] +mysqliden = flip map (parseExampleStrings src) $ \e -> + ("scalarExpr", "mysql", e) + where src = [R.r| +`open +; +``` +; +`` + +|] + +paramvariations :: [(Text,Text,Text)] +paramvariations = flip map (parseExampleStrings src) $ \e -> + ("scalarExpr", "params", e) + where src = [R.r| +:3 +; +@3 +; +#3 + +|] + + +odbcexpr :: [(Text,Text,Text)] +odbcexpr = flip map (parseExampleStrings src) $ \e -> + ("scalarExpr", "odbc", e) + where src = [R.r| +{d '2000-01-01' +; +{fn CHARACTER_LENGTH(string_exp) + +|] + +odbcqexpr :: [(Text,Text,Text)] +odbcqexpr = flip map (parseExampleStrings src) $ \e -> + ("queryExpr", "odbc", e) + where src = [R.r| +select * from {oj t1 left outer join t2 on expr + +|] + + + +queryExprExamples :: [(Text,Text,Text)] +queryExprExamples = flip map (parseExampleStrings src) $ \e -> + ("queryExpr", "ansi2011", e) + where src = [R.r| +select a select +; +select a from t, +; +select a from t select +; +select a from t(a) +; +select a from (t +; +select a from (t having +; +select a from t a b +; +select a from t as +; +select a from t as having +; +select a from (1234) +; +select a from (1234 +; +select a from a wrong join b +; +select a from a natural wrong join b +; +select a from a left wrong join b +; +select a from a left wrong join b +; +select a from a join b select +; +select a from a join b on select +; +select a from a join b on (1234 +; +select a from a join b using(a +; +select a from a join b using(a, +; +select a from a join b using(a,) +; +select a from a join b using(1234 +; +select a from t order no a +; +select a from t order by a where c +; +select 'test +' +; +select a as +; +select a as from t +; +select a as, +; +select a, +; +select a, from t +; +select a as from +; +select a as from from +; +select a as from2 from +; +select a fromt +; +select a b fromt + +; +select a from t u v +; +select a from t as +; +select a from t, +; +select a from group by b +; +select a from t join group by a +; +select a from t join +; +select a from (@ +; +select a from () +; +select a from t left join u on +; +select a from t left join u on group by a +; +select a from t left join u using +; +select a from t left join u using ( +; +select a from t left join u using (a +; +select a from t left join u using (a, +; +select a from (select a from) +; +select a from (select a + +; +select a from t where +; +select a from t group by a having b where +; +select a from t where (a +; +select a from t where group by b + +; +select a from t group by +; +select a from t group +; +select a from t group by a as +; +select a from t group by a, +; +select a from t group by order by +; +select a <<== b from t +; +/* +; +select * as a +; +select t.* as a +; +select 3 + * +; +select case when * then 1 end +; +select (*) +; +select * from (select a + from t +; +select * from (select a(stuff) + from t + +; +select * + from (select a,b + from t + where a = 1 + and b > a + +; +select * + from (select a,b + from t + where a = 1 + and b > a + from t) + +|] + + +statementParseErrorExamples :: [(Text,Text,Text)] +statementParseErrorExamples = flip map (parseExampleStrings src) $ \e -> + ("statement", "ansi2011", e) + where src = [R.r| +create +; +drop +; +delete this +; +delete where 7 +; +delete from where t +; +truncate nothing +; +truncate nothing nothing +; +truncate table from +; +truncate table t u +; +insert t select u +; +insert into t insert +; +insert into t (1,2) +; +insert into t( +; +insert into t(1 +; +insert into t(a +; +insert into t(a, +; +insert into t(a,b) +; +insert into t(a,b) values +; +insert into t(a,b) values ( +; +insert into t(a,b) values (1 +; +insert into t(a,b) values (1, +; +insert into t(a,b) values (1,2) and stuff +; +update set 1 +; +update t u +; +update t u v +; +update t set a +; +update t set a= +; +update t set a=1, +; +update t set a=1 where +; +update t set a=1 where 1 also +; +create table +; +create table t ( + a +) +; +create table t ( + a +; +create table t ( + a, +) +; +create table t ( +) +; +create table t ( +; +create table t +; +create table t. ( +; +truncate table t. +; +drop table t. where +; +update t. set +; +delete from t. where +; +insert into t. values +; +with a as (select * from t +select 1 +; +with a as (select * from t +; +with a as ( +; +with a ( +; +with as (select * from t) +select 1 +; +with (select * from t) as a +select 1 + + +|] + diff --git a/tests/Language/SQL/SimpleSQL/Expectations.hs b/tests/Language/SQL/SimpleSQL/Expectations.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Expectations.hs @@ -0,0 +1,61 @@ + +module Language.SQL.SimpleSQL.Expectations + (shouldParseA + ,shouldParseL + ,shouldParse1 + ,shouldFail + ,shouldSucceed + ,shouldFailWith + ) where + + +import Language.SQL.SimpleSQL.Parse +import qualified Language.SQL.SimpleSQL.Lex as Lex + +import qualified Data.Text as T +import Data.Text (Text) + +import Test.Hspec.Expectations + (Expectation + ,HasCallStack + ,expectationFailure + ) + +import Test.Hspec + (shouldBe + ) + +shouldParseA :: (HasCallStack,Eq a, Show a) => Either ParseError a -> a -> Expectation +shouldParseA = shouldParse1 (T.unpack . prettyError) + +shouldParseL :: (HasCallStack,Eq a, Show a) => Either Lex.ParseError a -> a -> Expectation +shouldParseL = shouldParse1 (T.unpack . Lex.prettyError) + +shouldParse1 :: (HasCallStack, Show a, Eq a) => + (e -> String) + -> Either e a + -> a + -> Expectation +shouldParse1 prettyErr r v = case r of + Left e -> + expectationFailure $ + "expected: " + ++ show v + ++ "\nbut parsing failed with error:\n" + ++ prettyErr e + Right x -> x `shouldBe` v + +shouldFail :: (HasCallStack, Show a) => Either e a -> Expectation +shouldFail r = case r of + Left _ -> (1 :: Int) `shouldBe` 1 + Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a + +shouldFailWith :: (HasCallStack, Show a) => (e -> Text) -> Either e a -> Text -> Expectation +shouldFailWith p r e = case r of + Left e1 -> p e1 `shouldBe` e + Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a + +shouldSucceed :: (HasCallStack) => (e -> String) -> Either e a -> Expectation +shouldSucceed pe r = case r of + Left e -> expectationFailure $ "expected parse success, but got: " <> pe e + Right _ -> (1 :: Int) `shouldBe` 1 diff --git a/tests/Language/SQL/SimpleSQL/FullQueries.hs b/tests/Language/SQL/SimpleSQL/FullQueries.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/FullQueries.hs @@ -0,0 +1,43 @@ + +-- Some tests for parsing full queries. + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.FullQueries (fullQueriesTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +fullQueriesTests :: TestItem +fullQueriesTests = Group "queries" $ + [q "select count(*) from t" + $ toQueryExpr $ makeSelect + {msSelectList = [(App [Name Nothing "count"] [Star], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + } + + ,q "select a, sum(c+d) as s\n\ + \ from t,u\n\ + \ where a > 5\n\ + \ group by a\n\ + \ having count(1) > 5\n\ + \ order by s" + $ toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing) + ,(App [Name Nothing "sum"] + [BinOp (Iden [Name Nothing "c"]) + [Name Nothing "+"] (Iden [Name Nothing "d"])] + ,Just $ Name Nothing "s")] + ,msFrom = [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]] + ,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5") + ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] + ,msHaving = Just $ BinOp (App [Name Nothing "count"] [NumLit "1"]) + [Name Nothing ">"] (NumLit "5") + ,msOrderBy = [SortSpec (Iden [Name Nothing "s"]) DirDefault NullsOrderDefault] + } + + ] + where + q :: HasCallStack => Text -> QueryExpr -> TestItem + q src a = testQueryExpr ansi2011 src a diff --git a/tests/Language/SQL/SimpleSQL/GroupBy.hs b/tests/Language/SQL/SimpleSQL/GroupBy.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/GroupBy.hs @@ -0,0 +1,248 @@ + +-- Here are the tests for the group by component of query exprs + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.GroupBy (groupByTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + + +groupByTests :: TestItem +groupByTests = Group "groupByTests" + [simpleGroupBy + ,newGroupBy + ,randomGroupBy + ] + +q :: HasCallStack => Text -> QueryExpr -> TestItem +q src a = testQueryExpr ansi2011 src a + +p :: HasCallStack => Text -> TestItem +p src = testParseQueryExpr ansi2011 src + + + +simpleGroupBy :: TestItem +simpleGroupBy = Group "simpleGroupBy" + [q "select a,sum(b) from t group by a" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] + } + + ,q "select a,b,sum(c) from t group by a,b" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing) + ,(Iden [Name Nothing "b"],Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "c"]],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"] + ,SimpleGroup $ Iden [Name Nothing "b"]] + } + ] + +{- +test the new group by (), grouping sets, cube and rollup syntax (not +sure which sql version they were introduced, 1999 or 2003 I think). +-} + +newGroupBy :: TestItem +newGroupBy = Group "newGroupBy" + [q "select * from t group by ()" $ ms [GroupingParens []] + ,q "select * from t group by grouping sets ((), (a))" + $ ms [GroupingSets [GroupingParens [] + ,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"]]]] + ,q "select * from t group by cube(a,b)" + $ ms [Cube [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]] + ,q "select * from t group by rollup(a,b)" + $ ms [Rollup [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]] + ] + where + ms g = toQueryExpr $ makeSelect {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = g} + +randomGroupBy :: TestItem +randomGroupBy = Group "randomGroupBy" + [p "select * from t GROUP BY a" + ,p "select * from t GROUP BY GROUPING SETS((a))" + ,p "select * from t GROUP BY a,b,c" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c))" + ,p "select * from t GROUP BY ROLLUP(a,b)" + ,p "select * from t GROUP BY GROUPING SETS((a,b),\n\ + \(a),\n\ + \() )" + ,p "select * from t GROUP BY ROLLUP(b,a)" + ,p "select * from t GROUP BY GROUPING SETS((b,a),\n\ + \(b),\n\ + \() )" + ,p "select * from t GROUP BY CUBE(a,b,c)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\ + \(a,b),\n\ + \(a,c),\n\ + \(b,c),\n\ + \(a),\n\ + \(b),\n\ + \(c),\n\ + \() )" + ,p "select * from t GROUP BY ROLLUP(Province, County, City)" + ,p "select * from t GROUP BY ROLLUP(Province, (County, City))" + ,p "select * from t GROUP BY ROLLUP(Province, (County, City))" + ,p "select * from t GROUP BY GROUPING SETS((Province, County, City),\n\ + \(Province),\n\ + \() )" + ,p "select * from t GROUP BY GROUPING SETS((Province, County, City),\n\ + \(Province, County),\n\ + \(Province),\n\ + \() )" + ,p "select * from t GROUP BY a, ROLLUP(b,c)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\ + \(a,b),\n\ + \(a) )" + ,p "select * from t GROUP BY a, b, ROLLUP(c,d)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\ + \(a,b,c),\n\ + \(a,b) )" + ,p "select * from t GROUP BY ROLLUP(a), ROLLUP(b,c)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\ + \(a,b),\n\ + \(a),\n\ + \(b,c),\n\ + \(b),\n\ + \() )" + ,p "select * from t GROUP BY ROLLUP(a), CUBE(b,c)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c),\n\ + \(a,b),\n\ + \(a,c),\n\ + \(a),\n\ + \(b,c),\n\ + \(b),\n\ + \(c),\n\ + \() )" + ,p "select * from t GROUP BY CUBE(a,b), ROLLUP(c,d)" + ,p "select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\ + \(a,b,c),\n\ + \(a,b),\n\ + \(a,c,d),\n\ + \(a,c),\n\ + \(a),\n\ + \(b,c,d),\n\ + \(b,c),\n\ + \(b),\n\ + \(c,d),\n\ + \(c),\n\ + \() )" + ,p "select * from t GROUP BY a, ROLLUP(a,b)" + ,p "select * from t GROUP BY GROUPING SETS((a,b),\n\ + \(a) )" + ,p "select * from t GROUP BY Region,\n\ + \ROLLUP(Sales_Person, WEEK(Sales_Date)),\n\ + \CUBE(YEAR(Sales_Date), MONTH (Sales_Date))" + ,p "select * from t GROUP BY ROLLUP (Region, Sales_Person, WEEK(Sales_Date),\n\ + \YEAR(Sales_Date), MONTH(Sales_Date) )" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \WHERE WEEK(SALES_DATE) = 13\n\ + \GROUP BY WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON\n\ + \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \WHERE WEEK(SALES_DATE) = 13\n\ + \GROUP BY GROUPING SETS ( (WEEK(SALES_DATE), SALES_PERSON),\n\ + \(DAYOFWEEK(SALES_DATE), SALES_PERSON))\n\ + \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \WHERE WEEK(SALES_DATE) = 13\n\ + \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\ + \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \WHERE WEEK(SALES_DATE) = 13\n\ + \GROUP BY CUBE ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\ + \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" + + ,p "SELECT SALES_PERSON,\n\ + \MONTH(SALES_DATE) AS MONTH,\n\ + \SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \GROUP BY GROUPING SETS ( (SALES_PERSON, MONTH(SALES_DATE)),\n\ + \()\n\ + \)\n\ + \ORDER BY SALES_PERSON, MONTH" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE) )\n\ + \ORDER BY WEEK, DAY_WEEK" + + ,p "SELECT MONTH(SALES_DATE) AS MONTH,\n\ + \REGION,\n\ + \SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \GROUP BY ROLLUP ( MONTH(SALES_DATE), REGION )\n\ + \ORDER BY MONTH, REGION" + + ,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \MONTH(SALES_DATE) AS MONTH,\n\ + \REGION,\n\ + \SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES\n\ + \GROUP BY GROUPING SETS ( ROLLUP( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE) ),\n\ + \ROLLUP( MONTH(SALES_DATE), REGION ) )\n\ + \ORDER BY WEEK, DAY_WEEK, MONTH, REGION" + + ,p "SELECT R1, R2,\n\ + \WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \MONTH(SALES_DATE) AS MONTH,\n\ + \REGION, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES,(VALUES('GROUP 1','GROUP 2')) AS X(R1,R2)\n\ + \GROUP BY GROUPING SETS ((R1, ROLLUP(WEEK(SALES_DATE),\n\ + \DAYOFWEEK(SALES_DATE))),\n\ + \(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\ + \ORDER BY WEEK, DAY_WEEK, MONTH, REGION" + + {-,p "SELECT COALESCE(R1,R2) AS GROUP,\n\ + \WEEK(SALES_DATE) AS WEEK,\n\ + \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ + \MONTH(SALES_DATE) AS MONTH,\n\ + \REGION, SUM(SALES) AS UNITS_SOLD\n\ + \FROM SALES,(VALUES('GROUP 1','GROUP 2')) AS X(R1,R2)\n\ + \GROUP BY GROUPING SETS ((R1, ROLLUP(WEEK(SALES_DATE),\n\ + \DAYOFWEEK(SALES_DATE))),\n\ + \(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\ + \ORDER BY GROUP, WEEK, DAY_WEEK, MONTH, REGION"-} + -- as group - needs more subtle keyword blacklisting + + -- decimal as a function not allowed due to the reserved keyword + -- handling: todo, review if this is ansi standard function or + -- if there are places where reserved keywords can still be used + ,p "SELECT MONTH(SALES_DATE) AS MONTH,\n\ + \REGION,\n\ + \SUM(SALES) AS UNITS_SOLD,\n\ + \MAX(SALES) AS BEST_SALE,\n\ + \CAST(ROUND(AVG(DECIMALx(SALES)),2) AS DECIMAL(5,2)) AS AVG_UNITS_SOLD\n\ + \FROM SALES\n\ + \GROUP BY CUBE(MONTH(SALES_DATE),REGION)\n\ + \ORDER BY MONTH, REGION" + + ] diff --git a/tests/Language/SQL/SimpleSQL/LexerTests.hs b/tests/Language/SQL/SimpleSQL/LexerTests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/LexerTests.hs @@ -0,0 +1,428 @@ + + +-- Test for the lexer + + +{- +TODO: +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. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.LexerTests (lexerTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Lex + (Token(..) + ,tokenListWillPrintAndLex + ) +import Language.SQL.SimpleSQL.TestRunners + +import qualified Data.Text as T +import Data.Text (Text) + +--import Debug.Trace +--import Data.Char (isAlpha) +-- import Data.List + +lexerTests :: TestItem +lexerTests = Group "lexerTests" $ + [bootstrapTests + ,ansiLexerTests + ,postgresLexerTests + ,sqlServerLexerTests + ,oracleLexerTests + ,mySqlLexerTests + ,odbcLexerTests + ] + +-- quick sanity tests to see something working +bootstrapTests :: TestItem +bootstrapTests = Group "bootstrap tests" $ + [t "iden" [Identifier Nothing "iden"] + + ,t "\"a1normal \"\" iden\"" [Identifier (Just ("\"","\"")) "a1normal \"\" iden"] + + ,t "'string'" [SqlString "'" "'" "string"] + + ,t " " [Whitespace " "] + ,t "\t " [Whitespace "\t "] + ,t " \n " [Whitespace " \n "] + + ,t "--" [LineComment "--"] + ,t "--\n" [LineComment "--\n"] + ,t "--stuff" [LineComment "--stuff"] + ,t "-- stuff" [LineComment "-- stuff"] + ,t "-- stuff\n" [LineComment "-- stuff\n"] + ,t "--\nstuff" [LineComment "--\n", Identifier Nothing "stuff"] + ,t "-- com \nstuff" [LineComment "-- com \n", Identifier Nothing "stuff"] + + ,t "/*test1*/" [BlockComment "/*test1*/"] + ,t "/**/" [BlockComment "/**/"] + ,t "/***/" [BlockComment "/***/"] + ,t "/* * */" [BlockComment "/* * */"] + ,t "/*test*/" [BlockComment "/*test*/"] + ,t "/*te/*st*/*/" [BlockComment "/*te/*st*/*/"] + ,t "/*te*st*/" [BlockComment "/*te*st*/"] + ,t "/*lines\nmore lines*/" [BlockComment "/*lines\nmore lines*/"] + ,t "/*test1*/\n" [BlockComment "/*test1*/", Whitespace "\n"] + ,t "/*test1*/stuff" [BlockComment "/*test1*/", Identifier Nothing "stuff"] + + ,t "1" [SqlNumber "1"] + ,t "42" [SqlNumber "42"] + + ,tp "$1" [PositionalArg 1] + ,tp "$200" [PositionalArg 200] + + ,t ":test" [PrefixedVariable ':' "test"] + + ] ++ map (\a -> t a [Symbol a]) ( + ["!=", "<>", ">=", "<=", "||"] + ++ map T.singleton ("(),-+*/<>=." :: [Char])) + where + t :: HasCallStack => Text -> [Token] -> TestItem + t src ast = testLex ansi2011 src ast + tp :: HasCallStack => Text -> [Token] -> TestItem + tp src ast = testLex ansi2011{diPositionalArg=True} src ast + + +ansiLexerTable :: [(Text,[Token])] +ansiLexerTable = + -- single char symbols + map (\s -> (T.singleton s,[Symbol $ T.singleton 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 -> (T.cons ':' i, [PrefixedVariable ':' i])) idens + ) + -- quoted identifiers with embedded double quotes + -- the lexer doesn't unescape the quotes + ++ [("\"anormal \"\" iden\"", [Identifier (Just ("\"","\"")) "anormal \"\" 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 [[(T.singleton a,[Whitespace $ T.singleton a]) + ,(T.singleton a <> T.singleton b, [Whitespace (T.singleton a <> T.singleton 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" $ [l s t | (s,t) <- ansiLexerTable] + ,Group "ansi generated combination lexer tests" $ + [ l (s <> s1) (t <> t1) + | (s,t) <- ansiLexerTable + , (s1,t1) <- ansiLexerTable + , tokenListWillPrintAndLex ansi2011 $ t <> t1 + + ] + ,Group "ansiadhoclexertests" $ + [l "" [] + ,l "-- line com\nstuff" [LineComment "-- line com\n",Identifier Nothing "stuff"] + ] ++ + [-- want to make sure this gives a parse error + f "*/" + -- 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 + ,f "|||" + ,f "||||" + ,f "|||||" + -- 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 + ,f "12e3e4" + ,f "12e3e4" + ,f "12e3e4" + ,f "12e3.4" + ,f "12.4.5" + ,f "12.4e5.6" + ,f "12.4e5e7"] + ] + where + l :: HasCallStack => Text -> [Token] -> TestItem + l src ast = testLex ansi2011 src ast + f :: HasCallStack => Text -> TestItem + f src = lexFails ansi2011 src + + +{- +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 :: [(Text,[Token])] +postgresLexerTable = + -- single char symbols + map (\s -> (T.singleton s,[Symbol $ T.singleton 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 -> (T.cons ':' 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 [[(T.singleton a,[Whitespace $ T.singleton a]) + ,(T.singleton a <> T.singleton b, [Whitespace $ T.singleton a <> T.singleton 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 :: [(Text,[Token])] +postgresShortOperatorTable = + [ (x, [Symbol x]) | x <- someValidPostgresOperators 2] + + +postgresExtraOperatorTable :: [(Text,[Token])] +postgresExtraOperatorTable = + [ (x, [Symbol x]) | x <- someValidPostgresOperators 4] + + +someValidPostgresOperators :: Int -> [Text] +someValidPostgresOperators l = + [ x + | n <- [1..l] + , x <- combos "+-*/<>=~!@#%^&|`?" n + , not ("--" `T.isInfixOf` x || "/*" `T.isInfixOf` x || "*/" `T.isInfixOf` x) + , not (T.last x `T.elem` "+-") + || or (map (`T.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 -> [Text] +somePostgresOpsWhichWontAddTrailingPlusMinus l = + [ x + | n <- [1..l] + , x <- combos "+-*/<>=" n + , not ("--" `T.isInfixOf` x || "/*" `T.isInfixOf` x || "*/" `T.isInfixOf` x) + , not (T.last x `T.elem` "+-") + ] + +postgresLexerTests :: TestItem +postgresLexerTests = Group "postgresLexerTests" $ + [Group "postgres lexer token tests" $ + [l s t | (s,t) <- postgresLexerTable] + ,Group "postgres generated lexer token tests" $ + [l s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable] + ,Group "postgres generated combination lexer tests" $ + [ l (s <> s1) (t <> t1) + | (s,t) <- postgresLexerTable ++ postgresShortOperatorTable + , (s1,t1) <- postgresLexerTable ++ postgresShortOperatorTable + , tokenListWillPrintAndLex postgres $ t ++ t1 + + ] + ,Group "generated postgres edgecase lexertests" $ + [l 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 + [f "*/" + ,f ":::" + ,f "::::" + ,f ":::::" + ,f "@*/" + ,f "-*/" + ,f "12e3e4" + ,f "12e3e4" + ,f "12e3e4" + ,f "12e3.4" + ,f "12.4.5" + ,f "12.4e5.6" + ,f "12.4e5e7" + -- special case allow this to lex to 1 .. 2 + -- this is for 'for loops' in plpgsql + ,l "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"] + ] + ] + where + edgeCaseCommentOps = + [ (x <> "/* "-- "+", [Symbol x, Symbol "+"]) + , (x <> "-", [Symbol x, Symbol "-"]) ] + | x <- somePostgresOpsWhichWontAddTrailingPlusMinus 2 + ] + edgeCasePlusMinusComments = + [("---", [LineComment "---"]) + ,("+--", [Symbol "+", LineComment "--"]) + ,("-/**/", [Symbol "-", BlockComment "/**/"]) + ,("+/**/", [Symbol "+", BlockComment "/**/"]) + ] + l :: HasCallStack => Text -> [Token] -> TestItem + l src ast = testLex postgres src ast + f :: HasCallStack => Text -> TestItem + f src = lexFails postgres src + +sqlServerLexerTests :: TestItem +sqlServerLexerTests = Group "sqlServerLexTests" $ + [l s t | (s,t) <- + [("@variable", [(PrefixedVariable '@' "variable")]) + ,("#variable", [(PrefixedVariable '#' "variable")]) + ,("[quoted identifier]", [(Identifier (Just ("[", "]")) "quoted identifier")]) + ]] + where + l :: HasCallStack => Text -> [Token] -> TestItem + l src ast = testLex sqlserver src ast + +oracleLexerTests :: TestItem +oracleLexerTests = Group "oracleLexTests" $ + [] -- nothing oracle specific atm + +mySqlLexerTests :: TestItem +mySqlLexerTests = Group "mySqlLexerTests" $ + [ l s t | (s,t) <- + [("`quoted identifier`", [(Identifier (Just ("`", "`")) "quoted identifier")]) + ] + ] + where + l :: HasCallStack => Text -> [Token] -> TestItem + l src ast = testLex mysql src ast + +odbcLexerTests :: TestItem +odbcLexerTests = Group "odbcLexTests" $ + [ lo s t | (s,t) <- + [("{}", [Symbol "{", Symbol "}"]) + ]] + ++ [lno "{" + ,lno "}"] + where + lo :: HasCallStack => Text -> [Token] -> TestItem + lo src ast = testLex (sqlserver {diOdbc = True}) src ast + lno :: HasCallStack => Text -> TestItem + lno src = lexFails (sqlserver{diOdbc = False}) src + + +combos :: [Char] -> Int -> [Text] +combos _ 0 = [T.empty] +combos l n = [ T.cons x tl | x <- l, tl <- combos l (n - 1) ] + diff --git a/tests/Language/SQL/SimpleSQL/MySQL.hs b/tests/Language/SQL/SimpleSQL/MySQL.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/MySQL.hs @@ -0,0 +1,39 @@ + +-- Tests for mysql dialect parsing + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.MySQL (mySQLTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners + +mySQLTests :: TestItem +mySQLTests = Group "mysql dialect" + [backtickQuotes + ,limit] + +{- +backtick quotes + +limit syntax + +[LIMIT {[offset,] row_count | row_count OFFSET offset}] +-} + +backtickQuotes :: TestItem +backtickQuotes = Group "backtickQuotes" + [testScalarExpr mysql "`test`" $ Iden [Name (Just ("`","`")) "test"] + ,testParseScalarExprFails ansi2011 "`test`"] + +limit :: TestItem +limit = Group "queries" + [testQueryExpr mysql "select * from t limit 5" + $ toQueryExpr $ sel {msFetchFirst = Just (NumLit "5")} + ,testParseQueryExprFails mysql "select a from t fetch next 10 rows only;" + ,testParseQueryExprFails ansi2011 "select * from t limit 5"] + where + sel = makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + } diff --git a/tests/Language/SQL/SimpleSQL/Odbc.hs b/tests/Language/SQL/SimpleSQL/Odbc.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Odbc.hs @@ -0,0 +1,60 @@ + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Odbc (odbcTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +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" [ + q + "select * from {oj t1 left outer join t2 on expr}" + $ toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TROdbc $ TRJoin (TRSimple [Name Nothing "t1"]) False JLeft (TRSimple [Name Nothing "t2"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])]}] + ,Group "check parsing bugs" [ + q + "select {fn CONVERT(cint,SQL_BIGINT)} from t;" + $ toQueryExpr $ makeSelect + {msSelectList = [(OdbcFunc (ap "CONVERT" + [iden "cint" + ,iden "SQL_BIGINT"]), Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]}] + ] + where + e :: HasCallStack => Text -> ScalarExpr -> TestItem + e src ast = testScalarExpr ansi2011{diOdbc = True} src ast + + q :: HasCallStack => Text -> QueryExpr -> TestItem + q src ast = testQueryExpr ansi2011{diOdbc = True} src ast + + --tsql = ParseProcSql defaultParseFlags {pfDialect=sqlServerDialect} + ap n = App [Name Nothing n] + iden n = Iden [Name Nothing n] + diff --git a/tests/Language/SQL/SimpleSQL/Oracle.hs b/tests/Language/SQL/SimpleSQL/Oracle.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Oracle.hs @@ -0,0 +1,32 @@ + +-- Tests for oracle dialect parsing + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Oracle (oracleTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners + +oracleTests :: TestItem +oracleTests = Group "oracle dialect" + [oracleLobUnits] + + +oracleLobUnits :: TestItem +oracleLobUnits = Group "oracleLobUnits" + [testScalarExpr oracle "cast (a as varchar2(3 char))" + $ Cast (Iden [Name Nothing "a"]) ( + PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecCharacters)) + ,testScalarExpr oracle "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") + (Just (PrecLengthTypeName [Name Nothing "varchar2"] 55 Nothing (Just PrecOctets))) + []] + False + ] + diff --git a/tests/Language/SQL/SimpleSQL/Postgres.hs b/tests/Language/SQL/SimpleSQL/Postgres.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Postgres.hs @@ -0,0 +1,284 @@ + +{- +Here are some tests taken from the SQL in the postgres manual. Almost +all of the postgres specific syntax has been skipped, this can be +revisited when the dialect support is added. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Postgres (postgresTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +postgresTests :: TestItem +postgresTests = Group "postgresTests" + +{- +lexical syntax section + +TODO: get all the commented out tests working +-} + + [-- "SELECT 'foo'\n\ + -- \'bar';" -- this should parse as select 'foobar' + -- , + t "SELECT name, (SELECT max(pop) FROM cities\n\ + \ WHERE cities.state = states.name)\n\ + \ FROM states;" + ,t "SELECT ROW(1,2.5,'this is a test');" + + ,t "SELECT ROW(t.*, 42) FROM t;" + ,t "SELECT ROW(t.f1, t.f2, 42) FROM t;" + ,t "SELECT getf1(CAST(ROW(11,'this is a test',2.5) AS myrowtype));" + + ,t "SELECT ROW(1,2.5,'this is a test') = ROW(1, 3, 'not the same');" + + -- table is a reservered keyword? + --,t "SELECT ROW(table.*) IS NULL FROM table;" + ,t "SELECT ROW(tablex.*) IS NULL FROM tablex;" + + ,t "SELECT true OR somefunc();" + + ,t "SELECT somefunc() OR true;" + +-- queries section + + ,t "SELECT * FROM t1 CROSS JOIN t2;" + ,t "SELECT * FROM t1 INNER JOIN t2 ON t1.num = t2.num;" + ,t "SELECT * FROM t1 INNER JOIN t2 USING (num);" + ,t "SELECT * FROM t1 NATURAL INNER JOIN t2;" + ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num;" + ,t "SELECT * FROM t1 LEFT JOIN t2 USING (num);" + ,t "SELECT * FROM t1 RIGHT JOIN t2 ON t1.num = t2.num;" + ,t "SELECT * FROM t1 FULL JOIN t2 ON t1.num = t2.num;" + ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num AND t2.value = 'xxx';" + ,t "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num WHERE t2.value = 'xxx';" + + ,t "SELECT * FROM some_very_long_table_name s\n\ + \JOIN another_fairly_long_name a ON s.id = a.num;" + ,t "SELECT * FROM people AS mother JOIN people AS child\n\ + \ ON mother.id = child.mother_id;" + ,t "SELECT * FROM my_table AS a CROSS JOIN my_table AS b;" + ,t "SELECT * FROM (my_table AS a CROSS JOIN my_table) AS b;" + ,t "SELECT * FROM getfoo(1) AS t1;" + ,t "SELECT * FROM foo\n\ + \ WHERE foosubid IN (\n\ + \ SELECT foosubid\n\ + \ FROM getfoo(foo.fooid) z\n\ + \ WHERE z.fooid = foo.fooid\n\ + \ );" + {-,t "SELECT *\n\ + \ FROM dblink('dbname=mydb', 'SELECT proname, prosrc FROM pg_proc')\n\ + \ AS t1(proname name, prosrc text)\n\ + \ WHERE proname LIKE 'bytea%';"-} -- types in the alias?? + + ,t "SELECT * FROM foo, LATERAL (SELECT * FROM bar WHERE bar.id = foo.bar_id) ss;" + ,t "SELECT * FROM foo, bar WHERE bar.id = foo.bar_id;" + + {-,t "SELECT p1.id, p2.id, v1, v2\n\ + \FROM polygons p1, polygons p2,\n\ + \ LATERAL vertices(p1.poly) v1,\n\ + \ LATERAL vertices(p2.poly) v2\n\ + \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-} -- <-> operator? + + {-,t "SELECT p1.id, p2.id, v1, v2\n\ + \FROM polygons p1 CROSS JOIN LATERAL vertices(p1.poly) v1,\n\ + \ polygons p2 CROSS JOIN LATERAL vertices(p2.poly) v2\n\ + \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-} + + ,t "SELECT m.name\n\ + \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true\n\ + \WHERE pname IS NULL;" + + + ,t "SELECT * FROM fdt WHERE c1 > 5" + + ,t "SELECT * FROM fdt WHERE c1 IN (1, 2, 3)" + + ,t "SELECT * FROM fdt WHERE c1 IN (SELECT c1 FROM t2)" + + ,t "SELECT * FROM fdt WHERE c1 IN (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10)" + + ,t "SELECT * FROM fdt WHERE c1 BETWEEN \n\ + \ (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10) AND 100" + + ,t "SELECT * FROM fdt WHERE EXISTS (SELECT c1 FROM t2 WHERE c2 > fdt.c1)" + + ,t "SELECT * FROM test1;" + + ,t "SELECT x FROM test1 GROUP BY x;" + ,t "SELECT x, sum(y) FROM test1 GROUP BY x;" + -- s.date changed to s.datex because of reserved keyword + -- handling, not sure if this is correct or not for ansi sql + ,t "SELECT product_id, p.name, (sum(s.units) * p.price) AS sales\n\ + \ FROM products p LEFT JOIN sales s USING (product_id)\n\ + \ GROUP BY product_id, p.name, p.price;" + + ,t "SELECT x, sum(y) FROM test1 GROUP BY x HAVING sum(y) > 3;" + ,t "SELECT x, sum(y) FROM test1 GROUP BY x HAVING x < 'c';" + ,t "SELECT product_id, p.name, (sum(s.units) * (p.price - p.cost)) AS profit\n\ + \ FROM products p LEFT JOIN sales s USING (product_id)\n\ + \ WHERE s.datex > CURRENT_DATE - INTERVAL '4 weeks'\n\ + \ GROUP BY product_id, p.name, p.price, p.cost\n\ + \ HAVING sum(p.price * s.units) > 5000;" + + ,t "SELECT a, b, c FROM t" + + ,t "SELECT tbl1.a, tbl2.a, tbl1.b FROM t" + + ,t "SELECT tbl1.*, tbl2.a FROM t" + + ,t "SELECT a AS value, b + c AS sum FROM t" + + ,t "SELECT a \"value\", b + c AS sum FROM t" + + ,t "SELECT DISTINCT select_list t" + + ,t "VALUES (1, 'one'), (2, 'two'), (3, 'three');" + + ,t "SELECT 1 AS column1, 'one' AS column2\n\ + \UNION ALL\n\ + \SELECT 2, 'two'\n\ + \UNION ALL\n\ + \SELECT 3, 'three';" + + ,t "SELECT * FROM (VALUES (1, 'one'), (2, 'two'), (3, 'three')) AS t (num,letter);" + + ,t "WITH regional_sales AS (\n\ + \ SELECT region, SUM(amount) AS total_sales\n\ + \ FROM orders\n\ + \ GROUP BY region\n\ + \ ), top_regions AS (\n\ + \ SELECT region\n\ + \ FROM regional_sales\n\ + \ WHERE total_sales > (SELECT SUM(total_sales)/10 FROM regional_sales)\n\ + \ )\n\ + \SELECT region,\n\ + \ product,\n\ + \ SUM(quantity) AS product_units,\n\ + \ SUM(amount) AS product_sales\n\ + \FROM orders\n\ + \WHERE region IN (SELECT region FROM top_regions)\n\ + \GROUP BY region, product;" + + ,t "WITH RECURSIVE t(n) AS (\n\ + \ VALUES (1)\n\ + \ UNION ALL\n\ + \ SELECT n+1 FROM t WHERE n < 100\n\ + \)\n\ + \SELECT sum(n) FROM t" + + ,t "WITH RECURSIVE included_parts(sub_part, part, quantity) AS (\n\ + \ SELECT sub_part, part, quantity FROM parts WHERE part = 'our_product'\n\ + \ UNION ALL\n\ + \ SELECT p.sub_part, p.part, p.quantity\n\ + \ FROM included_parts pr, parts p\n\ + \ WHERE p.part = pr.sub_part\n\ + \ )\n\ + \SELECT sub_part, SUM(quantity) as total_quantity\n\ + \FROM included_parts\n\ + \GROUP BY sub_part" + + ,t "WITH RECURSIVE search_graph(id, link, data, depth) AS (\n\ + \ SELECT g.id, g.link, g.data, 1\n\ + \ FROM graph g\n\ + \ UNION ALL\n\ + \ SELECT g.id, g.link, g.data, sg.depth + 1\n\ + \ FROM graph g, search_graph sg\n\ + \ WHERE g.id = sg.link\n\ + \)\n\ + \SELECT * FROM search_graph;" + + {-,t "WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\ + \ SELECT g.id, g.link, g.data, 1,\n\ + \ ARRAY[g.id],\n\ + \ false\n\ + \ FROM graph g\n\ + \ UNION ALL\n\ + \ SELECT g.id, g.link, g.data, sg.depth + 1,\n\ + \ path || g.id,\n\ + \ g.id = ANY(path)\n\ + \ FROM graph g, search_graph sg\n\ + \ WHERE g.id = sg.link AND NOT cycle\n\ + \)\n\ + \SELECT * FROM search_graph;"-} -- ARRAY + + {-,t "WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\ + \ SELECT g.id, g.link, g.data, 1,\n\ + \ ARRAY[ROW(g.f1, g.f2)],\n\ + \ false\n\ + \ FROM graph g\n\ + \ UNION ALL\n\ + \ SELECT g.id, g.link, g.data, sg.depth + 1,\n\ + \ path || ROW(g.f1, g.f2),\n\ + \ ROW(g.f1, g.f2) = ANY(path)\n\ + \ FROM graph g, search_graph sg\n\ + \ WHERE g.id = sg.link AND NOT cycle\n\ + \)\n\ + \SELECT * FROM search_graph;"-} -- ARRAY + + ,t "WITH RECURSIVE t(n) AS (\n\ + \ SELECT 1\n\ + \ UNION ALL\n\ + \ SELECT n+1 FROM t\n\ + \)\n\ + \SELECT n FROM t --LIMIT 100;" -- limit is not standard + +-- select page reference + + ,t "SELECT f.title, f.did, d.name, f.date_prod, f.kind\n\ + \ FROM distributors d, films f\n\ + \ WHERE f.did = d.did" + + ,t "SELECT kind, sum(len) AS total\n\ + \ FROM films\n\ + \ GROUP BY kind\n\ + \ HAVING sum(len) < interval '5 hours';" + + ,t "SELECT * FROM distributors ORDER BY name;" + ,t "SELECT * FROM distributors ORDER BY 2;" + + ,t "SELECT distributors.name\n\ + \ FROM distributors\n\ + \ WHERE distributors.name LIKE 'W%'\n\ + \UNION\n\ + \SELECT actors.name\n\ + \ FROM actors\n\ + \ WHERE actors.name LIKE 'W%';" + + ,t "WITH t AS (\n\ + \ SELECT random() as x FROM generate_series(1, 3)\n\ + \ )\n\ + \SELECT * FROM t\n\ + \UNION ALL\n\ + \SELECT * FROM t" + + ,t "WITH RECURSIVE employee_recursive(distance, employee_name, manager_name) AS (\n\ + \ SELECT 1, employee_name, manager_name\n\ + \ FROM employee\n\ + \ WHERE manager_name = 'Mary'\n\ + \ UNION ALL\n\ + \ SELECT er.distance + 1, e.employee_name, e.manager_name\n\ + \ FROM employee_recursive er, employee e\n\ + \ WHERE er.employee_name = e.manager_name\n\ + \ )\n\ + \SELECT distance, employee_name FROM employee_recursive;" + + ,t "SELECT m.name AS mname, pname\n\ + \FROM manufacturers m, LATERAL get_product_names(m.id) pname;" + + ,t "SELECT m.name AS mname, pname\n\ + \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true;" + + ,t "SELECT 2+2;" + + -- simple-sql-parser doesn't support where without from + -- this can be added for the postgres dialect when it is written + --,t "SELECT distributors.* WHERE distributors.name = 'Westward';" + + ] + where + t :: HasCallStack => Text -> TestItem + t src = testParseQueryExpr postgres src diff --git a/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs b/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs @@ -0,0 +1,228 @@ + +{- +These are the tests for the query expression components apart from the +table refs which are in a separate file. + + +These are a few misc tests which don't fit anywhere else. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.QueryExprComponents (queryExprComponentTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +queryExprComponentTests :: TestItem +queryExprComponentTests = Group "queryExprComponentTests" + [duplicates + ,selectLists + ,whereClause + ,having + ,orderBy + ,offsetFetch + ,combos + ,withQueries + ,values + ,tables + ] + + + +duplicates :: TestItem +duplicates = Group "duplicates" + [q "select a from t" $ ms SQDefault + ,q "select all a from t" $ ms All + ,q "select distinct a from t" $ ms Distinct + ] + where + ms d = toQueryExpr $ makeSelect + {msSetQuantifier = d + ,msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + +selectLists :: TestItem +selectLists = Group "selectLists" + [q "select 1" + $ toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]} + + ,q "select a" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]} + + ,q "select a,b" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing) + ,(Iden [Name Nothing "b"],Nothing)]} + + ,q "select 1+2,3+4" + $ toQueryExpr $ makeSelect {msSelectList = + [(BinOp (NumLit "1") [Name Nothing "+"] (NumLit "2"),Nothing) + ,(BinOp (NumLit "3") [Name Nothing "+"] (NumLit "4"),Nothing)]} + + ,q "select a as a, /*comment*/ b as b" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a") + ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]} + + ,q "select a a, b b" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a") + ,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]} + + ,q "select a + b * c" + $ toQueryExpr $ makeSelect {msSelectList = + [(BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] + (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"])) + ,Nothing)]} + ,q "select * from t" + $ toQueryExpr $ makeSelect {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + + ,q "select t.* from t" + $ toQueryExpr $ makeSelect {msSelectList = [(QStar [Name Nothing "t"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + + ,q "select t.*, a as b, u.* from t" + $ toQueryExpr $ makeSelect + {msSelectList = + [(QStar [Name Nothing "t"],Nothing) + ,(Iden [Name Nothing "a"], Just $ Name Nothing "b") + ,(QStar [Name Nothing "u"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + + ] + +whereClause :: TestItem +whereClause = Group "whereClause" + [q "select a from t where a = 5" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")} + ] + +having :: TestItem +having = Group "having" + [q "select a,sum(b) from t group by a having sum(b) > 5" + $ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "b"]],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] + ,msHaving = Just $ BinOp (App [Name Nothing "sum"] [Iden [Name Nothing "b"]]) + [Name Nothing ">"] (NumLit "5") + } + ] + +orderBy :: TestItem +orderBy = Group "orderBy" + [q "select a from t order by a" + $ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] + + ,q "select a from t order by a, b" + $ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] + + ,q "select a from t order by a asc" + $ ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault] + + ,q "select a from t order by a desc, b desc" + $ ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault] + + ,q "select a from t order by a desc nulls first, b desc nulls last" + $ ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsFirst + ,SortSpec (Iden [Name Nothing "b"]) Desc NullsLast] + + ] + where + ms o = toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msOrderBy = o} + +offsetFetch :: TestItem +offsetFetch = Group "offsetFetch" + [-- ansi standard + q "select a from t offset 5 rows fetch next 10 rows only" + $ ms (Just $ NumLit "5") (Just $ NumLit "10") + ,q "select a from t offset 5 rows;" + $ ms (Just $ NumLit "5") Nothing + ,q "select a from t fetch next 10 row only;" + $ ms Nothing (Just $ NumLit "10") + ,q "select a from t offset 5 row fetch first 10 row only" + $ ms (Just $ NumLit "5") (Just $ NumLit "10") + -- postgres: disabled, will add back when postgres + -- dialect is added + --,q "select a from t limit 10 offset 5" + -- $ ms (Just $ NumLit "5") (Just $ NumLit "10")) + ] + where + ms o l = toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msOffset = o + ,msFetchFirst = l} + +combos :: TestItem +combos = Group "combos" + [q "select a from t union select b from u" + $ QueryExprSetOp mst Union SQDefault Respectively msu + + ,q "select a from t intersect select b from u" + $ QueryExprSetOp mst Intersect SQDefault Respectively msu + + ,q "select a from t except all select b from u" + $ QueryExprSetOp mst Except All Respectively msu + + ,q "select a from t union distinct corresponding \ + \select b from u" + $ QueryExprSetOp mst Union Distinct Corresponding msu + + ,q "select a from t union select a from t union select a from t" + $ QueryExprSetOp (QueryExprSetOp mst Union SQDefault Respectively mst) + Union SQDefault Respectively mst + ] + where + mst = toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + msu = toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "b"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "u"]]} + + +withQueries :: TestItem +withQueries = Group "with queries" + [q "with u as (select a from t) select a from u" + $ With False [(Alias (Name Nothing "u") Nothing, ms1)] ms2 + + ,q "with u(b) as (select a from t) select a from u" + $ With False [(Alias (Name Nothing "u") (Just [Name Nothing "b"]), ms1)] ms2 + + ,q "with x as (select a from t),\n\ + \ u as (select a from x)\n\ + \select a from u" + $ With False [(Alias (Name Nothing "x") Nothing, ms1), (Alias (Name Nothing "u") Nothing,ms3)] ms2 + + ,q "with recursive u as (select a from t) select a from u" + $ With True [(Alias (Name Nothing "u") Nothing, ms1)] ms2 + ] + where + ms c t = toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing c],Nothing)] + ,msFrom = [TRSimple [Name Nothing t]]} + ms1 = ms "a" "t" + ms2 = ms "a" "u" + ms3 = ms "a" "x" + +values :: TestItem +values = Group "values" + [q "values (1,2),(3,4)" + $ Values [[NumLit "1", NumLit "2"] + ,[NumLit "3", NumLit "4"]] + ] + +tables :: TestItem +tables = Group "tables" + [q "table tbl" $ Table [Name Nothing "tbl"] + ] + +q :: HasCallStack => Text -> QueryExpr -> TestItem +q src ast = testQueryExpr ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/QueryExprParens.hs b/tests/Language/SQL/SimpleSQL/QueryExprParens.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/QueryExprParens.hs @@ -0,0 +1,47 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Language.SQL.SimpleSQL.QueryExprParens (queryExprParensTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) +import qualified Text.RawString.QQ as R + +queryExprParensTests :: TestItem +queryExprParensTests = Group "query expr parens" + [q "(select * from t)" $ QueryExprParens $ ms "t" + ,q "select * from t except (select * from u except select * from v)" + $ (ms "t") `sexcept` QueryExprParens (ms "u" `sexcept` ms "v") + + ,q "(select * from t except select * from u) except select * from v" + $ QueryExprParens (ms "t" `sexcept` ms "u") `sexcept` ms "v" + + ,q [R.r| +select * from t +union +with a as (select * from u) +select * from a +|] + $ ms "t" `sunion` with [("a", ms "u")] (ms "a") + + ,q [R.r| +select * from t +union +(with a as (select * from u) + select * from a) +|] + $ ms "t" `sunion` QueryExprParens (with [("a", ms "u")] (ms "a")) + ] + where + q :: HasCallStack => Text -> QueryExpr -> TestItem + q src ast = testQueryExpr ansi2011 src ast + ms t = toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing t]]} + sexcept = so Except + sunion = so Union + so op a b = QueryExprSetOp a op SQDefault Respectively b + with es s = + With False (flip map es $ \(n,sn) -> (Alias (Name Nothing n) Nothing ,sn)) s diff --git a/tests/Language/SQL/SimpleSQL/QueryExprs.hs b/tests/Language/SQL/SimpleSQL/QueryExprs.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/QueryExprs.hs @@ -0,0 +1,31 @@ + +{- +These are the tests for the queryExprs parsing which parses multiple +query expressions from one string. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.QueryExprs (queryExprsTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +queryExprsTests :: TestItem +queryExprsTests = Group "query exprs" + [q "select 1" [ms] + ,q "select 1;" [ms] + ,q "select 1;select 1" [ms,ms] + ,q " select 1;select 1; " [ms,ms] + ,q "SELECT CURRENT_TIMESTAMP;" + [SelectStatement $ toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "CURRENT_TIMESTAMP"],Nothing)]}] + ,q "SELECT \"CURRENT_TIMESTAMP\";" + [SelectStatement $ toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name (Just ("\"","\"")) "CURRENT_TIMESTAMP"],Nothing)]}] + ] + where + ms = SelectStatement $ toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]} + q :: HasCallStack => Text -> [Statement] -> TestItem + q src ast = testStatements ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs b/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs @@ -0,0 +1,304 @@ + +{- +Section 12 in Foundation + +grant, etc +-} + + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.SQL2011AccessControl (sql2011AccessControlTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +sql2011AccessControlTests :: TestItem +sql2011AccessControlTests = Group "sql 2011 access control tests" [ + +{- +12 Access control + +12.1 + + ::= + + | + +12.2 + + ::= + GRANT TO [ { }... ] + [ WITH HIERARCHY OPTION ] + [ WITH GRANT OPTION ] + [ GRANTED BY ] + +12.3 + ::= + ON + + ::= + [ TABLE ]
+ | DOMAIN + | COLLATION + | CHARACTER SET + | TRANSLATION + | TYPE + | SEQUENCE + | + + ::= + ALL PRIVILEGES + | [ { }... ] + + ::= + SELECT + | SELECT + | SELECT + | DELETE + | INSERT [ ] + | UPDATE [ ] + | REFERENCES [ ] + | USAGE + | TRIGGER + | UNDER + | EXECUTE + + ::= + [ { }... ] + + ::= + + + ::= + PUBLIC + | + + ::= + CURRENT_USER + | CURRENT_ROLE +-} + + s "grant all privileges on tbl1 to role1" + $ GrantPrivilege [PrivAll] + (PrivTable [Name Nothing "tbl1"]) + [Name Nothing "role1"] WithoutGrantOption + + + ,s "grant all privileges on tbl1 to role1,role2" + $ GrantPrivilege [PrivAll] + (PrivTable [Name Nothing "tbl1"]) + [Name Nothing "role1",Name Nothing "role2"] WithoutGrantOption + + ,s "grant all privileges on tbl1 to role1 with grant option" + $ GrantPrivilege [PrivAll] + (PrivTable [Name Nothing "tbl1"]) + [Name Nothing "role1"] WithGrantOption + + ,s "grant all privileges on table tbl1 to role1" + $ GrantPrivilege [PrivAll] + (PrivTable [Name Nothing "tbl1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant all privileges on domain mydom to role1" + $ GrantPrivilege [PrivAll] + (PrivDomain [Name Nothing "mydom"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant all privileges on type t1 to role1" + $ GrantPrivilege [PrivAll] + (PrivType [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant all privileges on sequence s1 to role1" + $ GrantPrivilege [PrivAll] + (PrivSequence [Name Nothing "s1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant select on table t1 to role1" + $ GrantPrivilege [PrivSelect []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant select(a,b) on table t1 to role1" + $ GrantPrivilege [PrivSelect [Name Nothing "a", Name Nothing "b"]] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant delete on table t1 to role1" + $ GrantPrivilege [PrivDelete] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant insert on table t1 to role1" + $ GrantPrivilege [PrivInsert []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant insert(a,b) on table t1 to role1" + $ GrantPrivilege [PrivInsert [Name Nothing "a", Name Nothing "b"]] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant update on table t1 to role1" + $ GrantPrivilege [PrivUpdate []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant update(a,b) on table t1 to role1" + $ GrantPrivilege [PrivUpdate [Name Nothing "a", Name Nothing "b"]] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant references on table t1 to role1" + $ GrantPrivilege [PrivReferences []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant references(a,b) on table t1 to role1" + $ GrantPrivilege [PrivReferences [Name Nothing "a", Name Nothing "b"]] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant usage on table t1 to role1" + $ GrantPrivilege [PrivUsage] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant trigger on table t1 to role1" + $ GrantPrivilege [PrivTrigger] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + + + ,s "grant execute on specific function f to role1" + $ GrantPrivilege [PrivExecute] + (PrivFunction [Name Nothing "f"]) + [Name Nothing "role1"] WithoutGrantOption + + ,s "grant select,delete on table t1 to role1" + $ GrantPrivilege [PrivSelect [], PrivDelete] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] WithoutGrantOption + +{- +skipping for now: + +what is 'under' action? + +collation, character set, translation, member thing, methods + +for review + +some pretty big things missing in the standard: + +schema, database + +functions, etc., by argument types since they can be overloaded + + + +12.4 + + ::= + CREATE ROLE [ WITH ADMIN ] +-} + + ,s "create role rolee" + $ CreateRole (Name Nothing "rolee") + + +{- +12.5 + + ::= + GRANT [ { }... ] + TO [ { }... ] + [ WITH ADMIN OPTION ] + [ GRANTED BY ] + + ::= + +-} + + ,s "grant role1 to public" + $ GrantRole [Name Nothing "role1"] [Name Nothing "public"] WithoutAdminOption + + ,s "grant role1,role2 to role3,role4" + $ GrantRole [Name Nothing "role1",Name Nothing "role2"] + [Name Nothing "role3", Name Nothing "role4"] WithoutAdminOption + + ,s "grant role1 to role3 with admin option" + $ GrantRole [Name Nothing "role1"] [Name Nothing "role3"] WithAdminOption + + +{- +12.6 + + ::= + DROP ROLE +-} + + ,s "drop role rolee" + $ DropRole (Name Nothing "rolee") + + +{- +12.7 + + ::= + + | + + ::= + REVOKE [ ] + FROM [ { }... ] + [ GRANTED BY ] + + + ::= + GRANT OPTION FOR + | HIERARCHY OPTION FOR +-} + + + ,s "revoke select on t1 from role1" + $ RevokePrivilege NoGrantOptionFor [PrivSelect []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1"] DefaultDropBehaviour + + ,s + "revoke grant option for select on t1 from role1,role2 cascade" + $ RevokePrivilege GrantOptionFor [PrivSelect []] + (PrivTable [Name Nothing "t1"]) + [Name Nothing "role1",Name Nothing "role2"] Cascade + + +{- + ::= + REVOKE [ ADMIN OPTION FOR ] [ { }... ] + FROM [ { }... ] + [ GRANTED BY ] + + + ::= + +-} + + ,s "revoke role1 from role2" + $ RevokeRole NoAdminOptionFor [Name Nothing "role1"] + [Name Nothing "role2"] DefaultDropBehaviour + + ,s "revoke role1,role2 from role3,role4" + $ RevokeRole NoAdminOptionFor [Name Nothing "role1",Name Nothing "role2"] + [Name Nothing "role3",Name Nothing "role4"] DefaultDropBehaviour + + + ,s "revoke admin option for role1 from role2 cascade" + $ RevokeRole AdminOptionFor [Name Nothing "role1"] [Name Nothing "role2"] Cascade + + ] + +s :: HasCallStack => Text -> Statement -> TestItem +s src ast = testStatement ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs b/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs @@ -0,0 +1,226 @@ + +{- +Sections 17 and 19 in Foundation + +This module covers the tests for transaction management (begin, +commit, savepoint, etc.), and session management (set). +-} + + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.SQL2011Bits (sql2011BitsTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +sql2011BitsTests :: TestItem +sql2011BitsTests = Group "sql 2011 bits tests" [ + +{- +17 Transaction management + +17.1 + + ::= + START TRANSACTION [ ] + +BEGIN is not in the standard! +-} + + s "start transaction" StartTransaction + +{- +17.2 + + ::= + SET [ LOCAL ] TRANSACTION + +17.3 + + ::= + [ [ { }... ] ] + + ::= + + | + | + + ::= + READ ONLY + | READ WRITE + + ::= + ISOLATION LEVEL + + ::= + READ UNCOMMITTED + | READ COMMITTED + | REPEATABLE READ + | SERIALIZABLE + + ::= + DIAGNOSTICS SIZE + + ::= + + +17.4 + + ::= + SET CONSTRAINTS { DEFERRED | IMMEDIATE } + + ::= + ALL + | [ { }... ] + +17.5 + + ::= + SAVEPOINT + + ::= + +-} + + ,s "savepoint difficult_bit" + $ Savepoint $ Name Nothing "difficult_bit" + + +{- +17.6 + + ::= + RELEASE SAVEPOINT +-} + + ,s "release savepoint difficult_bit" + $ ReleaseSavepoint $ Name Nothing "difficult_bit" + + +{- +17.7 + + ::= + COMMIT [ WORK ] [ AND [ NO ] CHAIN ] +-} + + ,s "commit" Commit + + ,s "commit work" Commit + + +{- +17.8 + + ::= + ROLLBACK [ WORK ] [ AND [ NO ] CHAIN ] [ ] + + ::= + TO SAVEPOINT +-} + + ,s "rollback" $ Rollback Nothing + + ,s "rollback work" $ Rollback Nothing + + ,s "rollback to savepoint difficult_bit" + $ Rollback $ Just $ Name Nothing "difficult_bit" + + +{- +19 Session management + +19.1 + + ::= + SET SESSION CHARACTERISTICS AS + + ::= + [ { }... ] + + ::= + + + ::= + TRANSACTION [ { }... ] + +19.2 + + ::= + SET SESSION AUTHORIZATION + +19.3 + + ::= + SET ROLE + + ::= + + | NONE + +19.4 + + ::= + SET TIME ZONE + + ::= + + | LOCAL + +19.5 + + ::= + SET + + ::= + CATALOG + +19.6 + + ::= + SET + + ::= + SCHEMA + +19.7 + + ::= + SET + + ::= + NAMES + +19.8 + + ::= + SET + + ::= + PATH + +19.9 + + ::= + SET + + ::= + DEFAULT TRANSFORM GROUP + | TRANSFORM GROUP FOR TYPE + +19.10 + + ::= + SET COLLATION [ FOR ] + | SET NO COLLATION [ FOR ] + + ::= + +-} + + ] + +s :: HasCallStack => Text -> Statement -> TestItem +s src ast = testStatement ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs b/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs @@ -0,0 +1,560 @@ + +-- Section 14 in Foundation + + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.SQL2011DataManipulation (sql2011DataManipulationTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +sql2011DataManipulationTests :: TestItem +sql2011DataManipulationTests = Group "sql 2011 data manipulation tests" + [ + + +{- +14 Data manipulation + + +14.1 + + ::= + DECLARE + FOR + +14.2 + + ::= + [ ] [ ] CURSOR + [ ] + [ ] + + ::= + SENSITIVE + | INSENSITIVE + | ASENSITIVE + + ::= + SCROLL + | NO SCROLL + + ::= + WITH HOLD + | WITHOUT HOLD + + ::= + WITH RETURN + | WITHOUT RETURN + +14.3 + + ::= + [ ] + + ::= + FOR { READ ONLY | UPDATE [ OF ] } + +14.4 + + ::= + OPEN + +14.5 + + ::= + FETCH [ [ ] FROM ] INTO + + ::= + NEXT + | PRIOR + | FIRST + | LAST + | { ABSOLUTE | RELATIVE } + + ::= + [ { }... ] + + +14.6 + + ::= + CLOSE + +14.7 ::= + SELECT [ ] +
+ +
+ | ONLY
+ +14.9 + + ::= + DELETE FROM + [ FOR PORTION OF + FROM TO ] + [ [ AS ] ] + [ WHERE ] +-} + + s "delete from t" + $ Delete [Name Nothing "t"] Nothing Nothing + + ,s "delete from t as u" + $ Delete [Name Nothing "t"] (Just (Name Nothing "u")) Nothing + + ,s "delete from t where x = 5" + $ Delete [Name Nothing "t"] Nothing + (Just $ BinOp (Iden [Name Nothing "x"]) [Name Nothing "="] (NumLit "5")) + + + ,s "delete from t as u where u.x = 5" + $ Delete [Name Nothing "t"] (Just (Name Nothing "u")) + (Just $ BinOp (Iden [Name Nothing "u", Name Nothing "x"]) [Name Nothing "="] (NumLit "5")) + +{- +14.10 + + ::= + TRUNCATE TABLE [ ] + + ::= + CONTINUE IDENTITY + | RESTART IDENTITY +-} + + ,s "truncate table t" + $ Truncate [Name Nothing "t"] DefaultIdentityRestart + + ,s "truncate table t continue identity" + $ Truncate [Name Nothing "t"] ContinueIdentity + + ,s "truncate table t restart identity" + $ Truncate [Name Nothing "t"] RestartIdentity + + +{- +14.11 + + ::= + INSERT INTO + + ::= +
+ + ::= + + | + | + + ::= + [ ] + [ ] + + + ::= + [ ] + [ ] + + + ::= + OVERRIDING USER VALUE + | OVERRIDING SYSTEM VALUE + + ::= + DEFAULT VALUES + + ::= + +-} + + ,s "insert into t select * from u" + $ Insert [Name Nothing "t"] Nothing + $ InsertQuery $ toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "u"]]} + + ,s "insert into t(a,b,c) select * from u" + $ Insert [Name Nothing "t"] (Just [Name Nothing "a", Name Nothing "b", Name Nothing "c"]) + $ InsertQuery $ toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "u"]]} + + ,s "insert into t default values" + $ Insert [Name Nothing "t"] Nothing DefaultInsertValues + + ,s "insert into t values(1,2)" + $ Insert [Name Nothing "t"] Nothing + $ InsertQuery $ Values [[NumLit "1", NumLit "2"]] + + ,s "insert into t values (1,2),(3,4)" + $ Insert [Name Nothing "t"] Nothing + $ InsertQuery $ Values [[NumLit "1", NumLit "2"] + ,[NumLit "3", NumLit "4"]] + + ,s + "insert into t values (default,null,array[],multiset[])" + $ Insert [Name Nothing "t"] Nothing + $ InsertQuery $ Values [[Iden [Name Nothing "default"] + ,Iden [Name Nothing "null"] + ,Array (Iden [Name Nothing "array"]) [] + ,MultisetCtor []]] + + +{- +14.12 + + ::= + MERGE INTO [ [ AS ] ] + USING
+ ON + +merge into t + using t + on a = b + merge operation specification + +merge into t as u +using (table factor | joined expression) + + MERGE INTO tablename USING table_reference ON (condition) + WHEN MATCHED THEN + UPDATE SET column1 = value1 [, column2 = value2 ...] + WHEN NOT MATCHED THEN + INSERT (column1 [, column2 ...]) VALUES (value1 [, value2 ... + +merge into t23 +using t42 +on t42.id = t23.id +when matched then + update + set t23.col1 = t42.col1 +when not matched then + insert (id, col1) + values (t42.id, t42.col1) + + + +MERGE INTO TableA u + +USING (SELECT b.Key1, b.ColB1, c.ColC1 + +FROM TableB b + +INNER JOIN TableC c ON c.KeyC1 = b.KeyB1 + +) s + +ON (u.KeyA1 = s.KeyA1) + +WHEN MATCHED THEN + +UPDATE SET u.ColA1 = s.ColB1, u.ColA2 = s.ColC1 + + +MERGE INTO Department +USING NewDept AS ND +ON nd.Department_Number = Department. +Department_Number +WHEN MATCHED THEN UPDATE +SET budget_amount = nd.Budget_Amount +WHEN NOT MATCHED THEN INSERT +VALUES +(nd.Department_Number, nd.Department_ +Name, nd.Budget_Amount, + nd.Manager_Employee_Number); + + +MERGE INTO Orders2 +USING Orders3 +ON ORDERS3.Order_Number = Orders2. +Order_Number +WHEN NOT MATCHED THEN INSERT +Orders3.order_number, Orders3. +invoice_number, + Orders3.customer_number, Orders3. +initial_order_date, + Orders3.invoice_date, Orders3. +invoice_amount); + +MERGE INTO Orders2 +USING Orders3 +ON ORDERS3.Order_Number = Orders2. +Order_Number AND 1=0 +WHEN NOT MATCHED THEN INSERT +(Orders3.order_number, Orders3.invoice_number, + Orders3.customer_number, Orders3. +initial_order_date, + Orders3.invoice_date, Orders3. +invoice_amount); + +MERGE INTO Department +USING NewDept AS ND +ON nd.Department_Number = Department. +Department_Number +WHEN MATCHED THEN UPDATE +SET budget_amount = nd.Budget_Amount +LOGGING ALL ERRORS WITH NO LIMIT; + + +MERGE INTO Department +USING + (SELECT Department_Number, +department_name, + Budget_Amount, +Manager_Employee_Number + FROM NewDept + WHERE Department_Number IN +(SELECT Department_Number + FROM Employee)) AS m +ON m.Department_Number = Department. +Department_Number +WHEN MATCHED THEN UPDATE +SET budget_amount = m.Budget_Amount +WHEN NOT MATCHED THEN INSERT +(m.Department_Number, m.Department_ +Name, m.Budget_Amount, +m.Manager_Employee_Number) +LOGGING ALL ERRORS WITH NO LIMIT; + + +MERGE INTO Customers AS c +USING Moved AS m + ON m.SSN = c.SSN +WHEN MATCHED +THEN UPDATE +SET Street = m.Street, + HouseNo = m.HouseNo, + City = m.City; + +MERGE INTO CentralOfficeAccounts AS C -- Target +USING BranchOfficeAccounts AS B -- Source + ON C.account_nbr = B.account_nbr +WHEN MATCHED THEN -- On match update + UPDATE SET C.company_name = B.company_name, + C.primary_contact = B.primary_contact, + C.contact_phone = B.contact_phone +WHEN NOT MATCHED THEN -- Add missing + INSERT (account_nbr, company_name, primary_contact, contact_phone) + VALUES (B.account_nbr, B.company_name, B.primary_contact, B.contact_phone); + +SELECT account_nbr, company_name, primary_contact, contact_phone +FROM CentralOfficeAccounts; + + + +MERGE INTO CentralOfficeAccounts AS C -- Target +USING BranchOfficeAccounts AS B -- Source + ON C.account_nbr = B.account_nbr +WHEN MATCHED -- On match update + AND (C.company_name <> B.company_name -- Additional search conditions + OR C.primary_contact <> B.primary_contact + OR C.contact_phone <> B.contact_phone) THEN + UPDATE SET C.company_name = B.company_name, + C.primary_contact = B.primary_contact, + C.contact_phone = B.contact_phone +WHEN NOT MATCHED THEN -- Add missing + INSERT (account_nbr, company_name, primary_contact, contact_phone) + VALUES (B.account_nbr, B.company_name, B.primary_contact, B.contact_phone); + + + +MERGE INTO CentralOfficeAccounts AS C -- Target +USING BranchOfficeAccounts AS B -- Source + ON C.account_nbr = B.account_nbr +WHEN MATCHED -- On match update + AND (C.company_name <> B.company_name -- Additional search conditions + OR C.primary_contact <> B.primary_contact + OR C.contact_phone <> B.contact_phone) THEN + UPDATE SET C.company_name = B.company_name, + C.primary_contact = B.primary_contact, + C.contact_phone = B.contact_phone +WHEN NOT MATCHED THEN -- Add missing + INSERT (account_nbr, company_name, primary_contact, contact_phone) + VALUES (B.account_nbr, B.company_name, B.primary_contact, B.contact_phone) +WHEN SOURCE NOT MATCHED THEN -- Delete missing from source + DELETE; + +SELECT account_nbr, company_name, primary_contact, contact_phone +FROM CentralOfficeAccounts; + + + + + ::= + + + ::= + ... + + ::= + + | + + ::= + WHEN MATCHED [ AND ] + THEN + + ::= + + | + + ::= + WHEN NOT MATCHED [ AND ] + THEN + + ::= + UPDATE SET + + ::= + DELETE + + ::= + INSERT [ ] + [ ] + VALUES + + ::= + + [ { }... ] + + + ::= + + | + +14.13 + + ::= + UPDATE [ [ AS ] ] + SET + WHERE CURRENT OF + +14.14 + + ::= + UPDATE + [ FOR PORTION OF + FROM TO ] + [ [ AS ] ] + SET + [ WHERE ] +-} + + + ,s "update t set a=b" + $ Update [Name Nothing "t"] Nothing + [Set [Name Nothing "a"] (Iden [Name Nothing "b"])] Nothing + + ,s "update t set a=b, c=5" + $ Update [Name Nothing "t"] Nothing + [Set [Name Nothing "a"] (Iden [Name Nothing "b"]) + ,Set [Name Nothing "c"] (NumLit "5")] Nothing + + + ,s "update t set a=b where a>5" + $ Update [Name Nothing "t"] Nothing + [Set [Name Nothing "a"] (Iden [Name Nothing "b"])] + $ Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5") + + + ,s "update t as u set a=b where u.a>5" + $ Update [Name Nothing "t"] (Just $ Name Nothing "u") + [Set [Name Nothing "a"] (Iden [Name Nothing "b"])] + $ Just $ BinOp (Iden [Name Nothing "u",Name Nothing "a"]) + [Name Nothing ">"] (NumLit "5") + + ,s "update t set (a,b)=(3,5)" + $ Update [Name Nothing "t"] Nothing + [SetMultiple [[Name Nothing "a"],[Name Nothing "b"]] + [NumLit "3", NumLit "5"]] Nothing + + + +{- +14.15 + + ::= + [ { }... ] + + ::= + + | + + ::= + + | + + ::= + + + ::= + [ { }... ] + + ::= + + + ::= + + | + + + ::= + + + ::= + + + ::= + + | + + ::= + + | + +14.16 + + ::= + DECLARE LOCAL TEMPORARY TABLE
+ [ ON COMMIT
ROWS ] + +declare local temporary table t (a int) [on commit {preserve | delete} rows] + +14.17 + + ::= + FREE LOCATOR [ { }... ] + + ::= + + | + | + +14.18 + + ::= + HOLD LOCATOR [ { }... ] +-} + + + ] + +s :: HasCallStack => Text -> Statement -> TestItem +s src ast = testStatement ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs b/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs @@ -0,0 +1,4508 @@ + +{- +This file goes through the grammar for SQL 2011 queries (using the +draft standard). + +There are other files which cover some of the other sections from SQL +2011 (ddl, non-query dml, etc). + +Possible sections not in the todo which could +be covered: + +13 modules +16 control statements +18 connection management +20 dynamic +22 direct +23 diagnostics + +procedural sql + +some of the main areas being left for now: +temporal and versioning stuff +modules +ref stuff +todo: finish this list + + + +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. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.SQL2011Queries (sql2011QueryTests) where +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax + +import Data.Text (Text) +import Language.SQL.SimpleSQL.TestRunners + +sql2011QueryTests :: TestItem +sql2011QueryTests = Group "sql 2011 query 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 + + ::= + + | + |
::= + + ::= + + ::= [ ] + + ::= + + ::= + + ::= [ ] + + ::= + [ ] + + ::= | + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + [ ] + + ::= MODULE + + ::= + + ::= + + ::= + + ::= | + + ::= + + ::= + + ::= [ ] + + ::= + + ::= + + ::= + + ::= [ ] + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= + + ::= | + + ::= + + ::= [ ] + + ::= | + + ::= [ ] + + ::= + + | + + ::= + + ::= [ ] + + ::= GLOBAL | LOCAL + + ::= + += 6 Scalar expressions + +== 6.1 + +Function +Specify a data type. + + ::= + + | + | + | + | + + ::= + [ CHARACTER SET ] + [ ] + | [ ] + | + | + | + | + | + + ::= + CHARACTER [ ] + | CHAR [ ] + | CHARACTER VARYING + | CHAR VARYING + | VARCHAR + | + + ::= + CHARACTER LARGE OBJECT [ ] + | CHAR LARGE OBJECT [ ] + | CLOB [ ] + + ::= + NATIONAL CHARACTER [ ] + | NATIONAL CHAR [ ] + | NCHAR [ ] + | NATIONAL CHARACTER VARYING + | NATIONAL CHAR VARYING + | NCHAR VARYING + | + + ::= + NATIONAL CHARACTER LARGE OBJECT [ ] + | NCHAR LARGE OBJECT [ ] + | NCLOB [ ] + + ::= + BINARY [ ] + | BINARY VARYING + | VARBINARY + | + + ::= + BINARY LARGE OBJECT [ ] + | BLOB [ ] + + ::= | + + ::= + NUMERIC [ [ ] ] + | DECIMAL [ [ ] ] + | DEC [ [ ] ] + | SMALLINT + | INTEGER + | INT + | BIGINT + + ::= + FLOAT [ ] + | REAL + | DOUBLE PRECISION + + ::= + + ::= [ ] + + ::= + [ ] + | + + ::= + [ ] + + ::= CHARACTERS | OCTETS + + ::= + + ::= + + ::= BOOLEAN + + ::= + DATE + | TIME [
+ + ::= + + ::= + + ::= | + + ::= + ARRAY + [ ] + + ::= + + ::= MULTISET + +TODO: below, add new stuff: +review the length syntaxes +binary, binary varying/varbinary +new multipliers + +create a list of type name variations: +-} + +typeNames :: ([(Text,TypeName)],[(Text,TypeName)]) +typeNames = + (basicTypes, concatMap makeArray basicTypes + <> map makeMultiset basicTypes) + where + makeArray (s,t) = [(s <> " array", ArrayTypeName t Nothing) + ,(s <> " array[5]", ArrayTypeName t (Just 5))] + makeMultiset (s,t) = (s <> " multiset", MultisetTypeName t) + basicTypes :: [(Text, TypeName)] + basicTypes = + -- example of every standard type name + map (\t -> (t,TypeName [Name Nothing t])) + ["binary" + ,"binary varying" + ,"character" + ,"char" + ,"character varying" + ,"char varying" + ,"varbinary" + ,"varchar" + ,"character large object" + ,"char large object" + ,"clob" + ,"national character" + ,"national char" + ,"nchar" + ,"national character varying" + ,"national char varying" + ,"nchar varying" + ,"national character large object" + ,"nchar large object" + ,"nclob" + ,"binary large object" + ,"blob" + ,"numeric" + ,"decimal" + ,"dec" + ,"smallint" + ,"integer" + ,"int" + ,"bigint" + ,"float" + ,"real" + ,"double precision" + ,"boolean" + ,"date" + ,"time" + ,"timestamp"] + --interval -- not allowed without interval qualifier + --row -- not allowed without row type body + -- array -- not allowed on own + -- multiset -- not allowed on own + + <> + [-- 1 single prec + 1 with multiname + ("char(5)", PrecTypeName [Name Nothing "char"] 5) + ,("char varying(5)", PrecTypeName [Name Nothing "char varying"] 5) + -- 1 scale + ,("decimal(15,2)", PrecScaleTypeName [Name Nothing "decimal"] 15 2) + ,("char(3 octets)" + ,PrecLengthTypeName [Name Nothing "char"] 3 Nothing (Just PrecOctets)) + ,("varchar(50 characters)" + ,PrecLengthTypeName [Name Nothing "varchar"] 50 Nothing (Just PrecCharacters)) + -- lob prec + with multiname + ,("blob(3M)", PrecLengthTypeName [Name Nothing "blob"] 3 (Just PrecM) Nothing) + ,("blob(3T)", PrecLengthTypeName [Name Nothing "blob"] 3 (Just PrecT) Nothing) + ,("blob(3P)", PrecLengthTypeName [Name Nothing "blob"] 3 (Just PrecP) Nothing) + ,("blob(4M characters) " + ,PrecLengthTypeName [Name Nothing "blob"] 4 (Just PrecM) (Just PrecCharacters)) + ,("blob(6G octets) " + ,PrecLengthTypeName [Name Nothing "blob"] 6 (Just PrecG) (Just PrecOctets)) + ,("national character large object(7K) " + ,PrecLengthTypeName [Name Nothing "national character large object"] + 7 (Just PrecK) Nothing) + -- 1 with and without tz + ,("time with time zone" + ,TimeTypeName [Name Nothing "time"] Nothing True) + ,("datetime(3) without time zone" + ,TimeTypeName [Name Nothing "datetime"] (Just 3) False) + -- chars: (single/multiname) x prec x charset x collate + -- 1111 + ,("char varying(5) character set something collate something_insensitive" + ,CharTypeName [Name Nothing "char varying"] (Just 5) + [Name Nothing "something"] [Name Nothing "something_insensitive"]) + -- 0111 + ,("char(5) character set something collate something_insensitive" + ,CharTypeName [Name Nothing "char"] (Just 5) + [Name Nothing "something"] [Name Nothing "something_insensitive"]) + + -- 1011 + ,("char varying character set something collate something_insensitive" + ,CharTypeName [Name Nothing "char varying"] Nothing + [Name Nothing "something"] [Name Nothing "something_insensitive"]) + -- 0011 + ,("char character set something collate something_insensitive" + ,CharTypeName [Name Nothing "char"] Nothing + [Name Nothing "something"] [Name Nothing "something_insensitive"]) + + -- 1101 + ,("char varying(5) collate something_insensitive" + ,CharTypeName [Name Nothing "char varying"] (Just 5) + [] [Name Nothing "something_insensitive"]) + -- 0101 + ,("char(5) collate something_insensitive" + ,CharTypeName [Name Nothing "char"] (Just 5) + [] [Name Nothing "something_insensitive"]) + -- 1001 + ,("char varying collate something_insensitive" + ,CharTypeName [Name Nothing "char varying"] Nothing + [] [Name Nothing "something_insensitive"]) + -- 0001 + ,("char collate something_insensitive" + ,CharTypeName [Name Nothing "char"] Nothing + [] [Name Nothing "something_insensitive"]) + + -- 1110 + ,("char varying(5) character set something" + ,CharTypeName [Name Nothing "char varying"] (Just 5) + [Name Nothing "something"] []) + -- 0110 + ,("char(5) character set something" + ,CharTypeName [Name Nothing "char"] (Just 5) + [Name Nothing "something"] []) + -- 1010 + ,("char varying character set something" + ,CharTypeName [Name Nothing "char varying"] Nothing + [Name Nothing "something"] []) + -- 0010 + ,("char character set something" + ,CharTypeName [Name Nothing "char"] Nothing + [Name Nothing "something"] []) + -- 1100 + ,("char varying character set something" + ,CharTypeName [Name Nothing "char varying"] Nothing + [Name Nothing "something"] []) + + -- single row field, two row field + ,("row(a int)", RowTypeName [(Name Nothing "a", TypeName [Name Nothing "int"])]) + ,("row(a int,b char)" + ,RowTypeName [(Name Nothing "a", TypeName [Name Nothing "int"]) + ,(Name Nothing "b", TypeName [Name Nothing "char"])]) + -- interval each type raw + ,("interval year" + ,IntervalTypeName (Itf "year" Nothing) Nothing) + -- one type with single suffix + -- one type with double suffix + ,("interval year(2)" + ,IntervalTypeName (Itf "year" $ Just (2,Nothing)) Nothing) + ,("interval second(2,5)" + ,IntervalTypeName (Itf "second" $ Just (2,Just 5)) Nothing) + -- a to b with raw + -- a to b with single suffix + ,("interval year to month" + ,IntervalTypeName (Itf "year" Nothing) + (Just $ Itf "month" Nothing)) + ,("interval year(4) to second(2,3)" + ,IntervalTypeName (Itf "year" $ Just (4,Nothing)) + (Just $ Itf "second" $ Just (2, Just 3))) + ] + +{- +Now test each variation in both cast expression and typed literal +expression +-} + +typeNameTests :: TestItem +typeNameTests = Group "type names" + [Group "type names" $ map (uncurry (testScalarExpr ansi2011)) + $ concatMap makeSimpleTests $ fst typeNames + ,Group "generated casts" $ map (uncurry (testScalarExpr ansi2011)) + $ concatMap makeCastTests $ fst typeNames + ,Group "generated typename" $ map (uncurry (testScalarExpr ansi2011)) + $ concatMap makeTests $ snd typeNames] + where + makeSimpleTests (ctn, stn) = + [(ctn <> " 'test'", TypedLit stn "test") + ] + makeCastTests (ctn, stn) = + [("cast('test' as " <> ctn <> ")", Cast (StringLit "'" "'" "test") stn) + ] + makeTests a = makeSimpleTests a <> makeCastTests a + + +{- +== 6.2 + +Function +Define a field of a row type. + + ::= +-} + +fieldDefinition :: TestItem +fieldDefinition = Group "field definition" + [e "cast('(1,2)' as row(a int,b char))" + $ Cast (StringLit "'" "'" "(1,2)") + $ RowTypeName [(Name Nothing "a", TypeName [Name Nothing "int"]) + ,(Name Nothing "b", TypeName [Name Nothing "char"])]] +{- +== 6.3 + +Function +Specify a value that is syntactically self-delimited. + + ::= + + | + + ::= + + + ::= + + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + + ::= + + | +-} + +valueExpressions :: TestItem +valueExpressions = Group "value expressions" + [generalValueSpecification + ,parameterSpecification + ,contextuallyTypedValueSpecification + ,identifierChain + ,columnReference + ,setFunctionSpecification + ,windowFunction + ,nestedWindowFunction + ,caseExpression + ,castSpecification + ,nextScalarExpression + ,fieldReference + ,arrayElementReference + ,multisetElementReference + ,numericScalarExpression + ,numericValueFunction + ,stringScalarExpression + ,stringValueFunction + ,datetimeScalarExpression + ,datetimeValueFunction + ,intervalScalarExpression + ,intervalValueFunction + ,booleanScalarExpression + ,arrayScalarExpression + ,arrayValueFunction + ,arrayValueConstructor + ,multisetScalarExpression + ,multisetValueFunction + ,multisetValueConstructor + ,parenthesizedScalarExpression + ] + +parenthesizedScalarExpression :: TestItem +parenthesizedScalarExpression = Group "parenthesized value expression" + [e "(3)" $ Parens (NumLit "3") + ,e "((3))" $ Parens $ Parens (NumLit "3") + ] + +{- +== 6.4 and + +Function +Specify one or more values, host parameters, SQL parameters, dynamic parameters, or host variables. + + ::= | + + ::= + + | + + ::= + + | + | + | + | + | CURRENT_CATALOG + | CURRENT_DEFAULT_TRANSFORM_GROUP + | CURRENT_PATH + | CURRENT_ROLE + | CURRENT_SCHEMA + | CURRENT_TRANSFORM_GROUP_FOR_TYPE + | CURRENT_USER + | SESSION_USER + | SYSTEM_USER + | USER + | VALUE +-} + +generalValueSpecification :: TestItem +generalValueSpecification = Group "general value specification" + $ map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP" + ,"CURRENT_PATH" + ,"CURRENT_ROLE" + ,"CURRENT_USER" + ,"SESSION_USER" + ,"SYSTEM_USER" + ,"USER" + ,"VALUE"] + where + mkIden nm = e nm $ Iden [Name Nothing nm] + +{- +TODO: add the missing bits + + ::= + + | + | + | + + ::= + + | + | + | + | + | + + ::= + + | + | + | + + ::= + [ ] + + ::= + + ::= + [ ] + + ::= [ INDICATOR ] + + ::= [ INDICATOR ] + + ::= + + + + ::= | +-} + +parameterSpecification :: TestItem +parameterSpecification = Group "parameter specification" + [e ":hostparam" $ HostParameter ":hostparam" Nothing + ,e ":hostparam indicator :another_host_param" + $ HostParameter ":hostparam" $ Just ":another_host_param" + ,e "?" $ Parameter + ,e ":h[3]" $ Array (HostParameter ":h" Nothing) [NumLit "3"] + ] + +{- + ::= + COLLATION FOR + +TODO: review the modules stuff + +== 6.5 + +Function +Specify a value whose data type is to be inferred from its context. + + ::= + + | + + ::= + + | + + ::= NULL + + ::= + ARRAY + | MULTISET + + ::= DEFAULT +-} + +contextuallyTypedValueSpecification :: TestItem +contextuallyTypedValueSpecification = + Group "contextually typed value specification" + [e "null" $ Iden [Name Nothing "null"] + ,e "array[]" $ Array (Iden [Name Nothing "array"]) [] + ,e "multiset[]" $ MultisetCtor [] + ,e "default" $ Iden [Name Nothing "default"] + ] + +{- +== 6.6 + +Function +Disambiguate a -separated chain of identifiers. + + ::= [ { }... ] + + ::= +-} + +identifierChain :: TestItem +identifierChain = Group "identifier chain" + [e "a.b" $ Iden [Name Nothing "a",Name Nothing "b"]] + +{- +== 6.7 + +Function +Reference a column. + + ::= + + | MODULE +-} + +columnReference :: TestItem +columnReference = Group "column reference" + [e "module.a.b" $ Iden [Name Nothing "module",Name Nothing "a",Name Nothing "b"]] + +{- +== 6.8 + +Function +Reference an SQL parameter. + + ::= + +== 6.9 + +Function +Specify a value derived by the application of a function to an argument. + + ::= | + + ::= + GROUPING + [ { }... ] +-} + +setFunctionSpecification :: TestItem +setFunctionSpecification = Group "set function specification" + $ + [q "SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\ + \ GROUPING(SalesQuota) AS Grouping\n\ + \FROM Sales.SalesPerson\n\ + \GROUP BY ROLLUP(SalesQuota);" + $ toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "SalesQuota"],Nothing) + ,(App [Name Nothing "SUM"] [Iden [Name Nothing "SalesYTD"]] + ,Just (Name Nothing "TotalSalesYTD")) + ,(App [Name Nothing "GROUPING"] [Iden [Name Nothing "SalesQuota"]] + ,Just (Name Nothing "Grouping"))] + ,msFrom = [TRSimple [Name Nothing "Sales",Name Nothing "SalesPerson"]] + ,msGroupBy = [Rollup [SimpleGroup (Iden [Name Nothing "SalesQuota"])]]} + ] + +{- +== 6.10 + +Function +Specify a window function. + + ::= + OVER + + ::= + + | ROW_NUMBER + | + | + | + | + | + + ::= RANK | DENSE_RANK | PERCENT_RANK | CUME_DIST + + ::= NTILE + + ::= + + | + + ::= + + [ [ ] ] + [ ] + + ::= LEAD | LAG + + ::= + + ::= + + ::= + + ::= RESPECT NULLS | IGNORE NULLS + + ::= + [ + ] + + ::= FIRST_VALUE | LAST_VALUE + + ::= + NTH_VALUE + [ ] [ ] + + ::= | + + ::= FROM FIRST | FROM LAST + + ::= + + | + + ::= +-} + +windowFunction :: TestItem +windowFunction = Group "window function" + [-- todo: window function + ] + +{- +== 6.11 + +Function + +Specify a function nested in an aggregated argument of an + simply contained in a . + + ::= + + | + + ::= + ROW_NUMBER + + ::= + VALUE_OF AT + [ ] + + ::= + BEGIN_PARTITION + | BEGIN_FRAME + | CURRENT_ROW + | FRAME_ROW + | END_FRAME + | END_PARTITION + + ::= [ ] + + ::= + + | + + ::= + + | + + ::= +-} + +nestedWindowFunction :: TestItem +nestedWindowFunction = Group "nested window function" + [-- todo: nested window function + ] + + +{- +== 6.12 + +Function +Specify a conditional value. + + ::= | + + ::= + NULLIF + | COALESCE + { }... + + ::= | + + ::= + CASE ... [ ] END + + ::= CASE ... [ ] END + + ::= WHEN THEN + + ::= WHEN THEN + + ::= ELSE + + ::= | + + ::= [ { }... ] + + ::= + + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + +I haven't seen these part 2 style when operands in the wild. It +doesn't even allow all the binary operators here. We will allow them +all, and parser and represent these expressions by considering all the +binary ops as unary prefix ops. + + ::= | NULL + + ::= +-} + +caseExpression :: TestItem +caseExpression = Group "case expression" + [-- todo: case expression + ] + +{- +== 6.13 + +Function +Specify a data conversion. + + ::= + CAST AS + + ::= | + + ::= | +-} + +castSpecification :: TestItem +castSpecification = Group "cast specification" + [e "cast(a as int)" + $ Cast (Iden [Name Nothing "a"]) (TypeName [Name Nothing "int"]) + ] + +{- +== 6.14 + +Function +Return the next value of a sequence generator. + + ::= NEXT VALUE FOR +-} + +nextScalarExpression :: TestItem +nextScalarExpression = Group "next value expression" + [e "next value for a.b" $ NextValueFor [Name Nothing "a", Name Nothing "b"] + ] + +{- +== 6.15 + +Function +Reference a field of a row value. + + ::= +-} + +fieldReference :: TestItem +fieldReference = Group "field reference" + [e "f(something).a" + $ BinOp (App [Name Nothing "f"] [Iden [Name Nothing "something"]]) + [Name Nothing "."] + (Iden [Name Nothing "a"]) + ] + +{- +TODO: try all possible value expression syntax variations followed by +field reference + +== 6.16 + +Function +Modify the declared type of an expression. + + ::= + TREAT AS + + ::= + + ::= | + +todo: subtype treatment + +== 6.17 + +Function +Reference an SQL-invoked method of a user-defined type value. + + ::= | + + ::= + [ ] + + ::= + AS + [ ] + + ::= + + ::= + +todo: method invocation + +== 6.18 + +Function +Invoke a static method. + + ::= + + [ ] + + ::= + +todo: static method invocation + +== 6.19 + +Function +Invoke a method on a newly-constructed value of a structured type. + + ::= + NEW + + ::= | + +todo: new specification + +== 6.20 + +Function +Return a value acquired by accessing a column of the row identified by +a value of a reference type or by invoking an SQL-invoked method. + + ::= + + [ ] + + ::= + +todo: attribute of method reference + +== 6.21 + +Function +Access a column of the row identified by a value of a reference type. + + ::= + + +todo: deference operation + +== 6.22 + +Function +Return a value acquired from invoking an SQL-invoked routine that is a method. + + ::= + + +todo: method reference + +== 6.23 + +Function +Obtain the value referenced by a reference value. + + ::= + DEREF + +todo: reference resolution + +== 6.24 + +Function +Return an element of an array. + + ::= + + +-} + +arrayElementReference :: TestItem +arrayElementReference = Group "array element reference" + [e "something[3]" + $ Array (Iden [Name Nothing "something"]) [NumLit "3"] + ,e "(something(a))[x]" + $ Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]])) + [Iden [Name Nothing "x"]] + ,e "(something(a))[x][y] " + $ Array ( + Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]])) + [Iden [Name Nothing "x"]]) + [Iden [Name Nothing "y"]] + ] + +{- +== 6.25 + +Function +Return the sole element of a multiset of one element. + + ::= + ELEMENT +-} + +multisetElementReference :: TestItem +multisetElementReference = Group "multisetElementReference" + [e "element(something)" + $ App [Name Nothing "element"] [Iden [Name Nothing "something"]] + ] + +{- +== 6.26 + +Function +Specify a value. + + ::= + + | + | + + ::= + + | + | + | + | + | + | + + ::= + + ::= + + ::= + + | + +== 6.27 + +Function +Specify a numeric value. + + ::= + + | + | + + ::= | | + + ::= [ ] + + ::= | +-} + +numericScalarExpression :: TestItem +numericScalarExpression = Group "numeric value expression" + [e "a + b" $ binOp "+" + ,e "a - b" $ binOp "-" + ,e "a * b" $ binOp "*" + ,e "a / b" $ binOp "/" + ,e "+a" $ prefOp "+" + ,e "-a" $ prefOp "-" + ] + where + binOp o = BinOp (Iden [Name Nothing "a"]) [Name Nothing o] (Iden [Name Nothing "b"]) + prefOp o = PrefixOp [Name Nothing o] (Iden [Name Nothing "a"]) + +{- +TODO: precedence and associativity tests (need to review all operators +for what precendence and associativity tests to write) + +== 6.28 + +Function +Specify a function yielding a value of type numeric. + + ::= + + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | +-} + + +numericValueFunction :: TestItem +numericValueFunction = Group "numeric value function" + [-- todo: numeric value function + ] + +{- + ::= + + | + + ::= + OCCURRENCES_REGEX + [ FLAG ] + IN + [ FROM ] + [ USING ] + + + ::= + + ::= + + ::= + + ::= + POSITION_REGEX + [ ] + [ FLAG ] + IN + [ FROM ] + [ USING ] + [ OCCURRENCE ] + [ GROUP ] + + + ::= START | AFTER + + ::= + + ::= + + ::= + POSITION IN + [ USING ] + + ::= + + ::= + + ::= + POSITION IN + + ::= | + + ::= + { CHAR_LENGTH | CHARACTER_LENGTH } + [ USING ] + + ::= + OCTET_LENGTH + + ::= + EXTRACT FROM + + ::= |
+-} + +arrayValueConstructor :: TestItem +arrayValueConstructor = Group "array value constructor" + [e "array[1,2,3]" + $ Array (Iden [Name Nothing "array"]) + [NumLit "1", NumLit "2", NumLit "3"] + ,e "array[a,b,c]" + $ Array (Iden [Name Nothing "array"]) + [Iden [Name Nothing "a"], Iden [Name Nothing "b"], Iden [Name Nothing "c"]] + ,e "array(select * from t)" + $ ArrayCtor (toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]}) + ,e "array(select * from t order by a)" + $ ArrayCtor (toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + DirDefault NullsOrderDefault]}) + ] + + +{- +== 6.39 + +Function +Specify a multiset value. + + ::= + + | MULTISET UNION [ ALL | DISTINCT ] + | MULTISET EXCEPT [ ALL | DISTINCT ] + + ::= + + | MULTISET INTERSECT [ ALL | DISTINCT ] + + ::= | +-} + +multisetScalarExpression :: TestItem +multisetScalarExpression = Group "multiset value expression" + $ map (uncurry (testScalarExpr ansi2011)) + [("a multiset union b" + ,MultisetBinOp (Iden [Name Nothing "a"]) Union SQDefault (Iden [Name Nothing "b"])) + ,("a multiset union all b" + ,MultisetBinOp (Iden [Name Nothing "a"]) Union All (Iden [Name Nothing "b"])) + ,("a multiset union distinct b" + ,MultisetBinOp (Iden [Name Nothing "a"]) Union Distinct (Iden [Name Nothing "b"])) + ,("a multiset except b" + ,MultisetBinOp (Iden [Name Nothing "a"]) Except SQDefault (Iden [Name Nothing "b"])) + ,("a multiset intersect b" + ,MultisetBinOp (Iden [Name Nothing "a"]) Intersect SQDefault (Iden [Name Nothing "b"])) + ] + +{- +TODO: check precedence and associativity + +== 6.40 + +Function +Specify a function yielding a value of a multiset type. + + ::= + + ::= + SET + +TODO: set is now a reserved keyword. Fix the set parsing with a +special case term. +-} + +multisetValueFunction :: TestItem +multisetValueFunction = Group "multiset value function" + $ map (uncurry (testScalarExpr ansi2011)) + [("set(a)", App [Name Nothing "set"] [Iden [Name Nothing "a"]]) + ] + +{- +== 6.41 + +Function +Specify construction of a multiset. + + ::= + + | + |
+ + ::= + MULTISET + + ::= + [ { }... ] + + ::= + + ::= MULTISET
+ +
::= TABLE
+-} + +multisetValueConstructor :: TestItem +multisetValueConstructor = Group "multiset value constructor" + $ map (uncurry (testScalarExpr ansi2011)) + [("multiset[a,b,c]", MultisetCtor[Iden [Name Nothing "a"] + ,Iden [Name Nothing "b"], Iden [Name Nothing "c"]]) + ,("multiset(select * from t)", MultisetQueryCtor ms) + ,("table(select * from t)", MultisetQueryCtor ms) + ] + where + ms = toQueryExpr $ makeSelect {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + + +-- = 7 Query expressions + +queryExpressions :: TestItem +queryExpressions = Group "query expressions" + [rowValueConstructor + ,tableValueConstructor + ,fromClause + ,tableReference + ,joinedTable + ,whereClause + ,groupByClause + ,havingClause + ,windowClause + ,querySpecification + ,withQueryExpression + ,setOpQueryExpression + ,explicitTableQueryExpression + ,orderOffsetFetchQueryExpression + ,searchOrCycleClause + ] + + +{- +== 7.1 + +Function +Specify a value or list of values to be constructed into a row. + + ::= + + | + | + + ::= + + + | ROW + | + + ::= + [ { }... ] + + ::= + + ::= + + | + | + | + | + + | ROW + + ::= + + [ { }... ] + + ::= + + | + + ::= + + | + | +-} + +rowValueConstructor :: TestItem +rowValueConstructor = Group "row value constructor" + $ map (uncurry (testScalarExpr ansi2011)) + [("(a,b)" + ,SpecialOp [Name Nothing "rowctor"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]]) + ,("row(1)",App [Name Nothing "row"] [NumLit "1"]) + ,("row(1,2)",App [Name Nothing "row"] [NumLit "1",NumLit "2"]) + ] + +{- +== 7.2 + +Function +Specify a row value. + + ::= + + | + +
::= + + | + + ::= + + | + + ::= + + | + + ::= + +There is nothing new here. + +== 7.3
+ +Function +Specify a set of s to be constructed into a table. + +
::= VALUES + + ::= +
[ {
}... ] + + ::= + VALUES + + ::= + + [ { }... ] +-} + +tableValueConstructor :: TestItem +tableValueConstructor = Group "table value constructor" + $ map (uncurry (testQueryExpr ansi2011)) + [("values (1,2), (a+b,(select count(*) from t));" + ,Values [[NumLit "1", NumLit "2"] + ,[BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] + (Iden [Name Nothing "b"]) + ,SubQueryExpr SqSq + (toQueryExpr $ makeSelect + {msSelectList = [(App [Name Nothing "count"] [Star],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]})]]) + ] + +{- +== 7.4
+ +Function +Specify a table or a grouped table. + +
::= + + [ ] + [ ] + [ ] + [ ] + +== 7.5 + +Function +Specify a table derived from one or more tables. + + ::= FROM
+ +
::= +
[ {
}... ] +-} + +fromClause :: TestItem +fromClause = Group "fromClause" + $ map (uncurry (testQueryExpr ansi2011)) + [("select * from tbl1,tbl2" + ,toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "tbl1"], TRSimple [Name Nothing "tbl2"]] + })] + + +{- +== 7.6
+ +Function +Reference a table. +-} + +tableReference :: TestItem +tableReference = Group "table reference" + $ map (uncurry (testQueryExpr ansi2011)) + [("select * from t", toQueryExpr sel) + +{- +
::=
| + +
::=
[ ] + + ::= + TABLESAMPLE + [ ] + + ::= BERNOULLI | SYSTEM + + ::= REPEATABLE + + ::= + + ::= + +
::= +
[ ] + [ [ AS ] + [ ] ] + | [ AS ] + [ ] + | [ AS ] + [ ] + | [ AS ] + [ ] + |
[ AS ] + [ ] + | [ [ AS ] + [ ] ] + | [ [ AS ] + [ ] ] + | + + ::= + FOR SYSTEM_TIME AS OF + | FOR SYSTEM_TIME BETWEEN [ ASYMMETRIC | SYMMETRIC ] + AND + | FOR SYSTEM_TIME FROM TO + +TODO: query system time period spec + + ::= + + ::= + + ::= + + ::= ONLY
+ +TODO: only + + ::= LATERAL
+ + ::= + UNNEST + [ { }... ] + [ WITH ORDINALITY ] + +
::= + TABLE + + ::=
+ +
::=
| | + + ::= + + ::= [ { }... ] + + ::= + TABLE + + ::= + + | + | + | + + ::= FINAL | NEW | OLD + + ::= + + | +-} + + + -- table or query name + ,("select * from t u", toQueryExpr $ a sel) + ,("select * from t as u", toQueryExpr $ a sel) + ,("select * from t u(a,b)", toQueryExpr sel1 ) + ,("select * from t as u(a,b)", toQueryExpr sel1) + -- derived table TODO: realistic example + ,("select * from (select * from t) u" + ,toQueryExpr $ a $ sel {msFrom = [TRQueryExpr $ toQueryExpr sel]}) + -- lateral TODO: realistic example + ,("select * from lateral t" + ,toQueryExpr $ af TRLateral sel) + -- TODO: bug, lateral should bind more tightly than the alias + --,("select * from lateral t u" + -- ,a $ af sel TRLateral) + -- collection TODO: realistic example + -- TODO: make it work + --,("select * from unnest(a)", undefined) + --,("select * from unnest(a,b)", undefined) + --,("select * from unnest(a,b) with ordinality", undefined) + --,("select * from unnest(a,b) with ordinality u", undefined) + --,("select * from unnest(a,b) with ordinality as u", undefined) + -- table fn TODO: realistic example + -- TODO: make it work + --,("select * from table(a)", undefined) + -- parens + ,("select * from (a join b)", toQueryExpr jsel) + ,("select * from (a join b) u", toQueryExpr $ a jsel) + ,("select * from ((a join b)) u", toQueryExpr $ a $ af TRParens jsel) + ,("select * from ((a join b) u) u", toQueryExpr $ a $ af TRParens $ a jsel) + ] + where + sel = makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + af f s = s {msFrom = map f (msFrom s)} + a s = af (\x -> TRAlias x $ Alias (Name Nothing "u") Nothing) s + sel1 = makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRAlias (TRSimple [Name Nothing "t"]) + $ Alias (Name Nothing "u") $ Just [Name Nothing "a", Name Nothing "b"]]} + jsel = sel {msFrom = + [TRParens $ TRJoin (TRSimple [Name Nothing "a"]) + False + JInner + (TRSimple [Name Nothing "b"]) + Nothing]} + +{- +== 7.7 + +Function +Specify a table derived from a Cartesian product, inner join, or outer join. + + ::= | | + + ::=
CROSS JOIN
+ + ::= + {
| } + [ ] JOIN + {
| } + + + ::= +
PARTITION BY + + + ::= + + [ { }... ] + + + ::= + + ::= + {
| } + NATURAL [ ] JOIN + {
| } + + ::= | + + ::= ON + + ::= USING + + ::= INNER | [ OUTER ] + + ::= LEFT | RIGHT | FULL + + ::= +-} + +joinedTable :: TestItem +joinedTable = Group "joined table" + $ map (uncurry (testQueryExpr ansi2011)) + [("select * from a cross join b" + ,sel $ TRJoin a False JCross b Nothing) + ,("select * from a join b on true" + ,sel $ TRJoin a False JInner b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a join b using (c)" + ,sel $ TRJoin a False JInner b + (Just $ JoinUsing [Name Nothing "c"])) + ,("select * from a inner join b on true" + ,sel $ TRJoin a False JInner b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a left join b on true" + ,sel $ TRJoin a False JLeft b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a left outer join b on true" + ,sel $ TRJoin a False JLeft b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a right join b on true" + ,sel $ TRJoin a False JRight b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a full join b on true" + ,sel $ TRJoin a False JFull b + (Just $ JoinOn $ Iden [Name Nothing "true"])) + ,("select * from a natural join b" + ,sel $ TRJoin a True JInner b Nothing) + ,("select * from a natural inner join b" + ,sel $ TRJoin a True JInner b Nothing) + ,("select * from a natural left join b" + ,sel $ TRJoin a True JLeft b Nothing) + ,("select * from a natural left outer join b" + ,sel $ TRJoin a True JLeft b Nothing) + ,("select * from a natural right join b" + ,sel $ TRJoin a True JRight b Nothing) + ,("select * from a natural full join b" + ,sel $ TRJoin a True JFull b Nothing) + ] + where + sel t = toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [t]} + a = TRSimple [Name Nothing "a"] + b = TRSimple [Name Nothing "b"] + +{- +TODO: partitioned joins + +== 7.8 + +Function + +Specify a table derived by the application of a to +the result of the preceding . + + ::= WHERE +-} + +whereClause :: TestItem +whereClause = Group "where clause" + $ map (uncurry (testQueryExpr ansi2011)) + [("select * from t where a = 5" + ,toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")})] + +{- +== 7.9 + +Function + +Specify a grouped table derived by the application of the to the result of the previously specified clause. + + ::= GROUP BY [ ] + + ::= + [ { }... ] + + ::= + + | + | + | + | + + ::= + + | + + ::= [ ] + + ::= + [ { }... ] + + ::= + ROLLUP + + ::= + [ { }... ] + + ::= CUBE + + ::= + GROUPING SETS + + ::= [ { }... ] + + ::= + + | + | + | + | + + ::= +-} + + +groupByClause :: TestItem +groupByClause = Group "group by clause" + $ map (uncurry (testQueryExpr ansi2011)) + [("select a,sum(x) from t group by a" + ,toQueryExpr $ ms [SimpleGroup $ Iden [Name Nothing "a"]]) + ,("select a,sum(x) from t group by a collate c" + ,toQueryExpr $ ms [SimpleGroup $ Collate (Iden [Name Nothing "a"]) [Name Nothing "c"]]) + ,("select a,b,sum(x) from t group by a,b" + ,toQueryExpr $ msx [SimpleGroup $ Iden [Name Nothing "a"] + ,SimpleGroup $ Iden [Name Nothing "b"]]) + -- todo: group by set quantifier + --,("select a,sum(x) from t group by distinct a" + --,undefined) + --,("select a,sum(x) from t group by all a" + -- ,undefined) + ,("select a,b,sum(x) from t group by rollup(a,b)" + ,toQueryExpr $ msx [Rollup [SimpleGroup $ Iden [Name Nothing "a"] + ,SimpleGroup $ Iden [Name Nothing "b"]]]) + ,("select a,b,sum(x) from t group by cube(a,b)" + ,toQueryExpr $ msx [Cube [SimpleGroup $ Iden [Name Nothing "a"] + ,SimpleGroup $ Iden [Name Nothing "b"]]]) + ,("select a,b,sum(x) from t group by grouping sets((),(a,b))" + ,toQueryExpr $ msx [GroupingSets [GroupingParens [] + ,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"] + ,SimpleGroup $ Iden [Name Nothing "b"]]]]) + ,("select sum(x) from t group by ()" + ,toQueryExpr $ makeSelect + {msSelectList = [(App [Name Nothing "sum"] [Iden [Name Nothing "x"]], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = [GroupingParens []]}) + ] + where + ms g = makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "x"]], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = g} + msx g = makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing) + ,(Iden [Name Nothing "b"],Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "x"]], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = g} + +{- +== 7.10 + +Function + +Specify a grouped table derived by the elimination of groups that do +not satisfy a . + + ::= HAVING +-} + +havingClause :: TestItem +havingClause = Group "having clause" + $ map (uncurry (testQueryExpr ansi2011)) + [("select a,sum(x) from t group by a having sum(x) > 1000" + ,toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing) + ,(App [Name Nothing "sum"] [Iden [Name Nothing "x"]], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msGroupBy = [SimpleGroup $ Iden [Name Nothing "a"]] + ,msHaving = Just $ BinOp (App [Name Nothing "sum"] [Iden [Name Nothing "x"]]) + [Name Nothing ">"] + (NumLit "1000")}) + ] + +{- +== 7.11 + +Function +Specify one or more window definitions. + + ::= WINDOW + + ::= + [ { }... ] + + ::= AS + + ::= + + ::= + + + ::= + [ ] + [ ] + [ ] + [ ] + + ::= + + ::= + PARTITION BY + + ::= + + [ { }... ] + + ::= [ ] + + ::= ORDER BY + + ::= + + [ ] + + ::= ROWS | RANGE | GROUPS + + ::= | + + ::= + UNBOUNDED PRECEDING + | + | CURRENT ROW + + ::= PRECEDING + + ::= + BETWEEN AND + + ::= + + ::= + + ::= + + | UNBOUNDED FOLLOWING + | + + ::= FOLLOWING + + ::= + EXCLUDE CURRENT ROW + | EXCLUDE GROUP + | EXCLUDE TIES + | EXCLUDE NO OTHERS +-} + +windowClause :: TestItem +windowClause = Group "window clause" + [-- todo: window clause + ] + +{- +== 7.12 + +Function +Specify a table derived from the result of a
. + + ::= + SELECT [ ]
+ + [ { ::= | + + ::= + + | + + ::= + [ { }... ] + + ::= + + ::= [ ] + + ::= [ AS ] + + ::= + + [ AS ] + + ::= +-} + +querySpecification :: TestItem +querySpecification = Group "query specification" + $ map (uncurry (testQueryExpr ansi2011)) + [("select a from t",toQueryExpr ms) + ,("select all a from t",toQueryExpr $ ms {msSetQuantifier = All}) + ,("select distinct a from t",toQueryExpr $ ms {msSetQuantifier = Distinct}) + ,("select * from t", toQueryExpr $ ms {msSelectList = [(Star,Nothing)]}) + ,("select a.* from t" + ,toQueryExpr $ ms {msSelectList = + [(QStar [Name Nothing "a"] + ,Nothing)]}) + ,("select a b from t" + ,toQueryExpr $ ms {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "b")]}) + ,("select a as b from t" + ,toQueryExpr $ ms {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "b")]}) + ,("select a,b from t" + ,toQueryExpr $ ms {msSelectList = [(Iden [Name Nothing "a"], Nothing) + ,(Iden [Name Nothing "b"], Nothing)]}) + -- todo: all field reference alias + --,("select * as (a,b) from t",undefined) + ] + where + ms = makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + } + +{- +== 7.13 + +Function +Specify a table. + + ::= + [ ] + [ ] [ ] [ ] + + ::= WITH [ RECURSIVE ] + + ::= [ { }... ] + + ::= + [ ] + AS
[ ] + + ::= +-} + +withQueryExpression :: TestItem +withQueryExpression= Group "with query expression" + [-- todo: with query expression + ] + +{- + ::= + + | UNION [ ALL | DISTINCT ] + [ ] + | EXCEPT [ ALL | DISTINCT ] + [ ] + + ::= + + | INTERSECT [ ALL | DISTINCT ] + [ ] + + ::= + + | + [ ] [ ] [ ] + +-} + +setOpQueryExpression :: TestItem +setOpQueryExpression= Group "set operation query expression" + $ map (uncurry (testQueryExpr ansi2011)) + -- todo: complete setop query expression tests + [{-("select * from t union select * from t" + ,undefined) + ,("select * from t union all select * from t" + ,undefined) + ,("select * from t union distinct select * from t" + ,undefined) + ,("select * from t union corresponding select * from t" + ,undefined) + ,("select * from t union corresponding by (a,b) select * from t" + ,undefined) + ,("select * from t except select * from t" + ,undefined) + ,("select * from t in intersect select * from t" + ,undefined)-} + ] + +{- +TODO: tests for the associativity and precendence + +TODO: not sure exactly where parens are allowed, we will allow them +everywhere + + ::= + + |
+ | + + ::= TABLE
+ + ::= + CORRESPONDING [ BY ] + + ::= +-} + +explicitTableQueryExpression :: TestItem +explicitTableQueryExpression= Group "explicit table query expression" + $ map (uncurry (testQueryExpr ansi2011)) + [("table t", Table [Name Nothing "t"]) + ] + + +{- + ::= ORDER BY + + ::= OFFSET { ROW | ROWS } + + ::= + FETCH { FIRST | NEXT } [ ] { ROW | ROWS } { ONLY | WITH TIES } + + ::= | + + ::= + + ::= + + ::= PERCENT +-} + +orderOffsetFetchQueryExpression :: TestItem +orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression" + $ map (uncurry (testQueryExpr ansi2011)) + [-- todo: finish tests for order offset and fetch + ("select a from t order by a" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + DirDefault NullsOrderDefault]}) + ,("select a from t offset 5 row" + ,toQueryExpr $ ms {msOffset = Just $ NumLit "5"}) + ,("select a from t offset 5 rows" + ,toQueryExpr $ ms {msOffset = Just $ NumLit "5"}) + ,("select a from t fetch first 5 row only" + ,toQueryExpr $ ms {msFetchFirst = Just $ NumLit "5"}) + -- todo: support with ties and percent in fetch + --,("select a from t fetch next 5 rows with ties" + --,("select a from t fetch first 5 percent rows only" + ] + where + ms = makeSelect + {msSelectList = [(Iden [Name Nothing "a"], Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + } + + +{- +== 7.14 + +Function + +Specify the generation of ordering and cycle detection information in +the result of recursive query expressions. + + ::= + + | + | + + ::= SEARCH SET + + ::= + DEPTH FIRST BY + | BREADTH FIRST BY + + ::= + + ::= + CYCLE SET TO + DEFAULT USING + + ::= [ { }... ] + + ::= + + ::= + + ::= + + ::= + + ::= +-} + +searchOrCycleClause :: TestItem +searchOrCycleClause = Group "search or cycle clause" + [-- todo: search or cycle clause + ] + +{- +== 7.15 + +Function + +Specify a scalar value, a row, or a table derived from a . + + ::= + + ::= + +
::= + + ::= +-} + +scalarSubquery :: TestItem +scalarSubquery = Group "scalar subquery" + [-- todo: scalar subquery + ] + +{- += 8 Predicates + +== 8.1 + +Function +Specify a condition that can be evaluated to give a boolean value. + + ::= + + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + | +-} + +predicates :: TestItem +predicates = Group "predicates" + [comparisonPredicates + ,betweenPredicate + ,inPredicate + ,likePredicate + ,similarPredicate + ,regexLikePredicate + ,nullPredicate + ,quantifiedComparisonPredicate + ,existsPredicate + ,uniquePredicate + ,normalizedPredicate + ,matchPredicate + ,overlapsPredicate + ,distinctPredicate + ,memberPredicate + ,submultisetPredicate + ,setPredicate + ,periodPredicate + ] + + +{- +== 8.1 + +No grammar + +== 8.2 + +Function +Specify a comparison of two row values. + + ::= + + ::= + + ::= + + | + | + | + | + | +-} + +comparisonPredicates :: TestItem +comparisonPredicates = Group "comparison predicates" + $ map (uncurry (testScalarExpr ansi2011)) + $ map mkOp ["=", "<>", "<", ">", "<=", ">="] + <> [("ROW(a) = ROW(b)" + ,BinOp (App [Name Nothing "ROW"] [a]) + [Name Nothing "="] + (App [Name Nothing "ROW"] [b])) + ,("(a,b) = (c,d)" + ,BinOp (SpecialOp [Name Nothing "rowctor"] [a,b]) + [Name Nothing "="] + (SpecialOp [Name Nothing "rowctor"] [Iden [Name Nothing "c"], Iden [Name Nothing "d"]])) + ] + where + mkOp nm = ("a " <> nm <> " b" + ,BinOp a [Name Nothing nm] b) + a = Iden [Name Nothing "a"] + b = Iden [Name Nothing "b"] + +{- +TODO: what other tests, more complex expressions with comparisons? + +== 8.3 + +Function +Specify a range comparison. + + ::= + + ::= + [ NOT ] BETWEEN [ ASYMMETRIC | SYMMETRIC ] + AND +-} + +betweenPredicate :: TestItem +betweenPredicate = Group "between predicate" + [-- todo: between predicate + ] + +{- +== 8.4 + +Function +Specify a quantified comparison. + + ::= + + ::= [ NOT ] IN + + ::= +
+ | + + ::= + [ { }... ] +-} + +inPredicate :: TestItem +inPredicate = Group "in predicate" + [-- todo: in predicate + ] + +{- +== 8.5 + +Function +Specify a pattern-match comparison. + + ::= | + + ::= + + + ::= + [ NOT ] LIKE [ ESCAPE ] + + ::= + + ::= + + ::= + + ::= + [ NOT ] LIKE [ ESCAPE ] + + ::= + + ::= +-} + +likePredicate :: TestItem +likePredicate = Group "like predicate" + [-- todo: like predicate + ] + +{- +== 8.6 + +Function +Specify a character string similarity by means of a regular expression. + + ::= + + ::= + [ NOT ] SIMILAR TO [ ESCAPE ] + + ::= + + ::= + + | + + ::= | + + ::= + + | + | + | + | + + ::= [ ] + + ::= [ ] + + ::= + + ::= + + ::= + + | + | + | + + ::= | + + ::= !! See the Syntax Rules. + + ::= !! See the Syntax Rules. + + ::= + + | ... + | ... + | ... + ... + + ::= + + ::= + + ::= + + | + | + + ::= +-} + +similarPredicate :: TestItem +similarPredicate = Group "similar predicate" + [-- todo: similar predicate + ] + + +{- +== 8.7 + +Function +Specify a pattern-match comparison using an XQuery regular expression. + + ::= + + ::= + [ NOT ] LIKE_REGEX [ FLAG ] +-} + +regexLikePredicate :: TestItem +regexLikePredicate = Group "regex like predicate" + [-- todo: regex like predicate + ] + +{- +== 8.8 + +Function +Specify a test for a null value. + + ::= + + ::= IS [ NOT ] NULL +-} + +nullPredicate :: TestItem +nullPredicate = Group "null predicate" + [-- todo: null predicate + ] + +{- +== 8.9 + +Function +Specify a quantified comparison. + + ::= + + + ::= +
+ + ::= | + + ::= ALL + + ::= SOME | ANY +-} + +quantifiedComparisonPredicate :: TestItem +quantifiedComparisonPredicate = Group "quantified comparison predicate" + $ map (uncurry (testScalarExpr ansi2011)) + + [("a = any (select * from t)" + ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPAny ms) + ,("a <= some (select * from t)" + ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPSome ms) + ,("a > all (select * from t)" + ,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms) + ,("(a,b) <> all (select * from t)" + ,QuantifiedComparison + (SpecialOp [Name Nothing "rowctor"] [Iden [Name Nothing "a"] + ,Iden [Name Nothing "b"]]) [Name Nothing "<>"] CPAll ms) + ] + where + ms = toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + +{- +== 8.10 + +Function +Specify a test for a non-empty set. + + ::= EXISTS
+-} + +existsPredicate :: TestItem +existsPredicate = Group "exists predicate" + $ map (uncurry (testScalarExpr ansi2011)) + [("exists(select * from t where a = 4)" + ,SubQueryExpr SqExists + $ toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msWhere = Just (BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "4")) + } + )] + +{- +== 8.11 + +Function +Specify a test for the absence of duplicate rows. + + ::= UNIQUE
+-} + +uniquePredicate :: TestItem +uniquePredicate = Group "unique predicate" + $ map (uncurry (testScalarExpr ansi2011)) + [("unique(select * from t where a = 4)" + ,SubQueryExpr SqUnique + $ toQueryExpr $ makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + ,msWhere = Just (BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "4")) + } + )] + +{- +== 8.12 + +Function +Determine whether a character string value is normalized. + + ::= + + ::= IS [ NOT ] [ ] NORMALIZED +-} + +normalizedPredicate :: TestItem +normalizedPredicate = Group "normalized predicate" + [-- todo: normalized predicate + ] + +{- +== 8.13 + +Function +Specify a test for matching rows. + + ::= + + ::= + MATCH [ UNIQUE ] [ SIMPLE | PARTIAL | FULL ]
+-} + +matchPredicate :: TestItem +matchPredicate = Group "match predicate" + $ map (uncurry (testScalarExpr ansi2011)) + [("a match (select a from t)" + ,Match (Iden [Name Nothing "a"]) False $ toQueryExpr ms) + ,("(a,b) match (select a,b from t)" + ,Match (SpecialOp [Name Nothing "rowctor"] + [Iden [Name Nothing "a"], Iden [Name Nothing "b"]]) False $ toQueryExpr msa) + ,("(a,b) match unique (select a,b from t)" + ,Match (SpecialOp [Name Nothing "rowctor"] + [Iden [Name Nothing "a"], Iden [Name Nothing "b"]]) True $ toQueryExpr msa) + ] + where + ms = makeSelect + {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + msa = ms {msSelectList = msSelectList ms + <> [(Iden [Name Nothing "b"],Nothing)]} + +{- +TODO: simple, partial and full + +== 8.14 + +Function +Specify a test for an overlap between two datetime periods. + + ::= + + + ::= + + ::= OVERLAPS + + ::= + + ::= +-} + +overlapsPredicate :: TestItem +overlapsPredicate = Group "overlaps predicate" + [-- todo: overlaps predicate + ] + +{- +== 8.15 + +Function +Specify a test of whether two row values are distinct + + ::= + + ::= + IS [ NOT ] DISTINCT FROM + + ::= + + ::= +-} + +distinctPredicate :: TestItem +distinctPredicate = Group "distinct predicate" + [-- todo: distinct predicate + ] + +{- +== 8.16 + +Function +Specify a test of whether a value is a member of a multiset. + + ::= + + ::= [ NOT ] MEMBER [ OF ] +-} + +memberPredicate :: TestItem +memberPredicate = Group "member predicate" + [-- todo: member predicate + ] + +{- +== 8.17 + +Function +Specify a test of whether a multiset is a submultiset of another multiset. + + ::= + + + ::= + [ NOT ] SUBMULTISET [ OF ] +-} + +submultisetPredicate :: TestItem +submultisetPredicate = Group "submultiset predicate" + [-- todo: submultiset predicate + ] + +{- +== 8.18 + +Function + +Specify a test of whether a multiset is a set (that is, does not +contain any duplicates). + + ::= + + ::= IS [ NOT ] A SET +-} + +setPredicate :: TestItem +setPredicate = Group "set predicate" + [-- todo: set predicate + ] + +{- +== 8.19 + +Function +Specify a type test. + + ::= + + ::= + IS [ NOT ] OF + + ::= + + [ { }... ] + + ::= + + | + + ::= + + + ::= + ONLY + +TODO: type predicate + +== 8.20 + +Function +Specify a test to determine the relationship between periods. + + ::= + + | + | + | + | + | + | + + ::= + + + ::= OVERLAPS + + ::= + + ::= + + ::= + + | PERIOD + + ::= + + ::= + + ::= + + ::= + + + ::= EQUALS + + ::= + + + ::= + CONTAINS + + ::= + + | + + ::= + + + ::= PRECEDES + + ::= + + + ::= SUCCEEDS + + ::= + + + ::= + IMMEDIATELY PRECEDES + + ::= + + + ::= + IMMEDIATELY SUCCEEDS +-} + +periodPredicate :: TestItem +periodPredicate = Group "period predicate" + [-- todo: period predicate + ] + +{- +== 8.21 + +Function + +Specify a condition that is True, False, or Unknown, depending on the +value of a . + + ::= + += 10 Additional common elements + +== 10.1 + +Function +Specify the precision of an interval data type. + + ::= TO | + + ::= + + [ ] + + ::= + + | SECOND [ ] + + ::= + + [ ] + | SECOND [ + [ ] ] + + ::= | SECOND + + ::= YEAR | MONTH | DAY | HOUR | MINUTE + + ::= + + ::= +-} + +intervalQualifier :: TestItem +intervalQualifier = Group "interval qualifier" + [-- todo: interval qualifier + ] + +{- +todo: also test all of these in the typenames and in the interval +literal tests + +== 10.2 + +Function +Specify a programming language. + + ::= LANGUAGE + + ::= ADA | C | COBOL | FORTRAN | M | MUMPS | PASCAL | PLI | SQL + +== 10.3 + +Function +Specify an order for searching for an SQL-invoked routine. + + ::= PATH + + ::= [ { }... ] + +== 10.4 + +Function +Invoke an SQL-invoked routine. + + ::= + + ::= [ ] + + ::= + [ [ { }... ] ] + + ::= + + | + | + | + | + + ::= + AS + + ::= + + + + ::= + + | + | + +== 10.5 + +Function +Identify a character set. + + ::= + + | + | + + ::= + + ::= + + ::= + +tested in the type names + +== 10.6 + +Function +Specify an SQL-invoked routine. + + ::= + SPECIFIC + | [ FOR ] + + ::= + ROUTINE + | FUNCTION + | PROCEDURE + | [ INSTANCE | STATIC | CONSTRUCTOR ] METHOD + + ::= [ ] + + ::= | + + ::= + [ [ { }... ] ] + +== 10.7 + +Function +Specify a default collation. + + ::= COLLATE +-} + +collateClause :: TestItem +collateClause = Group "collate clause" + $ map (uncurry (testScalarExpr ansi2011)) + [("a collate my_collation" + ,Collate (Iden [Name Nothing "a"]) [Name Nothing "my_collation"])] + +{- +== 10.8 and + +Function +Specify the name of a constraint and its characteristics. + + ::= CONSTRAINT + + ::= + [ [ NOT ] DEFERRABLE ] [ ] + | [ NOT ] DEFERRABLE [ ] [ ] + | + + ::= INITIALLY DEFERRED | INITIALLY IMMEDIATE + + ::= [ NOT ] ENFORCED + +== 10.9 + +Function +Specify a value computed from a collection of rows. + + ::= + COUNT [ ] + | [ ] + | [ ] + | [ ] + | [ ] + + ::= + [ ] + + + ::= + + ::= + AVG + | MAX + | MIN + | SUM + | EVERY + | ANY + | SOME + | COUNT + | STDDEV_POP + | STDDEV_SAMP + | VAR_SAMP + | VAR_POP + | COLLECT + | FUSION + | INTERSECTION + + ::= DISTINCT | ALL + + ::= FILTER WHERE + + ::= + + + + ::= + COVAR_POP + | COVAR_SAMP + | CORR + | REGR_SLOPE + | REGR_INTERCEPT + | REGR_COUNT + | REGR_R2 + | REGR_AVGX + | REGR_AVGY + | REGR_SXX + | REGR_SYY + | REGR_SXY + + ::= + + ::= + + ::= + + | + + ::= + + + + + ::= + WITHIN GROUP ORDER BY + + ::= + [ { }... ] + + ::= + + + + + ::= + + ::= PERCENTILE_CONT | PERCENTILE_DISC + + ::= + ARRAY_AGG + [ ORDER BY ] +-} + +aggregateFunction :: TestItem +aggregateFunction = Group "aggregate function" + $ map (uncurry (testScalarExpr ansi2011)) $ + [("count(*)",App [Name Nothing "count"] [Star]) + ,("count(*) filter (where something > 5)" + ,AggregateApp [Name Nothing "count"] SQDefault [Star] [] fil) + +-- gsf + + ,("count(a)",App [Name Nothing "count"] [Iden [Name Nothing "a"]]) + ,("count(distinct a)" + ,AggregateApp [Name Nothing "count"] + Distinct + [Iden [Name Nothing "a"]] [] Nothing) + ,("count(all a)" + ,AggregateApp [Name Nothing "count"] + All + [Iden [Name Nothing "a"]] [] Nothing) + ,("count(all a) filter (where something > 5)" + ,AggregateApp [Name Nothing "count"] + All + [Iden [Name Nothing "a"]] [] fil) + ] <> concatMap mkSimpleAgg + ["avg","max","min","sum" + ,"every", "any", "some" + ,"stddev_pop","stddev_samp","var_samp","var_pop" + ,"collect","fusion","intersection"] + +-- bsf + + <> concatMap mkBsf + ["COVAR_POP","COVAR_SAMP","CORR","REGR_SLOPE" + ,"REGR_INTERCEPT","REGR_COUNT","REGR_R2" + ,"REGR_AVGX","REGR_AVGY" + ,"REGR_SXX","REGR_SYY","REGR_SXY"] + +-- osf + + <> + [("rank(a,c) within group (order by b)" + ,AggregateAppGroup [Name Nothing "rank"] + [Iden [Name Nothing "a"], Iden [Name Nothing "c"]] + ob)] + <> map mkGp ["dense_rank","percent_rank" + ,"cume_dist", "percentile_cont" + ,"percentile_disc"] + <> [("array_agg(a)", App [Name Nothing "array_agg"] [Iden [Name Nothing "a"]]) + ,("array_agg(a order by z)" + ,AggregateApp [Name Nothing "array_agg"] + SQDefault + [Iden [Name Nothing "a"]] + [SortSpec (Iden [Name Nothing "z"]) + DirDefault NullsOrderDefault] + Nothing)] + + where + fil = Just $ BinOp (Iden [Name Nothing "something"]) [Name Nothing ">"] (NumLit "5") + ob = [SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] + mkGp nm = (nm <> "(a) within group (order by b)" + ,AggregateAppGroup [Name Nothing nm] + [Iden [Name Nothing "a"]] + ob) + + mkSimpleAgg nm = + [(nm <> "(a)",App [Name Nothing nm] [Iden [Name Nothing "a"]]) + ,(nm <> "(distinct a)" + ,AggregateApp [Name Nothing nm] + Distinct + [Iden [Name Nothing "a"]] [] Nothing)] + mkBsf nm = + [(nm <> "(a,b)",App [Name Nothing nm] [Iden [Name Nothing "a"],Iden [Name Nothing "b"]]) + ,(nm <> "(a,b) filter (where something > 5)" + ,AggregateApp [Name Nothing nm] + SQDefault + [Iden [Name Nothing "a"],Iden [Name Nothing "b"]] [] fil)] + +{- +== 10.10 + +Function +Specify a sort order. + + ::= + [ { }... ] + + ::= + [ ] [ ] + + ::= + + ::= ASC | DESC + + ::= + | NULLS LAST + NULLS FIRST +-} + +sortSpecificationList :: TestItem +sortSpecificationList = Group "sort specification list" + $ map (uncurry (testQueryExpr ansi2011)) + [("select * from t order by a" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + DirDefault NullsOrderDefault]}) + ,("select * from t order by a,b" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + DirDefault NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) + DirDefault NullsOrderDefault]}) + ,("select * from t order by a asc,b" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + Asc NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) + DirDefault NullsOrderDefault]}) + ,("select * from t order by a desc,b" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"]) + Desc NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) + DirDefault NullsOrderDefault]}) + ,("select * from t order by a collate x desc,b" + ,toQueryExpr $ ms {msOrderBy = [SortSpec + (Collate (Iden [Name Nothing "a"]) [Name Nothing "x"]) + Desc NullsOrderDefault + ,SortSpec (Iden [Name Nothing "b"]) + DirDefault NullsOrderDefault]}) + ,("select * from t order by 1,2" + ,toQueryExpr $ ms {msOrderBy = [SortSpec (NumLit "1") + DirDefault NullsOrderDefault + ,SortSpec (NumLit "2") + DirDefault NullsOrderDefault]}) + ] + where + ms = makeSelect + {msSelectList = [(Star,Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]]} + + +q :: HasCallStack => Text -> QueryExpr -> TestItem +q src ast = testQueryExpr ansi2011 src ast + +e :: HasCallStack => Text -> ScalarExpr -> TestItem +e src ast = testScalarExpr ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs b/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs @@ -0,0 +1,2239 @@ + +{- +Section 11 in Foundation + +This module covers the tests for parsing schema and DDL statements. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.SQL2011Schema (sql2011SchemaTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +sql2011SchemaTests :: TestItem +sql2011SchemaTests = Group "sql 2011 schema tests" + [ + + +{- +11.1 + + ::= + CREATE SCHEMA + [ ] + [ ... ] +-} + + s "create schema my_schema" + $ CreateSchema [Name Nothing "my_schema"] + +{- +todo: schema name can have . +schema name can be quoted iden or unicode quoted iden +add schema element support: + create a list of schema elements + then do pairwise combinations in schema element list to test + + + ::= + + | + | + | + + ::= + + | AUTHORIZATION + | AUTHORIZATION + + ::= + + + ::= + DEFAULT CHARACTER SET + + ::= + + + ::= +
+ | + | + | + | + | + | + | + | + | + | + | + | + | + | + | + + +11.2 + + ::= + DROP SCHEMA + + ::= + CASCADE + | RESTRICT +-} + + + ,s "drop schema my_schema" + $ DropSchema [Name Nothing "my_schema"] DefaultDropBehaviour + ,s "drop schema my_schema cascade" + $ DropSchema [Name Nothing "my_schema"] Cascade + ,s "drop schema my_schema restrict" + $ DropSchema [Name Nothing "my_schema"] Restrict + +{- +11.3
+ + +
::= + CREATE [
] TABLE
+ [ WITH ] + [ ON COMMIT
ROWS ] +-} + + ,s "create table t (a int, b int);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) []] + False + + +{- +
::= +
+ | + | + +
::= + TEMPORARY + + ::= + GLOBAL + | LOCAL + + ::= + SYSTEM VERSIONING + +defintely skip + +
::= + PRESERVE + | DELETE + +defintely skip + +
::= +
[ {
}... ] + +
::= + + |
+ |
+ | + + ::= + OF [ ] + [ ] + +defintely skip + + ::= + + [ { }... ] + +defintely skip + + ::= + + |
+ | + +defintely skip + + ::= + REF IS [ ] + +defintely skip + + ::= + SYSTEM GENERATED + | USER GENERATED + | DERIVED + +defintely skip + + ::= + + +defintely skip + + ::= + WITH OPTIONS + +defintely skip + + ::= + [ ] [ ] [ ... ] + +defintely skip + + ::= + UNDER + +defintely skip + + ::= + + +defintely skip + + ::= +
+ +defintely skip + + ::= + LIKE
[ ] + + ::= + ... + + ::= + + | + | + + ::= + INCLUDING IDENTITY + | EXCLUDING IDENTITY + + ::= + INCLUDING DEFAULTS + | EXCLUDING DEFAULTS + + ::= + INCLUDING GENERATED + | EXCLUDING GENERATED + + ::= + [ ] AS
+ + + ::= + WITH NO DATA + | WITH DATA + +
::= + + + +defintely skip + + ::= + + | + +defintely skip + + ::= + PERIOD FOR SYSTEM_TIME + +defintely skip + + ::= + PERIOD FOR + +defintely skip + + ::= + + +defintely skip + + ::= + + +defintely skip + + ::= + + +defintely skip + + +11.4 + + ::= + [ ] + [ | | + | + | ] + [ ... ] + [ ] + + ::= + + | + + ::= + AS ROW START + +defintely skip + + ::= + AS ROW END + +defintely skip + + ::= + GENERATED ALWAYS + +defintely skip + + ::= + [ ] [ ] + + ::= + NOT NULL + | + | + | + + +can have more than one +whitespace separated + +one constratint: +optional name: constraint [Name] +not null | unique | references | check +todo: constraint characteristics +-} + + + ,s + "create table t (a int not null);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing ColNotNullConstraint]] + False + + ,s + "create table t (a int constraint a_not_null not null);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef (Just [Name Nothing "a_not_null"]) ColNotNullConstraint]] + False + + ,s + "create table t (a int unique);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing ColUniqueConstraint]] + False + + ,s + "create table t (a int primary key);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing (ColPrimaryKeyConstraint False)]] + False + + ,testStatement ansi2011{ diAutoincrement = True } + "create table t (a int primary key autoincrement);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing (ColPrimaryKeyConstraint True)]] + False + +{- +references t(a,b) + [ Full |partial| simepl] + [perm: on update [cascade | set null | set default | restrict | no action] + on delete "" +-} + + ,s + "create table t (a int references u);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + DefaultReferentialAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u(a));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] (Just $ Name Nothing "a") DefaultReferenceMatch + DefaultReferentialAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u match full);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing MatchFull + DefaultReferentialAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u match partial);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing MatchPartial + DefaultReferentialAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u match simple);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing MatchSimple + DefaultReferentialAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u on update cascade );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefCascade DefaultReferentialAction]] + False + + ,s + "create table t (a int references u on update set null );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefSetNull DefaultReferentialAction]] + False + + ,s + "create table t (a int references u on update set default );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefSetDefault DefaultReferentialAction]] + False + + ,s + "create table t (a int references u on update no action );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefNoAction DefaultReferentialAction]] + False + + ,s + "create table t (a int references u on delete cascade );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + DefaultReferentialAction RefCascade]] + False + + + ,s + "create table t (a int references u on update cascade on delete restrict );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefCascade RefRestrict]] + False + + ,s + "create table t (a int references u on delete restrict on update cascade );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing $ ColReferencesConstraint + [Name Nothing "u"] Nothing DefaultReferenceMatch + RefCascade RefRestrict]] + False + +{- +TODO: try combinations and permutations of column constraints and +options +-} + + + ,s + "create table t (a int check (a>5));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + (ColCheckConstraint $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))]] + False + + + + + +{- + ::= + GENERATED { ALWAYS | BY DEFAULT } AS IDENTITY + [ ] +-} + + ,s "create table t (a int generated always as identity);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ IdentityColumnSpec GeneratedAlways []]] + False + + ,s "create table t (a int generated by default as identity);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ IdentityColumnSpec GeneratedByDefault []]] + False + + + ,s + "create table t (a int generated always as identity\n\ + \ ( start with 5 increment by 5 maxvalue 500 minvalue 5 cycle ));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ IdentityColumnSpec GeneratedAlways + [SGOStartWith 5 + ,SGOIncrementBy 5 + ,SGOMaxValue 500 + ,SGOMinValue 5 + ,SGOCycle]]] + False + + ,s + "create table t (a int generated always as identity\n\ + \ ( start with -4 no maxvalue no minvalue no cycle ));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ IdentityColumnSpec GeneratedAlways + [SGOStartWith (-4) + ,SGONoMaxValue + ,SGONoMinValue + ,SGONoCycle]]] + False + +{- +I think is supposed to just +whitespace separated. In db2 it seems to be csv, but the grammar here +just seems to be whitespace separated, and it is just whitespace +separated in oracle... Not completely sure though. Usually db2 is +closer than oracle? + +generated always (valueexpr) + + ::= + AS + + ::= + GENERATED ALWAYS + + ::= + +-} + + ,s + "create table t (a int, \n\ + \ a2 int generated always as (a * 2));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "a2") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ GenerationClause (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (NumLit "2"))]] + False + + + +{- +11.5 + + ::= + DEFAULT + + ::= + + | + | USER + | CURRENT_USER + | CURRENT_ROLE + | SESSION_USER + | SYSTEM_USER + | CURRENT_CATALOG + | CURRENT_SCHEMA + | CURRENT_PATH + | +-} + + + ,s "create table t (a int default 0);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ DefaultClause $ NumLit "0"]] + False + + + +{- +11.6
+ +
::= + [ ]
+ [ ] + +
::= + + | + | + +11.7 + + ::= + [ ] + | UNIQUE ( VALUE ) + + ::= + UNIQUE + | PRIMARY KEY + + ::= + +-} + + ,s + "create table t (a int, unique (a));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ TableUniqueConstraint [Name Nothing "a"] + ] + False + + ,s + "create table t (a int, constraint a_unique unique (a));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef (Just [Name Nothing "a_unique"]) $ + TableUniqueConstraint [Name Nothing "a"] + ] + False + +-- todo: test permutations of column defs and table constraints + + ,s + "create table t (a int, b int, unique (a,b));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ + TableUniqueConstraint [Name Nothing "a", Name Nothing "b"] + ] + False + + ,s + "create table t (a int, b int, primary key (a,b));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ + TablePrimaryKeyConstraint [Name Nothing "a", Name Nothing "b"] + ] + False + + +{- + ::= + WITHOUT OVERLAPS + +defintely skip + + +11.8 + + ::= + FOREIGN KEY + [ ] + +-} + + + ,s + "create table t (a int, b int,\n\ + \ foreign key (a,b) references u(c,d) match full on update cascade on delete restrict );" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ + TableReferencesConstraint + [Name Nothing "a", Name Nothing "b"] + [Name Nothing "u"] + (Just [Name Nothing "c", Name Nothing "d"]) + MatchFull RefCascade RefRestrict + ] + False + + ,s + "create table t (a int,\n\ + \ constraint tfku1 foreign key (a) references u);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef (Just [Name Nothing "tfku1"]) $ + TableReferencesConstraint + [Name Nothing "a"] + [Name Nothing "u"] + Nothing DefaultReferenceMatch + DefaultReferentialAction DefaultReferentialAction + ] + False + + ,testStatement ansi2011{ diNonCommaSeparatedConstraints = True } + "create table t (a int, b int,\n\ + \ foreign key (a) references u(c)\n\ + \ foreign key (b) references v(d));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ + TableReferencesConstraint + [Name Nothing "a"] + [Name Nothing "u"] + (Just [Name Nothing "c"]) + DefaultReferenceMatch + DefaultReferentialAction DefaultReferentialAction + ,TableConstraintDef Nothing $ + TableReferencesConstraint + [Name Nothing "b"] + [Name Nothing "v"] + (Just [Name Nothing "d"]) + DefaultReferenceMatch + DefaultReferentialAction DefaultReferentialAction + ] + False + ,testStatement ansi2011{ diWithoutRowidTables = True } + "create table t (a int) without rowid;" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) []] + True + ,testStatement ansi2011{ diOptionalColumnTypes = True } + "create table t (a,b);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") Nothing [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") Nothing [] + ] + False + ,testStatement ansi2011{ diDefaultClausesAsConstraints = True } + "create table t (a int default 1 default 2);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing + $ ColDefaultClause + $ DefaultClause $ NumLit "1" + ,ColConstraintDef Nothing + $ ColDefaultClause + $ DefaultClause $ NumLit "2"]] + False + ,testStatement ansi2011{ diDefaultClausesAsConstraints = True } + "create table t (a int not null default 2);" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) + [ColConstraintDef Nothing ColNotNullConstraint + ,ColConstraintDef Nothing + $ ColDefaultClause + $ DefaultClause $ NumLit "2"]] + False + + +{- + ::= + REFERENCES + [ MATCH ] [ ] + + ::= + FULL + | PARTIAL + | SIMPLE + + ::= + + + ::= + PERIOD + +defintely skip + + ::= +
[ + [ ] ] + + ::= + + + ::= + PERIOD + +defintely skip + + ::= + [ ] + | [ ] + + ::= + ON UPDATE + + ::= + ON DELETE + + ::= + CASCADE + | SET NULL + | SET DEFAULT + | RESTRICT + | NO ACTION + + + +11.9 + + ::= + CHECK +-} + + ,s + "create table t (a int, b int, \n\ + \ check (a > b));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef Nothing $ + TableCheckConstraint + (BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"])) + ] + False + + + ,s + "create table t (a int, b int, \n\ + \ constraint agtb check (a > b));" + $ CreateTable [Name Nothing "t"] + [TableColumnDef $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + ,TableColumnDef $ ColumnDef (Name Nothing "b") (Just (TypeName [Name Nothing "int"])) [] + ,TableConstraintDef (Just [Name Nothing "agtb"]) $ + TableCheckConstraint + (BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"])) + ] + False + + +{- +TODO: lots more combos of table elements +and types and the other bits in a column def + +11.10 + + ::= + ALTER TABLE
+ + ::= + + | + | + | + | + | + | + | + | + | + +11.11 + + ::= + ADD [ COLUMN ] + +alter table t add column a int +alter table t add a int +alter table t add a int unique not null check (a>0) +-} + + ,s + "alter table t add column a int" + $ AlterTable [Name Nothing "t"] $ AddColumnDef + $ ColumnDef (Name Nothing "a") (Just (TypeName [Name Nothing "int"])) [] + +{- +todo: more add column + +11.12 + + ::= + ALTER [ COLUMN ] + + ::= + + | + | + | + | + | + | + | + | + | + + +11.13 + + ::= + SET +-} + + + ,s + "alter table t alter column c set default 0" + $ AlterTable [Name Nothing "t"] $ AlterColumnSetDefault (Name Nothing "c") + $ NumLit "0" + +{- +11.14 + + ::= + DROP DEFAULT +-} + + ,s + "alter table t alter column c drop default" + $ AlterTable [Name Nothing "t"] $ AlterColumnDropDefault (Name Nothing "c") + + +{- +11.15 + + ::= + SET NOT NULL +-} + + ,s + "alter table t alter column c set not null" + $ AlterTable [Name Nothing "t"] $ AlterColumnSetNotNull (Name Nothing "c") + +{- +11.16 + + ::= + DROP NOT NULL +-} + + ,s + "alter table t alter column c drop not null" + $ AlterTable [Name Nothing "t"] $ AlterColumnDropNotNull (Name Nothing "c") + +{- +11.17 + + ::= + ADD + +11.18 + + ::= + DROP SCOPE + +11.19 + + ::= + SET DATA TYPE +-} + + ,s + "alter table t alter column c set data type int;" + $ AlterTable [Name Nothing "t"] $ + AlterColumnSetDataType (Name Nothing "c") (TypeName [Name Nothing "int"]) + + + +{- +11.20 + + ::= + [ ... ] + | ... + + ::= + SET GENERATED { ALWAYS | BY DEFAULT } + +so you have to write set generated for alter identity? +and you have to use always or by default + +makes no sense: if you just want to restart you have to explicitly set +the always or by default? you can't just leave it unchanged? + +you don't write as identity like with create table, this is wrong: + +alter table t alter column c set generated always as identity + +but these are ok? + +alter table t alter column c set generated always + +alter table t alter column c set generated by default + + ::= + + | SET + +alter table t alter column c set generated always restart +alter table t alter column c set generated always restart with 4 + +you can just write restart + +but to write others you have to repeat set? each time? + +alter table t alter column c set generated always set increment by 5 set minvalue 0 set maxvalue 5 set cycle restart with 5 +(no set before the restart + +in create table, it looks like this: + +c int generated generated always as identity (increment by 5 minvalue 0 maxvalue 5 cycle restart with 5) + +why gratuituous differences??? + +is there no way to do this: + +alter table t alter column c set generated as (a * 3) +?? + +UPDATE: alter sequence uses same syntax as create sequence, which is +the same sytnax as identity in create table, so overrule the sql +standard and use the same syntax in alter identity. + +PLAN: TODO + +don't implement alter table alter column generated now + +review the syntax for generated in db2, oracle, sql server, postgres, others? + +observe which features are supported, and the consistency between +create table and alter table + +try to find some people to ask if the standard really is this much of +a mess or I have misunderstood the grammer, or maybe there is a good +reason for the inconsistencies? + + +11.21 + + ::= + DROP IDENTITY + +alter table t alter column c drop identity + +included in the generated plan above + +11.22 + + ::= + DROP EXPRESSION + +alter table t alter column c drop expression + +included in the generated plan above + + +11.23 + + ::= + DROP [ COLUMN ] +-} + + ,s + "alter table t drop column c" + $ AlterTable [Name Nothing "t"] $ + DropColumn (Name Nothing "c") DefaultDropBehaviour + + ,s + "alter table t drop c cascade" + $ AlterTable [Name Nothing "t"] $ + DropColumn (Name Nothing "c") Cascade + + ,s + "alter table t drop c restrict" + $ AlterTable [Name Nothing "t"] $ + DropColumn (Name Nothing "c") Restrict + + + +{- +11.24 + + ::= + ADD
+-} + + ,s + "alter table t add constraint c unique (a,b)" + $ AlterTable [Name Nothing "t"] $ + AddTableConstraintDef (Just [Name Nothing "c"]) + $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"] + + ,s + "alter table t add unique (a,b)" + $ AlterTable [Name Nothing "t"] $ + AddTableConstraintDef Nothing + $ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"] + + +{- +11.25 + ::= + ALTER CONSTRAINT + +todo + +11.26 + + ::= + DROP CONSTRAINT +-} + + ,s + "alter table t drop constraint c" + $ AlterTable [Name Nothing "t"] $ + DropTableConstraintDef [Name Nothing "c"] DefaultDropBehaviour + + ,s + "alter table t drop constraint c restrict" + $ AlterTable [Name Nothing "t"] $ + DropTableConstraintDef [Name Nothing "c"] Restrict + +{- +11.27 + + ::= + ADD
[ ] + +defintely skip + + ::= + ADD [ COLUMN ] ADD [ COLUMN ] + +defintely skip + + ::= + + +defintely skip + + ::= + + +defintely skip + +11.28 + + ::= + DROP + +defintely skip + +11.29 + + ::= + ADD + +defintely skip + +11.30 + + ::= + DROP SYSTEM VERSIONING + +defintely skip + +11.31 + + ::= + DROP TABLE
+-} + + ,s + "drop table t" + $ DropTable [Name Nothing "t"] DefaultDropBehaviour + + ,s + "drop table t restrict" + $ DropTable [Name Nothing "t"] Restrict + + +{- +11.32 + + ::= + CREATE [ RECURSIVE ] VIEW
+ AS [ WITH [ ] CHECK OPTION ] + + ::= + + | + + ::= + [ ] + + ::= + OF [ ] + [ ] + + ::= + UNDER
+ + ::= + [ { }... ] + + ::= + + | + + ::= + WITH OPTIONS + + ::= + CASCADED + | LOCAL + + ::= + +-} + + ,s + "create view v as select * from t" + $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) Nothing + + + ,s + "create recursive view v as select * from t" + $ CreateView True [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) Nothing + + ,s + "create view v(a,b) as select * from t" + $ CreateView False [Name Nothing "v"] (Just [Name Nothing "a", Name Nothing "b"]) + (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) Nothing + + + ,s + "create view v as select * from t with check option" + $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) (Just DefaultCheckOption) + + ,s + "create view v as select * from t with cascaded check option" + $ CreateView False [Name Nothing "v"] Nothing (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) (Just CascadedCheckOption) + + ,s + "create view v as select * from t with local check option" + $ CreateView False [Name Nothing "v"] Nothing + (toQueryExpr $ makeSelect + {msSelectList = [(Star, Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + }) (Just LocalCheckOption) + + +{- +11.33 + + ::= + DROP VIEW
+-} + + + ,s + "drop view v" + $ DropView [Name Nothing "v"] DefaultDropBehaviour + + ,s + "drop view v cascade" + $ DropView [Name Nothing "v"] Cascade + + +{- +11.34 + + ::= + CREATE DOMAIN [ AS ] + [ ] + [ ... ] + [ ] + + ::= + [ ] [ + ] +-} + + ,s + "create domain my_int int" + $ CreateDomain [Name Nothing "my_int"] + (TypeName [Name Nothing "int"]) + Nothing [] + + ,s + "create domain my_int as int" + $ CreateDomain [Name Nothing "my_int"] + (TypeName [Name Nothing "int"]) + Nothing [] + + ,s + "create domain my_int int default 0" + $ CreateDomain [Name Nothing "my_int"] + (TypeName [Name Nothing "int"]) + (Just (NumLit "0")) [] + + ,s + "create domain my_int int check (value > 5)" + $ CreateDomain [Name Nothing "my_int"] + (TypeName [Name Nothing "int"]) + Nothing [(Nothing + ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))] + + ,s + "create domain my_int int constraint gt5 check (value > 5)" + $ CreateDomain [Name Nothing "my_int"] + (TypeName [Name Nothing "int"]) + Nothing [(Just [Name Nothing "gt5"] + ,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))] + + + +{- +11.35 + + ::= + ALTER DOMAIN + + ::= + + | + | + | + +11.36 + + ::= + SET +-} + + ,s + "alter domain my_int set default 0" + $ AlterDomain [Name Nothing "my_int"] + $ ADSetDefault $ NumLit "0" + + +{- +11.37 + + ::= + DROP DEFAULT +-} + + ,s + "alter domain my_int drop default" + $ AlterDomain [Name Nothing "my_int"] + $ ADDropDefault + + +{- +11.38 + + ::= + ADD +-} + + ,s + "alter domain my_int add check (value > 6)" + $ AlterDomain [Name Nothing "my_int"] + $ ADAddConstraint Nothing + $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6") + + ,s + "alter domain my_int add constraint gt6 check (value > 6)" + $ AlterDomain [Name Nothing "my_int"] + $ ADAddConstraint (Just [Name Nothing "gt6"]) + $ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6") + + +{- +11.39 + + ::= + DROP CONSTRAINT +-} + + ,s + "alter domain my_int drop constraint gt6" + $ AlterDomain [Name Nothing "my_int"] + $ ADDropConstraint [Name Nothing "gt6"] + +{- +11.40 + + ::= + DROP DOMAIN +-} + + ,s + "drop domain my_int" + $ DropDomain [Name Nothing "my_int"] DefaultDropBehaviour + + ,s + "drop domain my_int cascade" + $ DropDomain [Name Nothing "my_int"] Cascade + + + +{- +11.41 + + ::= + CREATE CHARACTER SET [ AS ] + [ ] + + ::= + GET + +11.42 + + ::= + DROP CHARACTER SET + +11.43 + + ::= + CREATE COLLATION FOR + FROM [ ] + + ::= + + + ::= + NO PAD + | PAD SPACE + +11.44 + + ::= + DROP COLLATION + +11.45 + + ::= + CREATE TRANSLATION FOR + TO FROM + + ::= + + + ::= + + + ::= + + | + + ::= + + + ::= + + +11.46 + + ::= + DROP TRANSLATION + +11.47 + + ::= + CREATE ASSERTION + CHECK + [ ] +-} + + ,s + "create assertion t1_not_empty CHECK ((select count(*) from t1) > 0);" + $ CreateAssertion [Name Nothing "t1_not_empty"] + $ BinOp (SubQueryExpr SqSq $ + toQueryExpr $ makeSelect + {msSelectList = [(App [Name Nothing "count"] [Star],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t1"]] + }) + [Name Nothing ">"] (NumLit "0") + +{- +11.48 + + ::= + DROP ASSERTION [ ] +-} + + ,s + "drop assertion t1_not_empty;" + $ DropAssertion [Name Nothing "t1_not_empty"] DefaultDropBehaviour + + ,s + "drop assertion t1_not_empty cascade;" + $ DropAssertion [Name Nothing "t1_not_empty"] Cascade + + +{- +11.49 + + ::= + CREATE TRIGGER + ON
[ REFERENCING ] + + + ::= + BEFORE + | AFTER + | INSTEAD OF + + ::= + INSERT + | DELETE + | UPDATE [ OF ] + + ::= + + + ::= + [ FOR EACH { ROW | STATEMENT } ] + [ ] + + + ::= + WHEN + + ::= + + | BEGIN ATOMIC { }... END + + ::= + ... + + ::= + OLD [ ROW ] [ AS ] + | NEW [ ROW ] [ AS ] + | OLD TABLE [ AS ] + | NEW TABLE [ AS ] + + ::= + + + ::= + + + ::= + + + ::= + + + ::= + + +11.50 + + ::= + DROP TRIGGER + +11.51 + + ::= + CREATE TYPE + + ::= + + [ ] + [ AS ] + [ ] + [ ] + + ::= + [ ... ] + + ::= + + | + | + | + | + | + | + + ::= + UNDER + + ::= + + + ::= + + | + | + + ::= + [ { }... ] + + ::= + + + ::= + INSTANTIABLE + | NOT INSTANTIABLE + + ::= + FINAL + | NOT FINAL + + ::= + + | + | + + ::= + REF USING + + ::= + REF FROM + + ::= + REF IS SYSTEM GENERATED + + ::= + CAST SOURCE AS REF WITH + + ::= + + + ::= + CAST REF AS SOURCE WITH + + ::= + + + ::= + [ { }... ] + + ::= + CAST SOURCE AS DISTINCT + WITH + + ::= + + + ::= + CAST DISTINCT AS SOURCE + WITH + + ::= + + + ::= + [ { }... ] + + ::= + + | + + ::= + [ SELF AS RESULT ] [ SELF AS LOCATOR ] + [ ] + + ::= + OVERRIDING + 1 ::= + [ INSTANCE | STATIC | CONSTRUCTOR ] + METHOD + + [ SPECIFIC ] + + ::= + [ ] + + ::= + ... + + ::= + + | + | + | + | + +11.52 + + ::= + + [ ] + [ ] + + ::= + + +11.53 + + ::= + ALTER TYPE + + ::= + + | + | + | + | + +11.54 + + ::= + ADD ATTRIBUTE + +11.55 + + ::= + DROP ATTRIBUTE RESTRICT + +11.56 + + ::= + ADD + +11.57 + + ::= + ADD + +11.58 + + ::= + DROP RESTRICT + + ::= + [ INSTANCE | STATIC | CONSTRUCTOR ] + METHOD + +11.59 + + ::= + DROP TYPE + +11.60 + + ::= + + + ::= + + | + + ::= + CREATE + + ::= + CREATE + + ::= + PROCEDURE + + + + ::= + { | } + + ::= + [ + [ { }... ] ] + + ::= + [ ] + [ ] + [ RESULT ] + [ DEFAULT ] + + ::= + + | + + ::= + IN + | OUT + | INOUT + + ::= + [ ] + + ::= + AS LOCATOR + + ::= + FUNCTION + + + [ ] + + ::= + SPECIFIC METHOD + | [ INSTANCE | STATIC | CONSTRUCTOR ] + METHOD + [ ] + FOR + + ::= + [ ... ] + + ::= + + | + | SPECIFIC + | + | + | + | + | + + ::= + NEW SAVEPOINT LEVEL + | OLD SAVEPOINT LEVEL + + ::= + DYNAMIC RESULT SETS + + ::= + PARAMETER STYLE + + ::= + STATIC DISPATCH + + ::= + RETURNS + + ::= + [ ] + | + + ::= + TABLE
+ +
::= +
+ [ {
}... ] + +
::= + + + ::= + CAST FROM + + ::= + [ ] + + ::= + [ ] + + ::= + + | + + ::= + [ ] + + ::= + SQL SECURITY INVOKER + | SQL SECURITY DEFINER + + ::= + + + ::= + EXTERNAL [ NAME ] + [ ] + [ ] + [ ] + + ::= + EXTERNAL SECURITY DEFINER + | EXTERNAL SECURITY INVOKER + | EXTERNAL SECURITY IMPLEMENTATION DEFINED + + ::= + SQL + | GENERAL + + ::= + DETERMINISTIC + | NOT DETERMINISTIC + + ::= + NO SQL + | CONTAINS SQL + | READS SQL DATA + | MODIFIES SQL DATA + + ::= + RETURNS NULL ON NULL INPUT + | CALLED ON NULL INPUT + + ::= + + + ::= + TRANSFORM GROUP { | } + + ::= + + + ::= + [ { }... ] + + ::= + FOR TYPE + +11.61 + + ::= + ALTER + + + ::= + ... + + ::= + + | + | + | + | + | NAME + + ::= + RESTRICT + +11.62 + + ::= + DROP + +11.63 + + ::= + CREATE CAST AS + WITH + [ AS ASSIGNMENT ] + + ::= + + + ::= + + + ::= + + +11.64 + + ::= + DROP CAST AS + + +11.65 + + ::= + CREATE ORDERING FOR + + ::= + + | + + ::= + EQUALS ONLY BY + + ::= + ORDER FULL BY + + ::= + + | + | + + ::= + RELATIVE WITH + + ::= + MAP WITH + + ::= + STATE [ ] + + ::= + + + ::= + + +11.66 + + ::= + DROP ORDERING FOR + +11.67 + + ::= + CREATE { TRANSFORM | TRANSFORMS } FOR + ... + + ::= + + + ::= + + + ::= + [ ] + + ::= + + | + + ::= + TO SQL WITH + + ::= + FROM SQL WITH + + ::= + + + ::= + + +11.68 + + ::= + ALTER { TRANSFORM | TRANSFORMS } + FOR ... + + ::= + + + ::= + [ { }... ] + + ::= + + | + +11.69 + + ::= + ADD + +11.70 + + ::= + DROP + [ ] + + ::= + TO SQL + | FROM SQL + +11.71 + + ::= + DROP { TRANSFORM | TRANSFORMS } + FOR + + ::= + ALL + | + + ::= + + +11.72 + + ::= + CREATE SEQUENCE [ ] + + ::= + ... + + ::= + + | + + ::= + ... + + ::= + + | + + ::= + + | + | + | + + ::= + AS + + ::= + START WITH + + ::= + + + ::= + INCREMENT BY + + ::= + + + ::= + MAXVALUE + | NO MAXVALUE + + ::= + + + ::= + MINVALUE + | NO MINVALUE + + ::= + + + ::= + CYCLE + | NO CYCLE +-} + + ,s + "create sequence seq" + $ CreateSequence [Name Nothing "seq"] [] + + ,s + "create sequence seq as bigint" + $ CreateSequence [Name Nothing "seq"] + [SGODataType $ TypeName [Name Nothing "bigint"]] + + ,s + "create sequence seq as bigint start with 5" + $ CreateSequence [Name Nothing "seq"] + [SGOStartWith 5 + ,SGODataType $ TypeName [Name Nothing "bigint"] + ] + + +{- +11.73 + + ::= + ALTER SEQUENCE + + ::= + ... + + ::= + + | + + ::= + RESTART [ WITH ] + + ::= + +-} + + ,s + "alter sequence seq restart" + $ AlterSequence [Name Nothing "seq"] + [SGORestart Nothing] + + ,s + "alter sequence seq restart with 5" + $ AlterSequence [Name Nothing "seq"] + [SGORestart $ Just 5] + + ,s + "alter sequence seq restart with 5 increment by 5" + $ AlterSequence [Name Nothing "seq"] + [SGORestart $ Just 5 + ,SGOIncrementBy 5] + + +{- +11.74 + + ::= + DROP SEQUENCE +-} + + ,s + "drop sequence seq" + $ DropSequence [Name Nothing "seq"] DefaultDropBehaviour + + ,s + "drop sequence seq restrict" + $ DropSequence [Name Nothing "seq"] Restrict + + + ] + +s :: HasCallStack => Text -> Statement -> TestItem +s src ast = testStatement ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/ScalarExprs.hs b/tests/Language/SQL/SimpleSQL/ScalarExprs.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/ScalarExprs.hs @@ -0,0 +1,436 @@ + +-- Tests for parsing scalar expressions + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.ScalarExprs (scalarExprTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners + +import Data.Text (Text) + +scalarExprTests :: TestItem +scalarExprTests = Group "scalarExprTests" + [literals + ,identifiers + ,star + ,parameter + ,dots + ,app + ,caseexp + ,convertfun + ,operators + ,parens + ,subqueries + ,aggregates + ,windowFunctions + ,functionsWithReservedNames + ] + +t :: HasCallStack => Text -> ScalarExpr -> TestItem +t src ast = testScalarExpr ansi2011 src ast + +td :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem +td d src ast = testScalarExpr d src ast + + + +literals :: TestItem +literals = Group "literals" + [t "3" $ NumLit "3" + ,t "3." $ NumLit "3." + ,t "3.3" $ NumLit "3.3" + ,t ".3" $ NumLit ".3" + ,t "3.e3" $ NumLit "3.e3" + ,t "3.3e3" $ NumLit "3.3e3" + ,t ".3e3" $ NumLit ".3e3" + ,t "3e3" $ NumLit "3e3" + ,t "3e+3" $ NumLit "3e+3" + ,t "3e-3" $ NumLit "3e-3" + ,t "'string'" $ StringLit "'" "'" "string" + ,t "'string with a '' quote'" $ StringLit "'" "'" "string with a '' quote" + ,t "'1'" $ StringLit "'" "'" "1" + ,t "interval '3' day" + $ IntervalLit Nothing "3" (Itf "day" Nothing) Nothing + ,t "interval '3' day (3)" + $ IntervalLit Nothing "3" (Itf "day" $ Just (3,Nothing)) Nothing + ,t "interval '3 weeks'" $ TypedLit (TypeName [Name Nothing "interval"]) "3 weeks" + ] + +identifiers :: TestItem +identifiers = Group "identifiers" + [t "iden1" $ Iden [Name Nothing "iden1"] + --,("t.a", Iden2 "t" "a") + ,t "\"quoted identifier\"" $ Iden [Name (Just ("\"","\"")) "quoted identifier"] + ,t "\"from\"" $ Iden [Name (Just ("\"","\"")) "from"] + ] + +star :: TestItem +star = Group "star" + [t "count(*)" $ App [Name Nothing "count"] [Star] + ,t "ROW(t.*,42)" $ App [Name Nothing "ROW"] [QStar [Name Nothing "t"], NumLit "42"] + ] + +parameter :: TestItem +parameter = Group "parameter" + [td ansi2011 "?" Parameter + ,td postgres "$13" $ PositionalArg 13] + +dots :: TestItem +dots = Group "dot" + [t "t.a" $ Iden [Name Nothing "t",Name Nothing "a"] + ,t "a.b.c" $ Iden [Name Nothing "a",Name Nothing "b",Name Nothing "c"] + ,t "ROW(t.*,42)" $ App [Name Nothing "ROW"] [QStar [Name Nothing "t"], NumLit "42"] + ] + +app :: TestItem +app = Group "app" + [t "f()" $ App [Name Nothing "f"] [] + ,t "f(a)" $ App [Name Nothing "f"] [Iden [Name Nothing "a"]] + ,t "f(a,b)" $ App [Name Nothing "f"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]] + ] + +caseexp :: TestItem +caseexp = Group "caseexp" + [t "case a when 1 then 2 end" + $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"] + ,NumLit "2")] Nothing + + ,t "case a when 1 then 2 when 3 then 4 end" + $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2") + ,([NumLit "3"], NumLit "4")] Nothing + + ,t "case a when 1 then 2 when 3 then 4 else 5 end" + $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"], NumLit "2") + ,([NumLit "3"], NumLit "4")] + (Just $ NumLit "5") + + ,t "case when a=1 then 2 when a=3 then 4 else 5 end" + $ Case Nothing [([BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "1")], NumLit "2") + ,([BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "3")], NumLit "4")] + (Just $ NumLit "5") + + ,t "case a when 1,2 then 10 when 3,4 then 20 end" + $ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1",NumLit "2"] + ,NumLit "10") + ,([NumLit "3",NumLit "4"] + ,NumLit "20")] + Nothing + ] + +convertfun :: TestItem +convertfun = Group "convert" + [td sqlserver "CONVERT(varchar, 25.65)" + $ Convert (TypeName [Name Nothing "varchar"]) (NumLit "25.65") Nothing + ,td sqlserver "CONVERT(datetime, '2017-08-25')" + $ Convert (TypeName [Name Nothing "datetime"]) (StringLit "'" "'" "2017-08-25") Nothing + ,td sqlserver "CONVERT(varchar, '2017-08-25', 101)" + $ Convert (TypeName [Name Nothing "varchar"]) (StringLit "'" "'" "2017-08-25") (Just 101) + ] + +operators :: TestItem +operators = Group "operators" + [binaryOperators + ,unaryOperators + ,casts + ,miscOps] + +binaryOperators :: TestItem +binaryOperators = Group "binaryOperators" + [t "a + b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"]) + -- sanity check fixities + -- todo: add more fixity checking + + ,t "a + b * c" + $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] + (BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"])) + + ,t "a * b + c" + $ BinOp (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (Iden [Name Nothing "b"])) + [Name Nothing "+"] (Iden [Name Nothing "c"]) + ] + +unaryOperators :: TestItem +unaryOperators = Group "unaryOperators" + [t "not a" $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"] + ,t "not not a" $ PrefixOp [Name Nothing "not"] $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"] + ,t "+a" $ PrefixOp [Name Nothing "+"] $ Iden [Name Nothing "a"] + ,t "-a" $ PrefixOp [Name Nothing "-"] $ Iden [Name Nothing "a"] + ] + + +casts :: TestItem +casts = Group "operators" + [t "cast('1' as int)" + $ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "int"] + + ,t "int '3'" + $ TypedLit (TypeName [Name Nothing "int"]) "3" + + ,t "cast('1' as double precision)" + $ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "double precision"] + + ,t "cast('1' as float(8))" + $ Cast (StringLit "'" "'" "1") $ PrecTypeName [Name Nothing "float"] 8 + + ,t "cast('1' as decimal(15,2))" + $ Cast (StringLit "'" "'" "1") $ PrecScaleTypeName [Name Nothing "decimal"] 15 2 + + ,t "double precision '3'" + $ TypedLit (TypeName [Name Nothing "double precision"]) "3" + ] + +subqueries :: TestItem +subqueries = Group "unaryOperators" + [t "exists (select a from t)" $ SubQueryExpr SqExists ms + ,t "(select a from t)" $ SubQueryExpr SqSq ms + + ,t "a in (select a from t)" + $ In True (Iden [Name Nothing "a"]) (InQueryExpr ms) + + ,t "a not in (select a from t)" + $ In False (Iden [Name Nothing "a"]) (InQueryExpr ms) + + ,t "a > all (select a from t)" + $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms + + ,t "a = some (select a from t)" + $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPSome ms + + ,t "a <= any (select a from t)" + $ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPAny ms + ] + where + ms = toQueryExpr $ makeSelect + {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = [TRSimple [Name Nothing "t"]] + } + +miscOps :: TestItem +miscOps = Group "unaryOperators" + [t "a in (1,2,3)" + $ In True (Iden [Name Nothing "a"]) $ InList $ map NumLit ["1","2","3"] + + ,t "a is null" $ PostfixOp [Name Nothing "is null"] (Iden [Name Nothing "a"]) + ,t "a is not null" $ PostfixOp [Name Nothing "is not null"] (Iden [Name Nothing "a"]) + ,t "a is true" $ PostfixOp [Name Nothing "is true"] (Iden [Name Nothing "a"]) + ,t "a is not true" $ PostfixOp [Name Nothing "is not true"] (Iden [Name Nothing "a"]) + ,t "a is false" $ PostfixOp [Name Nothing "is false"] (Iden [Name Nothing "a"]) + ,t "a is not false" $ PostfixOp [Name Nothing "is not false"] (Iden [Name Nothing "a"]) + ,t "a is unknown" $ PostfixOp [Name Nothing "is unknown"] (Iden [Name Nothing "a"]) + ,t "a is not unknown" $ PostfixOp [Name Nothing "is not unknown"] (Iden [Name Nothing "a"]) + ,t "a is distinct from b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is distinct from"] (Iden [Name Nothing "b"]) + + ,t "a is not distinct from b" + $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not distinct from"] (Iden [Name Nothing "b"]) + + ,t "a like b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "like"] (Iden [Name Nothing "b"]) + ,t "a not like b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "not like"] (Iden [Name Nothing "b"]) + ,t "a is similar to b"$ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is similar to"] (Iden [Name Nothing "b"]) + + ,t "a is not similar to b" + $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not similar to"] (Iden [Name Nothing "b"]) + + ,t "a overlaps b" $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "overlaps"] (Iden [Name Nothing "b"]) + +-- special operators + + ,t "a between b and c" $ SpecialOp [Name Nothing "between"] [Iden [Name Nothing "a"] + ,Iden [Name Nothing "b"] + ,Iden [Name Nothing "c"]] + + ,t "a not between b and c" $ SpecialOp [Name Nothing "not between"] [Iden [Name Nothing "a"] + ,Iden [Name Nothing "b"] + ,Iden [Name Nothing "c"]] + ,t "(1,2)" + $ SpecialOp [Name Nothing "rowctor"] [NumLit "1", NumLit "2"] + + +-- keyword special operators + + ,t "extract(day from t)" + $ SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "t"])] + + ,t "substring(x from 1 for 2)" + $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1") + ,("for", NumLit "2")] + + ,t "substring(x from 1)" + $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")] + + ,t "substring(x for 2)" + $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("for", NumLit "2")] + + ,t "substring(x from 1 for 2 collate C)" + $ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) + [("from", NumLit "1") + ,("for", Collate (NumLit "2") [Name Nothing "C"])] + +-- this doesn't work because of a overlap in the 'in' parser + + ,t "POSITION( string1 IN string2 )" + $ SpecialOpK [Name Nothing "position"] (Just $ Iden [Name Nothing "string1"]) [("in", Iden [Name Nothing "string2"])] + + ,t "CONVERT(char_value USING conversion_char_name)" + $ SpecialOpK [Name Nothing "convert"] (Just $ Iden [Name Nothing "char_value"]) + [("using", Iden [Name Nothing "conversion_char_name"])] + + ,t "TRANSLATE(char_value USING translation_name)" + $ SpecialOpK [Name Nothing "translate"] (Just $ Iden [Name Nothing "char_value"]) + [("using", Iden [Name Nothing "translation_name"])] + +{- +OVERLAY(string PLACING embedded_string FROM start +[FOR length]) +-} + + ,t "OVERLAY(string PLACING embedded_string FROM start)" + $ SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"]) + [("placing", Iden [Name Nothing "embedded_string"]) + ,("from", Iden [Name Nothing "start"])] + + ,t "OVERLAY(string PLACING embedded_string FROM start FOR length)" + $ SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"]) + [("placing", Iden [Name Nothing "embedded_string"]) + ,("from", Iden [Name Nothing "start"]) + ,("for", Iden [Name Nothing "length"])] + +{- +TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ] +target_string +[COLLATE collation_name] ) +-} + + + + ,t "trim(from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("both", StringLit "'" "'" " ") + ,("from", Iden [Name Nothing "target_string"])] + + ,t "trim(leading from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("leading", StringLit "'" "'" " ") + ,("from", Iden [Name Nothing "target_string"])] + + ,t "trim(trailing from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("trailing", StringLit "'" "'" " ") + ,("from", Iden [Name Nothing "target_string"])] + + ,t "trim(both from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("both", StringLit "'" "'" " ") + ,("from", Iden [Name Nothing "target_string"])] + + + ,t "trim(leading 'x' from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("leading", StringLit "'" "'" "x") + ,("from", Iden [Name Nothing "target_string"])] + + ,t "trim(trailing 'y' from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("trailing", StringLit "'" "'" "y") + ,("from", Iden [Name Nothing "target_string"])] + + ,t "trim(both 'z' from target_string collate C)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("both", StringLit "'" "'" "z") + ,("from", Collate (Iden [Name Nothing "target_string"]) [Name Nothing "C"])] + + ,t "trim(leading from target_string)" + $ SpecialOpK [Name Nothing "trim"] Nothing + [("leading", StringLit "'" "'" " ") + ,("from", Iden [Name Nothing "target_string"])] + + ] + +aggregates :: TestItem +aggregates = Group "aggregates" + [t "count(*)" $ App [Name Nothing "count"] [Star] + + ,t "sum(a order by a)" + $ AggregateApp [Name Nothing "sum"] SQDefault [Iden [Name Nothing "a"]] + [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] Nothing + + ,t "sum(all a)" + $ AggregateApp [Name Nothing "sum"] All [Iden [Name Nothing "a"]] [] Nothing + + ,t "count(distinct a)" + $ AggregateApp [Name Nothing "count"] Distinct [Iden [Name Nothing "a"]] [] Nothing + ] + +windowFunctions :: TestItem +windowFunctions = Group "windowFunctions" + [t "max(a) over ()" $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [] [] Nothing + ,t "count(*) over ()" $ WindowApp [Name Nothing "count"] [Star] [] [] Nothing + + ,t "max(a) over (partition by b)" + $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] [] Nothing + + ,t "max(a) over (partition by b,c)" + $ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"],Iden [Name Nothing "c"]] [] Nothing + + ,t "sum(a) over (order by b)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [] + [SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] Nothing + + ,t "sum(a) over (order by b desc,c)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [] + [SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault + ,SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing + + ,t "sum(a) over (partition by b order by c)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing + + ,t "sum(a) over (partition by b order by c range unbounded preceding)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameFrom FrameRange UnboundedPreceding + + ,t "sum(a) over (partition by b order by c range 5 preceding)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5") + + ,t "sum(a) over (partition by b order by c range current row)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameFrom FrameRange Current + + ,t "sum(a) over (partition by b order by c rows 5 following)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameFrom FrameRows $ Following (NumLit "5") + + ,t "sum(a) over (partition by b order by c range unbounded following)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameFrom FrameRange UnboundedFollowing + + ,t "sum(a) over (partition by b order by c \n\ + \range between 5 preceding and 5 following)" + $ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] + [SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] + $ Just $ FrameBetween FrameRange + (Preceding (NumLit "5")) + (Following (NumLit "5")) + + ] + +parens :: TestItem +parens = Group "parens" + [t "(a)" $ Parens (Iden [Name Nothing "a"]) + ,t "(a + b)" $ Parens (BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"])) + ] + +functionsWithReservedNames :: TestItem +functionsWithReservedNames = Group "functionsWithReservedNames" $ map f + ["abs" + ,"char_length" + ] + where + f fn = t (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]] diff --git a/tests/Language/SQL/SimpleSQL/TableRefs.hs b/tests/Language/SQL/SimpleSQL/TableRefs.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/TableRefs.hs @@ -0,0 +1,111 @@ + +{- +These are the tests for parsing focusing on the from part of query +expression +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.TableRefs (tableRefTests) where + +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestRunners +import Data.Text (Text) + +tableRefTests :: TestItem +tableRefTests = Group "tableRefTests" + [q "select a from t" + $ ms [TRSimple [Name Nothing "t"]] + + ,q "select a from f(a)" + $ ms [TRFunction [Name Nothing "f"] [Iden [Name Nothing "a"]]] + + ,q "select a from t,u" + $ ms [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]] + + ,q "select a from s.t" + $ ms [TRSimple [Name Nothing "s", Name Nothing "t"]] + +-- these lateral queries make no sense but the syntax is valid + + ,q "select a from lateral a" + $ ms [TRLateral $ TRSimple [Name Nothing "a"]] + + ,q "select a from lateral a,b" + $ ms [TRLateral $ TRSimple [Name Nothing "a"], TRSimple [Name Nothing "b"]] + + ,q "select a from a, lateral b" + $ ms [TRSimple [Name Nothing "a"], TRLateral $ TRSimple [Name Nothing "b"]] + + ,q "select a from a natural join lateral b" + $ ms [TRJoin (TRSimple [Name Nothing "a"]) True JInner + (TRLateral $ TRSimple [Name Nothing "b"]) + Nothing] + + ,q "select a from lateral a natural join lateral b" + $ ms [TRJoin (TRLateral $ TRSimple [Name Nothing "a"]) True JInner + (TRLateral $ TRSimple [Name Nothing "b"]) + Nothing] + + + ,q "select a from t inner join u on expr" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])] + + ,q "select a from t join u on expr" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])] + + ,q "select a from t left join u on expr" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JLeft (TRSimple [Name Nothing "u"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])] + + ,q "select a from t right join u on expr" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JRight (TRSimple [Name Nothing "u"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])] + + ,q "select a from t full join u on expr" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JFull (TRSimple [Name Nothing "u"]) + (Just $ JoinOn $ Iden [Name Nothing "expr"])] + + ,q "select a from t cross join u" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False + JCross (TRSimple [Name Nothing "u"]) Nothing] + + ,q "select a from t natural inner join u" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) True JInner (TRSimple [Name Nothing "u"]) + Nothing] + + ,q "select a from t inner join u using(a,b)" + $ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"]) + (Just $ JoinUsing [Name Nothing "a", Name Nothing "b"])] + + ,q "select a from (select a from t)" + $ ms [TRQueryExpr $ ms [TRSimple [Name Nothing "t"]]] + + ,q "select a from t as u" + $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)] + + ,q "select a from t u" + $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)] + + ,q "select a from t u(b)" + $ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") $ Just [Name Nothing "b"])] + + ,q "select a from (t cross join u) as u" + $ ms [TRAlias (TRParens $ + TRJoin (TRSimple [Name Nothing "t"]) False JCross (TRSimple [Name Nothing "u"]) Nothing) + (Alias (Name Nothing "u") Nothing)] + -- todo: not sure if the associativity is correct + + ,q "select a from t cross join u cross join v" + $ ms [TRJoin + (TRJoin (TRSimple [Name Nothing "t"]) False + JCross (TRSimple [Name Nothing "u"]) Nothing) + False JCross (TRSimple [Name Nothing "v"]) Nothing] + ] + where + ms f = toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)] + ,msFrom = f} + q :: HasCallStack => Text -> QueryExpr -> TestItem + q src ast = testQueryExpr ansi2011 src ast diff --git a/tests/Language/SQL/SimpleSQL/TestRunners.hs b/tests/Language/SQL/SimpleSQL/TestRunners.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/TestRunners.hs @@ -0,0 +1,92 @@ + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.TestRunners + (testLex + ,lexFails + ,testScalarExpr + ,testQueryExpr + ,testStatement + ,testStatements + ,testParseQueryExpr + ,testParseQueryExprFails + ,testParseScalarExprFails + ,HasCallStack + ) where + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.TestTypes +import Language.SQL.SimpleSQL.Pretty +import Language.SQL.SimpleSQL.Parse +import qualified Language.SQL.SimpleSQL.Lex as Lex + +import Data.Text (Text) +import qualified Data.Text as T + +import Language.SQL.SimpleSQL.Expectations + (shouldParseL + ,shouldFail + ,shouldParseA + ,shouldSucceed + ) + +import Test.Hspec + (it + ,HasCallStack + ) + +testLex :: HasCallStack => Dialect -> Text -> [Lex.Token] -> TestItem +testLex d input a = + LexTest d input a $ do + it (T.unpack input) $ Lex.lexSQL d False "" Nothing input `shouldParseL` a + it (T.unpack $ "pp: " <> input) $ Lex.lexSQL d False "" Nothing (Lex.prettyTokens d a) `shouldParseL` a + +lexFails :: HasCallStack => Dialect -> Text -> TestItem +lexFails d input = + LexFails d input $ + it (T.unpack input) $ shouldFail $ Lex.lexSQL d False "" Nothing input + +testScalarExpr :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem +testScalarExpr d input a = + TestScalarExpr d input a $ do + it (T.unpack input) $ parseScalarExpr d "" Nothing input `shouldParseA` a + it (T.unpack $ "pp: " <> input) $ parseScalarExpr d "" Nothing (prettyScalarExpr d a) `shouldParseA` a + +testQueryExpr :: HasCallStack => Dialect -> Text -> QueryExpr -> TestItem +testQueryExpr d input a = + TestQueryExpr d input a $ do + it (T.unpack input) $ parseQueryExpr d "" Nothing input `shouldParseA` a + it (T.unpack $ "pp: " <> input) $ parseQueryExpr d "" Nothing (prettyQueryExpr d a) `shouldParseA` a + +testParseQueryExpr :: HasCallStack => Dialect -> Text -> TestItem +testParseQueryExpr d input = + let a = parseQueryExpr d "" Nothing input + in ParseQueryExpr d input $ do + it (T.unpack input) $ shouldSucceed (T.unpack . prettyError) a + case a of + Left _ -> pure () + Right a' -> + it (T.unpack $ "pp: " <> input) $ + parseQueryExpr d "" Nothing (prettyQueryExpr d a') `shouldParseA` a' + +testParseQueryExprFails :: HasCallStack => Dialect -> Text -> TestItem +testParseQueryExprFails d input = + ParseQueryExprFails d input $ + it (T.unpack input) $ shouldFail $ parseQueryExpr d "" Nothing input + +testParseScalarExprFails :: HasCallStack => Dialect -> Text -> TestItem +testParseScalarExprFails d input = + ParseScalarExprFails d input $ + it (T.unpack input) $ shouldFail $ parseScalarExpr d "" Nothing input + +testStatement :: HasCallStack => Dialect -> Text -> Statement -> TestItem +testStatement d input a = + TestStatement d input a $ do + it (T.unpack input) $ parseStatement d "" Nothing input `shouldParseA` a + it (T.unpack $ "pp: " <> input) $ parseStatement d "" Nothing (prettyStatement d a) `shouldParseA` a + +testStatements :: HasCallStack => Dialect -> Text -> [Statement] -> TestItem +testStatements d input a = + TestStatements d input a $ do + it (T.unpack input) $ parseStatements d "" Nothing input `shouldParseA` a + it (T.unpack $ "pp: " <> input) $ parseStatements d "" Nothing (prettyStatements d a) `shouldParseA` a + diff --git a/tests/Language/SQL/SimpleSQL/TestTypes.hs b/tests/Language/SQL/SimpleSQL/TestTypes.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/TestTypes.hs @@ -0,0 +1,56 @@ + +{- +This is the types used to define the tests as pure data. See the +Tests.hs module for the 'interpreter'. +-} + +module Language.SQL.SimpleSQL.TestTypes + (TestItem(..) + ,module Language.SQL.SimpleSQL.Dialect + ) where + +import Language.SQL.SimpleSQL.Syntax +import Language.SQL.SimpleSQL.Lex (Token) +import Language.SQL.SimpleSQL.Dialect + +import Test.Hspec (SpecWith) + + +import Data.Text (Text) + +{- +TODO: maybe make the dialect args into [dialect], then each test +checks all the dialects mentioned work, and all the dialects not +mentioned give a parse error. Not sure if this will be too awkward due +to lots of tricky exceptions/variationsx. + +The test items are designed to allow code to grab all the examples +in easily usable data types, but since hspec has this neat feature +where it will give a source location for a test failure, each testitem +apart from group already has the SpecWith attached to run that test, +that way we can attach the source location to each test item +-} + +data TestItem = Group Text [TestItem] + | TestScalarExpr Dialect Text ScalarExpr (SpecWith ()) + | TestQueryExpr Dialect Text QueryExpr (SpecWith ()) + | TestStatement Dialect Text Statement (SpecWith ()) + | TestStatements Dialect Text [Statement] (SpecWith ()) + +{- +this just checks the sql parses without error, mostly just a +intermediate when I'm too lazy to write out the parsed AST. These +should all be TODO to convert to a testqueryexpr test. +-} + + | ParseQueryExpr Dialect Text (SpecWith ()) + +-- check that the string given fails to parse + + | ParseQueryExprFails Dialect Text (SpecWith ()) + | ParseScalarExprFails Dialect Text (SpecWith ()) + | LexTest Dialect Text [Token] (SpecWith ()) + | LexFails Dialect Text (SpecWith ()) + | GeneralParseFailTest Text Text (SpecWith ()) + | GoldenErrorTest Text [(Text,Text,Text)] (SpecWith ()) + diff --git a/tests/Language/SQL/SimpleSQL/Tests.hs b/tests/Language/SQL/SimpleSQL/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Tests.hs @@ -0,0 +1,98 @@ + +{- +This is the main tests module which exposes the test data plus the +Test.Framework tests. It also contains the code which converts the +test data to the Test.Framework tests. +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Tests + (testData + ,tests + ,TestItem(..) + ) where + +import Test.Hspec + (SpecWith + ,describe + ,parallel + ) + +import Language.SQL.SimpleSQL.TestTypes + +import Language.SQL.SimpleSQL.FullQueries +import Language.SQL.SimpleSQL.GroupBy +import Language.SQL.SimpleSQL.Postgres +import Language.SQL.SimpleSQL.QueryExprComponents +import Language.SQL.SimpleSQL.QueryExprs +import Language.SQL.SimpleSQL.QueryExprParens +import Language.SQL.SimpleSQL.TableRefs +import Language.SQL.SimpleSQL.ScalarExprs +import Language.SQL.SimpleSQL.Odbc +import Language.SQL.SimpleSQL.Tpch +import Language.SQL.SimpleSQL.LexerTests +import Language.SQL.SimpleSQL.EmptyStatement +import Language.SQL.SimpleSQL.CreateIndex + +import Language.SQL.SimpleSQL.SQL2011Queries +import Language.SQL.SimpleSQL.SQL2011AccessControl +import Language.SQL.SimpleSQL.SQL2011Bits +import Language.SQL.SimpleSQL.SQL2011DataManipulation +import Language.SQL.SimpleSQL.SQL2011Schema + +import Language.SQL.SimpleSQL.MySQL +import Language.SQL.SimpleSQL.Oracle +import Language.SQL.SimpleSQL.CustomDialect +import Language.SQL.SimpleSQL.ErrorMessages + +import qualified Data.Text as T + +{- +Order the tests to start from the simplest first. This is also the +order on the generated documentation. +-} + +testData :: TestItem +testData = + Group "parserTest" + [lexerTests + ,scalarExprTests + ,odbcTests + ,queryExprComponentTests + ,queryExprsTests + ,queryExprParensTests + ,tableRefTests + ,groupByTests + ,fullQueriesTests + ,postgresTests + ,tpchTests + ,sql2011QueryTests + ,sql2011DataManipulationTests + ,sql2011SchemaTests + ,sql2011AccessControlTests + ,sql2011BitsTests + ,mySQLTests + ,oracleTests + ,customDialectTests + ,emptyStatementTests + ,createIndexTests + ,errorMessageTests + ] + +tests :: SpecWith () +tests = parallel $ itemToTest testData + +itemToTest :: TestItem -> SpecWith () +itemToTest (Group nm ts) = + describe (T.unpack nm) $ mapM_ itemToTest ts +itemToTest (TestScalarExpr _ _ _ t) = t +itemToTest (TestQueryExpr _ _ _ t) = t +itemToTest (TestStatement _ _ _ t) = t +itemToTest (TestStatements _ _ _ t) = t +itemToTest (ParseQueryExpr _ _ t) = t +itemToTest (ParseQueryExprFails _ _ t) = t +itemToTest (ParseScalarExprFails _ _ t) = t +itemToTest (LexTest _ _ _ t) = t +itemToTest (LexFails _ _ t) = t +itemToTest (GeneralParseFailTest _ _ t) = t +itemToTest (GoldenErrorTest _ _ t) = t diff --git a/tests/Language/SQL/SimpleSQL/Tpch.hs b/tests/Language/SQL/SimpleSQL/Tpch.hs new file mode 100644 --- /dev/null +++ b/tests/Language/SQL/SimpleSQL/Tpch.hs @@ -0,0 +1,690 @@ + +{- +Some tests for parsing the tpch queries + +The changes made to the official syntax are: +1. replace the set rowcount with ansi standard fetch first n rows only +2. replace the create view, query, drop view sequence with a query + using a common table expression +-} + +{-# LANGUAGE OverloadedStrings #-} +module Language.SQL.SimpleSQL.Tpch (tpchTests,tpchQueries) where + +import Language.SQL.SimpleSQL.TestTypes + +import Data.Text (Text) +import Language.SQL.SimpleSQL.TestRunners + +tpchTests :: TestItem +tpchTests = Group "parse tpch" tpchQueries + +tpchQueries :: [TestItem] +tpchQueries = + [q "Q1" "\n\ + \select\n\ + \ l_returnflag,\n\ + \ l_linestatus,\n\ + \ sum(l_quantity) as sum_qty,\n\ + \ sum(l_extendedprice) as sum_base_price,\n\ + \ sum(l_extendedprice * (1 - l_discount)) as sum_disc_price,\n\ + \ sum(l_extendedprice * (1 - l_discount) * (1 + l_tax)) as sum_charge,\n\ + \ avg(l_quantity) as avg_qty,\n\ + \ avg(l_extendedprice) as avg_price,\n\ + \ avg(l_discount) as avg_disc,\n\ + \ count(*) as count_order\n\ + \from\n\ + \ lineitem\n\ + \where\n\ + \ l_shipdate <= date '1998-12-01' - interval '63' day (3)\n\ + \group by\n\ + \ l_returnflag,\n\ + \ l_linestatus\n\ + \order by\n\ + \ l_returnflag,\n\ + \ l_linestatus" + ,q "Q2" "\n\ + \select\n\ + \ s_acctbal,\n\ + \ s_name,\n\ + \ n_name,\n\ + \ p_partkey,\n\ + \ p_mfgr,\n\ + \ s_address,\n\ + \ s_phone,\n\ + \ s_comment\n\ + \from\n\ + \ part,\n\ + \ supplier,\n\ + \ partsupp,\n\ + \ nation,\n\ + \ region\n\ + \where\n\ + \ p_partkey = ps_partkey\n\ + \ and s_suppkey = ps_suppkey\n\ + \ and p_size = 15\n\ + \ and p_type like '%BRASS'\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_regionkey = r_regionkey\n\ + \ and r_name = 'EUROPE'\n\ + \ and ps_supplycost = (\n\ + \ select\n\ + \ min(ps_supplycost)\n\ + \ from\n\ + \ partsupp,\n\ + \ supplier,\n\ + \ nation,\n\ + \ region\n\ + \ where\n\ + \ p_partkey = ps_partkey\n\ + \ and s_suppkey = ps_suppkey\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_regionkey = r_regionkey\n\ + \ and r_name = 'EUROPE'\n\ + \ )\n\ + \order by\n\ + \ s_acctbal desc,\n\ + \ n_name,\n\ + \ s_name,\n\ + \ p_partkey\n\ + \fetch first 100 rows only" + ,q "Q3" "\n\ + \ select\n\ + \ l_orderkey,\n\ + \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\ + \ o_orderdate,\n\ + \ o_shippriority\n\ + \ from\n\ + \ customer,\n\ + \ orders,\n\ + \ lineitem\n\ + \ where\n\ + \ c_mktsegment = 'MACHINERY'\n\ + \ and c_custkey = o_custkey\n\ + \ and l_orderkey = o_orderkey\n\ + \ and o_orderdate < date '1995-03-21'\n\ + \ and l_shipdate > date '1995-03-21'\n\ + \ group by\n\ + \ l_orderkey,\n\ + \ o_orderdate,\n\ + \ o_shippriority\n\ + \ order by\n\ + \ revenue desc,\n\ + \ o_orderdate\n\ + \ fetch first 10 rows only" + ,q "Q4" "\n\ + \ select\n\ + \ o_orderpriority,\n\ + \ count(*) as order_count\n\ + \ from\n\ + \ orders\n\ + \ where\n\ + \ o_orderdate >= date '1996-03-01'\n\ + \ and o_orderdate < date '1996-03-01' + interval '3' month\n\ + \ and exists (\n\ + \ select\n\ + \ *\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_orderkey = o_orderkey\n\ + \ and l_commitdate < l_receiptdate\n\ + \ )\n\ + \ group by\n\ + \ o_orderpriority\n\ + \ order by\n\ + \ o_orderpriority" + ,q "Q5" "\n\ + \ select\n\ + \ n_name,\n\ + \ sum(l_extendedprice * (1 - l_discount)) as revenue\n\ + \ from\n\ + \ customer,\n\ + \ orders,\n\ + \ lineitem,\n\ + \ supplier,\n\ + \ nation,\n\ + \ region\n\ + \ where\n\ + \ c_custkey = o_custkey\n\ + \ and l_orderkey = o_orderkey\n\ + \ and l_suppkey = s_suppkey\n\ + \ and c_nationkey = s_nationkey\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_regionkey = r_regionkey\n\ + \ and r_name = 'EUROPE'\n\ + \ and o_orderdate >= date '1997-01-01'\n\ + \ and o_orderdate < date '1997-01-01' + interval '1' year\n\ + \ group by\n\ + \ n_name\n\ + \ order by\n\ + \ revenue desc" + ,q "Q6" "\n\ + \ select\n\ + \ sum(l_extendedprice * l_discount) as revenue\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_shipdate >= date '1997-01-01'\n\ + \ and l_shipdate < date '1997-01-01' + interval '1' year\n\ + \ and l_discount between 0.07 - 0.01 and 0.07 + 0.01\n\ + \ and l_quantity < 24" + ,q "Q7" "\n\ + \ select\n\ + \ supp_nation,\n\ + \ cust_nation,\n\ + \ l_year,\n\ + \ sum(volume) as revenue\n\ + \ from\n\ + \ (\n\ + \ select\n\ + \ n1.n_name as supp_nation,\n\ + \ n2.n_name as cust_nation,\n\ + \ extract(year from l_shipdate) as l_year,\n\ + \ l_extendedprice * (1 - l_discount) as volume\n\ + \ from\n\ + \ supplier,\n\ + \ lineitem,\n\ + \ orders,\n\ + \ customer,\n\ + \ nation n1,\n\ + \ nation n2\n\ + \ where\n\ + \ s_suppkey = l_suppkey\n\ + \ and o_orderkey = l_orderkey\n\ + \ and c_custkey = o_custkey\n\ + \ and s_nationkey = n1.n_nationkey\n\ + \ and c_nationkey = n2.n_nationkey\n\ + \ and (\n\ + \ (n1.n_name = 'PERU' and n2.n_name = 'IRAQ')\n\ + \ or (n1.n_name = 'IRAQ' and n2.n_name = 'PERU')\n\ + \ )\n\ + \ and l_shipdate between date '1995-01-01' and date '1996-12-31'\n\ + \ ) as shipping\n\ + \ group by\n\ + \ supp_nation,\n\ + \ cust_nation,\n\ + \ l_year\n\ + \ order by\n\ + \ supp_nation,\n\ + \ cust_nation,\n\ + \ l_year" + ,q "Q8" "\n\ + \ select\n\ + \ o_year,\n\ + \ sum(case\n\ + \ when nation = 'IRAQ' then volume\n\ + \ else 0\n\ + \ end) / sum(volume) as mkt_share\n\ + \ from\n\ + \ (\n\ + \ select\n\ + \ extract(year from o_orderdate) as o_year,\n\ + \ l_extendedprice * (1 - l_discount) as volume,\n\ + \ n2.n_name as nation\n\ + \ from\n\ + \ part,\n\ + \ supplier,\n\ + \ lineitem,\n\ + \ orders,\n\ + \ customer,\n\ + \ nation n1,\n\ + \ nation n2,\n\ + \ region\n\ + \ where\n\ + \ p_partkey = l_partkey\n\ + \ and s_suppkey = l_suppkey\n\ + \ and l_orderkey = o_orderkey\n\ + \ and o_custkey = c_custkey\n\ + \ and c_nationkey = n1.n_nationkey\n\ + \ and n1.n_regionkey = r_regionkey\n\ + \ and r_name = 'MIDDLE EAST'\n\ + \ and s_nationkey = n2.n_nationkey\n\ + \ and o_orderdate between date '1995-01-01' and date '1996-12-31'\n\ + \ and p_type = 'STANDARD ANODIZED BRASS'\n\ + \ ) as all_nations\n\ + \ group by\n\ + \ o_year\n\ + \ order by\n\ + \ o_year" + ,q "Q9" "\n\ + \ select\n\ + \ nation,\n\ + \ o_year,\n\ + \ sum(amount) as sum_profit\n\ + \ from\n\ + \ (\n\ + \ select\n\ + \ n_name as nation,\n\ + \ extract(year from o_orderdate) as o_year,\n\ + \ l_extendedprice * (1 - l_discount) - ps_supplycost * l_quantity as amount\n\ + \ from\n\ + \ part,\n\ + \ supplier,\n\ + \ lineitem,\n\ + \ partsupp,\n\ + \ orders,\n\ + \ nation\n\ + \ where\n\ + \ s_suppkey = l_suppkey\n\ + \ and ps_suppkey = l_suppkey\n\ + \ and ps_partkey = l_partkey\n\ + \ and p_partkey = l_partkey\n\ + \ and o_orderkey = l_orderkey\n\ + \ and s_nationkey = n_nationkey\n\ + \ and p_name like '%antique%'\n\ + \ ) as profit\n\ + \ group by\n\ + \ nation,\n\ + \ o_year\n\ + \ order by\n\ + \ nation,\n\ + \ o_year desc" + ,q "Q10" "\n\ + \ select\n\ + \ c_custkey,\n\ + \ c_name,\n\ + \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\ + \ c_acctbal,\n\ + \ n_name,\n\ + \ c_address,\n\ + \ c_phone,\n\ + \ c_comment\n\ + \ from\n\ + \ customer,\n\ + \ orders,\n\ + \ lineitem,\n\ + \ nation\n\ + \ where\n\ + \ c_custkey = o_custkey\n\ + \ and l_orderkey = o_orderkey\n\ + \ and o_orderdate >= date '1993-12-01'\n\ + \ and o_orderdate < date '1993-12-01' + interval '3' month\n\ + \ and l_returnflag = 'R'\n\ + \ and c_nationkey = n_nationkey\n\ + \ group by\n\ + \ c_custkey,\n\ + \ c_name,\n\ + \ c_acctbal,\n\ + \ c_phone,\n\ + \ n_name,\n\ + \ c_address,\n\ + \ c_comment\n\ + \ order by\n\ + \ revenue desc\n\ + \ fetch first 20 rows only" + ,q "Q11" "\n\ + \ select\n\ + \ ps_partkey,\n\ + \ sum(ps_supplycost * ps_availqty) as value\n\ + \ from\n\ + \ partsupp,\n\ + \ supplier,\n\ + \ nation\n\ + \ where\n\ + \ ps_suppkey = s_suppkey\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_name = 'CHINA'\n\ + \ group by\n\ + \ ps_partkey having\n\ + \ sum(ps_supplycost * ps_availqty) > (\n\ + \ select\n\ + \ sum(ps_supplycost * ps_availqty) * 0.0001000000\n\ + \ from\n\ + \ partsupp,\n\ + \ supplier,\n\ + \ nation\n\ + \ where\n\ + \ ps_suppkey = s_suppkey\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_name = 'CHINA'\n\ + \ )\n\ + \ order by\n\ + \ value desc" + ,q "Q12" "\n\ + \ select\n\ + \ l_shipmode,\n\ + \ sum(case\n\ + \ when o_orderpriority = '1-URGENT'\n\ + \ or o_orderpriority = '2-HIGH'\n\ + \ then 1\n\ + \ else 0\n\ + \ end) as high_line_count,\n\ + \ sum(case\n\ + \ when o_orderpriority <> '1-URGENT'\n\ + \ and o_orderpriority <> '2-HIGH'\n\ + \ then 1\n\ + \ else 0\n\ + \ end) as low_line_count\n\ + \ from\n\ + \ orders,\n\ + \ lineitem\n\ + \ where\n\ + \ o_orderkey = l_orderkey\n\ + \ and l_shipmode in ('AIR', 'RAIL')\n\ + \ and l_commitdate < l_receiptdate\n\ + \ and l_shipdate < l_commitdate\n\ + \ and l_receiptdate >= date '1994-01-01'\n\ + \ and l_receiptdate < date '1994-01-01' + interval '1' year\n\ + \ group by\n\ + \ l_shipmode\n\ + \ order by\n\ + \ l_shipmode" + ,q "Q13" "\n\ + \ select\n\ + \ c_count,\n\ + \ count(*) as custdist\n\ + \ from\n\ + \ (\n\ + \ select\n\ + \ c_custkey,\n\ + \ count(o_orderkey)\n\ + \ from\n\ + \ customer left outer join orders on\n\ + \ c_custkey = o_custkey\n\ + \ and o_comment not like '%pending%requests%'\n\ + \ group by\n\ + \ c_custkey\n\ + \ ) as c_orders (c_custkey, c_count)\n\ + \ group by\n\ + \ c_count\n\ + \ order by\n\ + \ custdist desc,\n\ + \ c_count desc" + ,q "Q14" "\n\ + \ select\n\ + \ 100.00 * sum(case\n\ + \ when p_type like 'PROMO%'\n\ + \ then l_extendedprice * (1 - l_discount)\n\ + \ else 0\n\ + \ end) / sum(l_extendedprice * (1 - l_discount)) as promo_revenue\n\ + \ from\n\ + \ lineitem,\n\ + \ part\n\ + \ where\n\ + \ l_partkey = p_partkey\n\ + \ and l_shipdate >= date '1994-12-01'\n\ + \ and l_shipdate < date '1994-12-01' + interval '1' month" + ,q "Q15" "\n\ + \ /*create view revenue0 (supplier_no, total_revenue) as\n\ + \ select\n\ + \ l_suppkey,\n\ + \ sum(l_extendedprice * (1 - l_discount))\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_shipdate >= date '1995-06-01'\n\ + \ and l_shipdate < date '1995-06-01' + interval '3' month\n\ + \ group by\n\ + \ l_suppkey;*/\n\ + \ with\n\ + \ revenue0 as\n\ + \ (select\n\ + \ l_suppkey as supplier_no,\n\ + \ sum(l_extendedprice * (1 - l_discount)) as total_revenue\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_shipdate >= date '1995-06-01'\n\ + \ and l_shipdate < date '1995-06-01' + interval '3' month\n\ + \ group by\n\ + \ l_suppkey)\n\ + \ select\n\ + \ s_suppkey,\n\ + \ s_name,\n\ + \ s_address,\n\ + \ s_phone,\n\ + \ total_revenue\n\ + \ from\n\ + \ supplier,\n\ + \ revenue0\n\ + \ where\n\ + \ s_suppkey = supplier_no\n\ + \ and total_revenue = (\n\ + \ select\n\ + \ max(total_revenue)\n\ + \ from\n\ + \ revenue0\n\ + \ )\n\ + \ order by\n\ + \ s_suppkey" + ,q "Q16" "\n\ + \ select\n\ + \ p_brand,\n\ + \ p_type,\n\ + \ p_size,\n\ + \ count(distinct ps_suppkey) as supplier_cnt\n\ + \ from\n\ + \ partsupp,\n\ + \ part\n\ + \ where\n\ + \ p_partkey = ps_partkey\n\ + \ and p_brand <> 'Brand#15'\n\ + \ and p_type not like 'MEDIUM BURNISHED%'\n\ + \ and p_size in (39, 26, 18, 45, 19, 1, 3, 9)\n\ + \ and ps_suppkey not in (\n\ + \ select\n\ + \ s_suppkey\n\ + \ from\n\ + \ supplier\n\ + \ where\n\ + \ s_comment like '%Customer%Complaints%'\n\ + \ )\n\ + \ group by\n\ + \ p_brand,\n\ + \ p_type,\n\ + \ p_size\n\ + \ order by\n\ + \ supplier_cnt desc,\n\ + \ p_brand,\n\ + \ p_type,\n\ + \ p_size" + ,q "Q17" "\n\ + \ select\n\ + \ sum(l_extendedprice) / 7.0 as avg_yearly\n\ + \ from\n\ + \ lineitem,\n\ + \ part\n\ + \ where\n\ + \ p_partkey = l_partkey\n\ + \ and p_brand = 'Brand#52'\n\ + \ and p_container = 'JUMBO CAN'\n\ + \ and l_quantity < (\n\ + \ select\n\ + \ 0.2 * avg(l_quantity)\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_partkey = p_partkey\n\ + \ )" + ,q "Q18" "\n\ + \ select\n\ + \ c_name,\n\ + \ c_custkey,\n\ + \ o_orderkey,\n\ + \ o_orderdate,\n\ + \ o_totalprice,\n\ + \ sum(l_quantity)\n\ + \ from\n\ + \ customer,\n\ + \ orders,\n\ + \ lineitem\n\ + \ where\n\ + \ o_orderkey in (\n\ + \ select\n\ + \ l_orderkey\n\ + \ from\n\ + \ lineitem\n\ + \ group by\n\ + \ l_orderkey having\n\ + \ sum(l_quantity) > 313\n\ + \ )\n\ + \ and c_custkey = o_custkey\n\ + \ and o_orderkey = l_orderkey\n\ + \ group by\n\ + \ c_name,\n\ + \ c_custkey,\n\ + \ o_orderkey,\n\ + \ o_orderdate,\n\ + \ o_totalprice\n\ + \ order by\n\ + \ o_totalprice desc,\n\ + \ o_orderdate\n\ + \ fetch first 100 rows only" + ,q "Q19" "\n\ + \ select\n\ + \ sum(l_extendedprice* (1 - l_discount)) as revenue\n\ + \ from\n\ + \ lineitem,\n\ + \ part\n\ + \ where\n\ + \ (\n\ + \ p_partkey = l_partkey\n\ + \ and p_brand = 'Brand#43'\n\ + \ and p_container in ('SM CASE', 'SM BOX', 'SM PACK', 'SM PKG')\n\ + \ and l_quantity >= 3 and l_quantity <= 3 + 10\n\ + \ and p_size between 1 and 5\n\ + \ and l_shipmode in ('AIR', 'AIR REG')\n\ + \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ + \ )\n\ + \ or\n\ + \ (\n\ + \ p_partkey = l_partkey\n\ + \ and p_brand = 'Brand#25'\n\ + \ and p_container in ('MED BAG', 'MED BOX', 'MED PKG', 'MED PACK')\n\ + \ and l_quantity >= 10 and l_quantity <= 10 + 10\n\ + \ and p_size between 1 and 10\n\ + \ and l_shipmode in ('AIR', 'AIR REG')\n\ + \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ + \ )\n\ + \ or\n\ + \ (\n\ + \ p_partkey = l_partkey\n\ + \ and p_brand = 'Brand#24'\n\ + \ and p_container in ('LG CASE', 'LG BOX', 'LG PACK', 'LG PKG')\n\ + \ and l_quantity >= 22 and l_quantity <= 22 + 10\n\ + \ and p_size between 1 and 15\n\ + \ and l_shipmode in ('AIR', 'AIR REG')\n\ + \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ + \ )" + ,q "Q20" "\n\ + \ select\n\ + \ s_name,\n\ + \ s_address\n\ + \ from\n\ + \ supplier,\n\ + \ nation\n\ + \ where\n\ + \ s_suppkey in (\n\ + \ select\n\ + \ ps_suppkey\n\ + \ from\n\ + \ partsupp\n\ + \ where\n\ + \ ps_partkey in (\n\ + \ select\n\ + \ p_partkey\n\ + \ from\n\ + \ part\n\ + \ where\n\ + \ p_name like 'lime%'\n\ + \ )\n\ + \ and ps_availqty > (\n\ + \ select\n\ + \ 0.5 * sum(l_quantity)\n\ + \ from\n\ + \ lineitem\n\ + \ where\n\ + \ l_partkey = ps_partkey\n\ + \ and l_suppkey = ps_suppkey\n\ + \ and l_shipdate >= date '1994-01-01'\n\ + \ and l_shipdate < date '1994-01-01' + interval '1' year\n\ + \ )\n\ + \ )\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_name = 'VIETNAM'\n\ + \ order by\n\ + \ s_name" + ,q "Q21" "\n\ + \ select\n\ + \ s_name,\n\ + \ count(*) as numwait\n\ + \ from\n\ + \ supplier,\n\ + \ lineitem l1,\n\ + \ orders,\n\ + \ nation\n\ + \ where\n\ + \ s_suppkey = l1.l_suppkey\n\ + \ and o_orderkey = l1.l_orderkey\n\ + \ and o_orderstatus = 'F'\n\ + \ and l1.l_receiptdate > l1.l_commitdate\n\ + \ and exists (\n\ + \ select\n\ + \ *\n\ + \ from\n\ + \ lineitem l2\n\ + \ where\n\ + \ l2.l_orderkey = l1.l_orderkey\n\ + \ and l2.l_suppkey <> l1.l_suppkey\n\ + \ )\n\ + \ and not exists (\n\ + \ select\n\ + \ *\n\ + \ from\n\ + \ lineitem l3\n\ + \ where\n\ + \ l3.l_orderkey = l1.l_orderkey\n\ + \ and l3.l_suppkey <> l1.l_suppkey\n\ + \ and l3.l_receiptdate > l3.l_commitdate\n\ + \ )\n\ + \ and s_nationkey = n_nationkey\n\ + \ and n_name = 'INDIA'\n\ + \ group by\n\ + \ s_name\n\ + \ order by\n\ + \ numwait desc,\n\ + \ s_name\n\ + \ fetch first 100 rows only" + ,q "Q22" "\n\ + \ select\n\ + \ cntrycode,\n\ + \ count(*) as numcust,\n\ + \ sum(c_acctbal) as totacctbal\n\ + \ from\n\ + \ (\n\ + \ select\n\ + \ substring(c_phone from 1 for 2) as cntrycode,\n\ + \ c_acctbal\n\ + \ from\n\ + \ customer\n\ + \ where\n\ + \ substring(c_phone from 1 for 2) in\n\ + \ ('41', '28', '39', '21', '24', '29', '44')\n\ + \ and c_acctbal > (\n\ + \ select\n\ + \ avg(c_acctbal)\n\ + \ from\n\ + \ customer\n\ + \ where\n\ + \ c_acctbal > 0.00\n\ + \ and substring(c_phone from 1 for 2) in\n\ + \ ('41', '28', '39', '21', '24', '29', '44')\n\ + \ )\n\ + \ and not exists (\n\ + \ select\n\ + \ *\n\ + \ from\n\ + \ orders\n\ + \ where\n\ + \ o_custkey = c_custkey\n\ + \ )\n\ + \ ) as custsale\n\ + \ group by\n\ + \ cntrycode\n\ + \ order by\n\ + \ cntrycode" + ] + where + q :: HasCallStack => Text -> Text -> TestItem + q _ src = testParseQueryExpr ansi2011 src diff --git a/tests/RunTests.hs b/tests/RunTests.hs new file mode 100644 --- /dev/null +++ b/tests/RunTests.hs @@ -0,0 +1,9 @@ + + +import Test.Hspec (hspec) + + +import Language.SQL.SimpleSQL.Tests + +main :: IO () +main = hspec tests diff --git a/tools/Language/SQL/SimpleSQL/FullQueries.lhs b/tools/Language/SQL/SimpleSQL/FullQueries.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/FullQueries.lhs +++ /dev/null @@ -1,39 +0,0 @@ - -Some tests for parsing full queries. - -> module Language.SQL.SimpleSQL.FullQueries (fullQueriesTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - - -> fullQueriesTests :: TestItem -> fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select count(*) from t" -> ,makeSelect -> {qeSelectList = [(App [Name "count"] [Star], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> } -> ) - -> ,("select a, sum(c+d) as s\n\ -> \ from t,u\n\ -> \ where a > 5\n\ -> \ group by a\n\ -> \ 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] -> } -> ) -> ] diff --git a/tools/Language/SQL/SimpleSQL/GroupBy.lhs b/tools/Language/SQL/SimpleSQL/GroupBy.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/GroupBy.lhs +++ /dev/null @@ -1,235 +0,0 @@ - -Here are the tests for the group by component of query exprs - -> module Language.SQL.SimpleSQL.GroupBy (groupByTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - - -> groupByTests :: TestItem -> groupByTests = Group "groupByTests" -> [simpleGroupBy -> ,newGroupBy -> ,randomGroupBy -> ] - -> simpleGroupBy :: TestItem -> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) -> [("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"]] -> }) - -> ,("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"]] -> }) -> ] - -test the new group by (), grouping sets, cube and rollup syntax (not -sure which sql version they were introduced, 1999 or 2003 I think). - -> newGroupBy :: TestItem -> newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from t group by ()", ms [GroupingParens []]) -> ,("select * from t group by grouping sets ((), (a))" -> ,ms [GroupingSets [GroupingParens [] -> ,GroupingParens [SimpleGroup $ Iden [Name "a"]]]]) -> ,("select * from t group by cube(a,b)" -> ,ms [Cube [SimpleGroup $ Iden [Name "a"], SimpleGroup $ Iden [Name "b"]]]) -> ,("select * from t group by rollup(a,b)" -> ,ms [Rollup [SimpleGroup $ Iden [Name "a"], SimpleGroup $ Iden [Name "b"]]]) -> ] -> where -> ms g = makeSelect {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = g} - -> randomGroupBy :: TestItem -> randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr SQL2011) -> ["select * from t GROUP BY a" -> ,"select * from t GROUP BY GROUPING SETS((a))" -> ,"select * from t GROUP BY a,b,c" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c))" -> ,"select * from t GROUP BY ROLLUP(a,b)" -> ,"select * from t GROUP BY GROUPING SETS((a,b),\n\ -> \(a),\n\ -> \() )" -> ,"select * from t GROUP BY ROLLUP(b,a)" -> ,"select * from t GROUP BY GROUPING SETS((b,a),\n\ -> \(b),\n\ -> \() )" -> ,"select * from t GROUP BY CUBE(a,b,c)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\ -> \(a,b),\n\ -> \(a,c),\n\ -> \(b,c),\n\ -> \(a),\n\ -> \(b),\n\ -> \(c),\n\ -> \() )" -> ,"select * from t GROUP BY ROLLUP(Province, County, City)" -> ,"select * from t GROUP BY ROLLUP(Province, (County, City))" -> ,"select * from t GROUP BY ROLLUP(Province, (County, City))" -> ,"select * from t GROUP BY GROUPING SETS((Province, County, City),\n\ -> \(Province),\n\ -> \() )" -> ,"select * from t GROUP BY GROUPING SETS((Province, County, City),\n\ -> \(Province, County),\n\ -> \(Province),\n\ -> \() )" -> ,"select * from t GROUP BY a, ROLLUP(b,c)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\ -> \(a,b),\n\ -> \(a) )" -> ,"select * from t GROUP BY a, b, ROLLUP(c,d)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\ -> \(a,b,c),\n\ -> \(a,b) )" -> ,"select * from t GROUP BY ROLLUP(a), ROLLUP(b,c)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\ -> \(a,b),\n\ -> \(a),\n\ -> \(b,c),\n\ -> \(b),\n\ -> \() )" -> ,"select * from t GROUP BY ROLLUP(a), CUBE(b,c)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\ -> \(a,b),\n\ -> \(a,c),\n\ -> \(a),\n\ -> \(b,c),\n\ -> \(b),\n\ -> \(c),\n\ -> \() )" -> ,"select * from t GROUP BY CUBE(a,b), ROLLUP(c,d)" -> ,"select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\ -> \(a,b,c),\n\ -> \(a,b),\n\ -> \(a,c,d),\n\ -> \(a,c),\n\ -> \(a),\n\ -> \(b,c,d),\n\ -> \(b,c),\n\ -> \(b),\n\ -> \(c,d),\n\ -> \(c),\n\ -> \() )" -> ,"select * from t GROUP BY a, ROLLUP(a,b)" -> ,"select * from t GROUP BY GROUPING SETS((a,b),\n\ -> \(a) )" -> ,"select * from t GROUP BY Region,\n\ -> \ROLLUP(Sales_Person, WEEK(Sales_Date)),\n\ -> \CUBE(YEAR(Sales_Date), MONTH (Sales_Date))" -> ,"select * from t GROUP BY ROLLUP (Region, Sales_Person, WEEK(Sales_Date),\n\ -> \YEAR(Sales_Date), MONTH(Sales_Date) )" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \WHERE WEEK(SALES_DATE) = 13\n\ -> \GROUP BY WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON\n\ -> \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \WHERE WEEK(SALES_DATE) = 13\n\ -> \GROUP BY GROUPING SETS ( (WEEK(SALES_DATE), SALES_PERSON),\n\ -> \(DAYOFWEEK(SALES_DATE), SALES_PERSON))\n\ -> \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \WHERE WEEK(SALES_DATE) = 13\n\ -> \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\ -> \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \SALES_PERSON, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \WHERE WEEK(SALES_DATE) = 13\n\ -> \GROUP BY CUBE ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\ -> \ORDER BY WEEK, DAY_WEEK, SALES_PERSON" - -> ,"SELECT SALES_PERSON,\n\ -> \MONTH(SALES_DATE) AS MONTH,\n\ -> \SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \GROUP BY GROUPING SETS ( (SALES_PERSON, MONTH(SALES_DATE)),\n\ -> \()\n\ -> \)\n\ -> \ORDER BY SALES_PERSON, MONTH" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \GROUP BY ROLLUP ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE) )\n\ -> \ORDER BY WEEK, DAY_WEEK" - -> ,"SELECT MONTH(SALES_DATE) AS MONTH,\n\ -> \REGION,\n\ -> \SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \GROUP BY ROLLUP ( MONTH(SALES_DATE), REGION )\n\ -> \ORDER BY MONTH, REGION" - -> ,"SELECT WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \MONTH(SALES_DATE) AS MONTH,\n\ -> \REGION,\n\ -> \SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES\n\ -> \GROUP BY GROUPING SETS ( ROLLUP( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE) ),\n\ -> \ROLLUP( MONTH(SALES_DATE), REGION ) )\n\ -> \ORDER BY WEEK, DAY_WEEK, MONTH, REGION" - -> ,"SELECT R1, R2,\n\ -> \WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \MONTH(SALES_DATE) AS MONTH,\n\ -> \REGION, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES,(VALUES('GROUP 1','GROUP 2')) AS X(R1,R2)\n\ -> \GROUP BY GROUPING SETS ((R1, ROLLUP(WEEK(SALES_DATE),\n\ -> \DAYOFWEEK(SALES_DATE))),\n\ -> \(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\ -> \ORDER BY WEEK, DAY_WEEK, MONTH, REGION" - -> {-,"SELECT COALESCE(R1,R2) AS GROUP,\n\ -> \WEEK(SALES_DATE) AS WEEK,\n\ -> \DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\ -> \MONTH(SALES_DATE) AS MONTH,\n\ -> \REGION, SUM(SALES) AS UNITS_SOLD\n\ -> \FROM SALES,(VALUES('GROUP 1','GROUP 2')) AS X(R1,R2)\n\ -> \GROUP BY GROUPING SETS ((R1, ROLLUP(WEEK(SALES_DATE),\n\ -> \DAYOFWEEK(SALES_DATE))),\n\ -> \(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\ -> \ORDER BY GROUP, WEEK, DAY_WEEK, MONTH, REGION"-} -> -- as group - needs more subtle keyword blacklisting - -> -- decimal as a function not allowed due to the reserved keyword -> -- handling: todo, review if this is ansi standard function or -> -- if there are places where reserved keywords can still be used -> ,"SELECT MONTH(SALES_DATE) AS MONTH,\n\ -> \REGION,\n\ -> \SUM(SALES) AS UNITS_SOLD,\n\ -> \MAX(SALES) AS BEST_SALE,\n\ -> \CAST(ROUND(AVG(DECIMALx(SALES)),2) AS DECIMAL(5,2)) AS AVG_UNITS_SOLD\n\ -> \FROM SALES\n\ -> \GROUP BY CUBE(MONTH(SALES_DATE),REGION)\n\ -> \ORDER BY MONTH, REGION" - -> ] diff --git a/tools/Language/SQL/SimpleSQL/MySQL.lhs b/tools/Language/SQL/SimpleSQL/MySQL.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/MySQL.lhs +++ /dev/null @@ -1,40 +0,0 @@ - -Tests for mysql dialect parsing - -> module Language.SQL.SimpleSQL.MySQL (mySQLTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - -> mySQLTests :: TestItem -> mySQLTests = Group "mysql dialect" -> [backtickQuotes -> ,limit] - -backtick quotes - -limit syntax - -[LIMIT {[offset,] row_count | row_count OFFSET offset}] - -> backtickQuotes :: TestItem -> backtickQuotes = Group "backtickQuotes" (map (uncurry (TestValueExpr MySQL)) -> [("`test`", Iden [DQName "`" "`" "test"]) -> ] -> ++ [ParseValueExprFails SQL2011 "`test`"] -> ) - -> limit :: TestItem -> 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"] -> ) -> where -> sel = makeSelect -> {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> } diff --git a/tools/Language/SQL/SimpleSQL/Postgres.lhs b/tools/Language/SQL/SimpleSQL/Postgres.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/Postgres.lhs +++ /dev/null @@ -1,274 +0,0 @@ - -Here are some tests taken from the SQL in the postgres manual. Almost -all of the postgres specific syntax has been skipped, this can be -revisited when the dialect support is added. - -> module Language.SQL.SimpleSQL.Postgres (postgresTests) where - -> import Language.SQL.SimpleSQL.TestTypes - -> postgresTests :: TestItem -> postgresTests = Group "postgresTests" $ map (ParseQueryExpr SQL2011) - -lexical syntax section - -TODO: get all the commented out tests working - -> [-- "SELECT 'foo'\n\ -> -- \'bar';" -- this should parse as select 'foobar' -> -- , -> "SELECT name, (SELECT max(pop) FROM cities\n\ -> \ WHERE cities.state = states.name)\n\ -> \ FROM states;" -> ,"SELECT ROW(1,2.5,'this is a test');" - -> ,"SELECT ROW(t.*, 42) FROM t;" -> ,"SELECT ROW(t.f1, t.f2, 42) FROM t;" -> ,"SELECT getf1(CAST(ROW(11,'this is a test',2.5) AS myrowtype));" - -> ,"SELECT ROW(1,2.5,'this is a test') = ROW(1, 3, 'not the same');" - -> -- table is a reservered keyword? -> --,"SELECT ROW(table.*) IS NULL FROM table;" -> ,"SELECT ROW(tablex.*) IS NULL FROM tablex;" - -> ,"SELECT true OR somefunc();" - -> ,"SELECT somefunc() OR true;" - -queries section - -> ,"SELECT * FROM t1 CROSS JOIN t2;" -> ,"SELECT * FROM t1 INNER JOIN t2 ON t1.num = t2.num;" -> ,"SELECT * FROM t1 INNER JOIN t2 USING (num);" -> ,"SELECT * FROM t1 NATURAL INNER JOIN t2;" -> ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num;" -> ,"SELECT * FROM t1 LEFT JOIN t2 USING (num);" -> ,"SELECT * FROM t1 RIGHT JOIN t2 ON t1.num = t2.num;" -> ,"SELECT * FROM t1 FULL JOIN t2 ON t1.num = t2.num;" -> ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num AND t2.value = 'xxx';" -> ,"SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num WHERE t2.value = 'xxx';" - -> ,"SELECT * FROM some_very_long_table_name s\n\ -> \JOIN another_fairly_long_name a ON s.id = a.num;" -> ,"SELECT * FROM people AS mother JOIN people AS child\n\ -> \ ON mother.id = child.mother_id;" -> ,"SELECT * FROM my_table AS a CROSS JOIN my_table AS b;" -> ,"SELECT * FROM (my_table AS a CROSS JOIN my_table) AS b;" -> ,"SELECT * FROM getfoo(1) AS t1;" -> ,"SELECT * FROM foo\n\ -> \ WHERE foosubid IN (\n\ -> \ SELECT foosubid\n\ -> \ FROM getfoo(foo.fooid) z\n\ -> \ WHERE z.fooid = foo.fooid\n\ -> \ );" -> {-,"SELECT *\n\ -> \ FROM dblink('dbname=mydb', 'SELECT proname, prosrc FROM pg_proc')\n\ -> \ AS t1(proname name, prosrc text)\n\ -> \ WHERE proname LIKE 'bytea%';"-} -- types in the alias?? - -> ,"SELECT * FROM foo, LATERAL (SELECT * FROM bar WHERE bar.id = foo.bar_id) ss;" -> ,"SELECT * FROM foo, bar WHERE bar.id = foo.bar_id;" - -> {-,"SELECT p1.id, p2.id, v1, v2\n\ -> \FROM polygons p1, polygons p2,\n\ -> \ LATERAL vertices(p1.poly) v1,\n\ -> \ LATERAL vertices(p2.poly) v2\n\ -> \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-} -- <-> operator? - -> {-,"SELECT p1.id, p2.id, v1, v2\n\ -> \FROM polygons p1 CROSS JOIN LATERAL vertices(p1.poly) v1,\n\ -> \ polygons p2 CROSS JOIN LATERAL vertices(p2.poly) v2\n\ -> \WHERE (v1 <-> v2) < 10 AND p1.id != p2.id;"-} - -> ,"SELECT m.name\n\ -> \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true\n\ -> \WHERE pname IS NULL;" - - -> ,"SELECT * FROM fdt WHERE c1 > 5" - -> ,"SELECT * FROM fdt WHERE c1 IN (1, 2, 3)" - -> ,"SELECT * FROM fdt WHERE c1 IN (SELECT c1 FROM t2)" - -> ,"SELECT * FROM fdt WHERE c1 IN (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10)" - -> ,"SELECT * FROM fdt WHERE c1 BETWEEN \n\ -> \ (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10) AND 100" - -> ,"SELECT * FROM fdt WHERE EXISTS (SELECT c1 FROM t2 WHERE c2 > fdt.c1)" - -> ,"SELECT * FROM test1;" - -> ,"SELECT x FROM test1 GROUP BY x;" -> ,"SELECT x, sum(y) FROM test1 GROUP BY x;" -> -- s.date changed to s.datex because of reserved keyword -> -- handling, not sure if this is correct or not for ansi sql -> ,"SELECT product_id, p.name, (sum(s.units) * p.price) AS sales\n\ -> \ FROM products p LEFT JOIN sales s USING (product_id)\n\ -> \ GROUP BY product_id, p.name, p.price;" - -> ,"SELECT x, sum(y) FROM test1 GROUP BY x HAVING sum(y) > 3;" -> ,"SELECT x, sum(y) FROM test1 GROUP BY x HAVING x < 'c';" -> ,"SELECT product_id, p.name, (sum(s.units) * (p.price - p.cost)) AS profit\n\ -> \ FROM products p LEFT JOIN sales s USING (product_id)\n\ -> \ WHERE s.datex > CURRENT_DATE - INTERVAL '4 weeks'\n\ -> \ GROUP BY product_id, p.name, p.price, p.cost\n\ -> \ HAVING sum(p.price * s.units) > 5000;" - -> ,"SELECT a, b, c FROM t" - -> ,"SELECT tbl1.a, tbl2.a, tbl1.b FROM t" - -> ,"SELECT tbl1.*, tbl2.a FROM t" - -> ,"SELECT a AS value, b + c AS sum FROM t" - -> ,"SELECT a \"value\", b + c AS sum FROM t" - -> ,"SELECT DISTINCT select_list t" - -> ,"VALUES (1, 'one'), (2, 'two'), (3, 'three');" - -> ,"SELECT 1 AS column1, 'one' AS column2\n\ -> \UNION ALL\n\ -> \SELECT 2, 'two'\n\ -> \UNION ALL\n\ -> \SELECT 3, 'three';" - -> ,"SELECT * FROM (VALUES (1, 'one'), (2, 'two'), (3, 'three')) AS t (num,letter);" - -> ,"WITH regional_sales AS (\n\ -> \ SELECT region, SUM(amount) AS total_sales\n\ -> \ FROM orders\n\ -> \ GROUP BY region\n\ -> \ ), top_regions AS (\n\ -> \ SELECT region\n\ -> \ FROM regional_sales\n\ -> \ WHERE total_sales > (SELECT SUM(total_sales)/10 FROM regional_sales)\n\ -> \ )\n\ -> \SELECT region,\n\ -> \ product,\n\ -> \ SUM(quantity) AS product_units,\n\ -> \ SUM(amount) AS product_sales\n\ -> \FROM orders\n\ -> \WHERE region IN (SELECT region FROM top_regions)\n\ -> \GROUP BY region, product;" - -> ,"WITH RECURSIVE t(n) AS (\n\ -> \ VALUES (1)\n\ -> \ UNION ALL\n\ -> \ SELECT n+1 FROM t WHERE n < 100\n\ -> \)\n\ -> \SELECT sum(n) FROM t" - -> ,"WITH RECURSIVE included_parts(sub_part, part, quantity) AS (\n\ -> \ SELECT sub_part, part, quantity FROM parts WHERE part = 'our_product'\n\ -> \ UNION ALL\n\ -> \ SELECT p.sub_part, p.part, p.quantity\n\ -> \ FROM included_parts pr, parts p\n\ -> \ WHERE p.part = pr.sub_part\n\ -> \ )\n\ -> \SELECT sub_part, SUM(quantity) as total_quantity\n\ -> \FROM included_parts\n\ -> \GROUP BY sub_part" - -> ,"WITH RECURSIVE search_graph(id, link, data, depth) AS (\n\ -> \ SELECT g.id, g.link, g.data, 1\n\ -> \ FROM graph g\n\ -> \ UNION ALL\n\ -> \ SELECT g.id, g.link, g.data, sg.depth + 1\n\ -> \ FROM graph g, search_graph sg\n\ -> \ WHERE g.id = sg.link\n\ -> \)\n\ -> \SELECT * FROM search_graph;" - -> {-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\ -> \ SELECT g.id, g.link, g.data, 1,\n\ -> \ ARRAY[g.id],\n\ -> \ false\n\ -> \ FROM graph g\n\ -> \ UNION ALL\n\ -> \ SELECT g.id, g.link, g.data, sg.depth + 1,\n\ -> \ path || g.id,\n\ -> \ g.id = ANY(path)\n\ -> \ FROM graph g, search_graph sg\n\ -> \ WHERE g.id = sg.link AND NOT cycle\n\ -> \)\n\ -> \SELECT * FROM search_graph;"-} -- ARRAY - -> {-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\ -> \ SELECT g.id, g.link, g.data, 1,\n\ -> \ ARRAY[ROW(g.f1, g.f2)],\n\ -> \ false\n\ -> \ FROM graph g\n\ -> \ UNION ALL\n\ -> \ SELECT g.id, g.link, g.data, sg.depth + 1,\n\ -> \ path || ROW(g.f1, g.f2),\n\ -> \ ROW(g.f1, g.f2) = ANY(path)\n\ -> \ FROM graph g, search_graph sg\n\ -> \ WHERE g.id = sg.link AND NOT cycle\n\ -> \)\n\ -> \SELECT * FROM search_graph;"-} -- ARRAY - -> ,"WITH RECURSIVE t(n) AS (\n\ -> \ SELECT 1\n\ -> \ UNION ALL\n\ -> \ SELECT n+1 FROM t\n\ -> \)\n\ -> \SELECT n FROM t --LIMIT 100;" -- limit is not standard - -select page reference - -> ,"SELECT f.title, f.did, d.name, f.date_prod, f.kind\n\ -> \ FROM distributors d, films f\n\ -> \ WHERE f.did = d.did" - -> ,"SELECT kind, sum(len) AS total\n\ -> \ FROM films\n\ -> \ GROUP BY kind\n\ -> \ HAVING sum(len) < interval '5 hours';" - -> ,"SELECT * FROM distributors ORDER BY name;" -> ,"SELECT * FROM distributors ORDER BY 2;" - -> ,"SELECT distributors.name\n\ -> \ FROM distributors\n\ -> \ WHERE distributors.name LIKE 'W%'\n\ -> \UNION\n\ -> \SELECT actors.name\n\ -> \ FROM actors\n\ -> \ WHERE actors.name LIKE 'W%';" - -> ,"WITH t AS (\n\ -> \ SELECT random() as x FROM generate_series(1, 3)\n\ -> \ )\n\ -> \SELECT * FROM t\n\ -> \UNION ALL\n\ -> \SELECT * FROM t" - -> ,"WITH RECURSIVE employee_recursive(distance, employee_name, manager_name) AS (\n\ -> \ SELECT 1, employee_name, manager_name\n\ -> \ FROM employee\n\ -> \ WHERE manager_name = 'Mary'\n\ -> \ UNION ALL\n\ -> \ SELECT er.distance + 1, e.employee_name, e.manager_name\n\ -> \ FROM employee_recursive er, employee e\n\ -> \ WHERE er.employee_name = e.manager_name\n\ -> \ )\n\ -> \SELECT distance, employee_name FROM employee_recursive;" - -> ,"SELECT m.name AS mname, pname\n\ -> \FROM manufacturers m, LATERAL get_product_names(m.id) pname;" - -> ,"SELECT m.name AS mname, pname\n\ -> \FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true;" - -> ,"SELECT 2+2;" - -> -- simple-sql-parser doesn't support where without from -> -- this can be added for the postgres dialect when it is written -> --,"SELECT distributors.* WHERE distributors.name = 'Westward';" - -> ] diff --git a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs b/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs +++ /dev/null @@ -1,209 +0,0 @@ - -These are the tests for the query expression components apart from the -table refs which are in a separate file. - - -These are a few misc tests which don't fit anywhere else. - -> module Language.SQL.SimpleSQL.QueryExprComponents (queryExprComponentTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - - -> queryExprComponentTests :: TestItem -> queryExprComponentTests = Group "queryExprComponentTests" -> [duplicates -> ,selectLists -> ,whereClause -> ,having -> ,orderBy -> ,offsetFetch -> ,combos -> ,withQueries -> ,values -> ,tables -> ] - - - -> duplicates :: TestItem -> duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a from t" ,ms SQDefault) -> ,("select all a from t" ,ms All) -> ,("select distinct a from t", ms Distinct) -> ] -> where -> ms d = makeSelect -> {qeSetQuantifier = d -> ,qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} - -> selectLists :: TestItem -> selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select 1", -> makeSelect {qeSelectList = [(NumLit "1",Nothing)]}) - -> ,("select a" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)]}) - -> ,("select a,b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing) -> ,(Iden [Name "b"],Nothing)]}) - -> ,("select 1+2,3+4" -> ,makeSelect {qeSelectList = -> [(BinOp (NumLit "1") [Name "+"] (NumLit "2"),Nothing) -> ,(BinOp (NumLit "3") [Name "+"] (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")]}) - -> ,("select a a, b b" -> ,makeSelect {qeSelectList = [(Iden [Name "a"], Just $ Name "a") -> ,(Iden [Name "b"], Just $ Name "b")]}) - -> ,("select a + b * c" -> ,makeSelect {qeSelectList = -> [(BinOp (Iden [Name "a"]) [Name "+"] -> (BinOp (Iden [Name "b"]) [Name "*"] (Iden [Name "c"])) -> ,Nothing)]}) - -> ] - -> whereClause :: TestItem -> whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr SQL2011)) -> [("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")}) -> ] - -> having :: TestItem -> having = Group "having" $ map (uncurry (TestQueryExpr SQL2011)) -> [("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") -> }) -> ] - -> orderBy :: TestItem -> orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a from t order by a" -> ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault]) - -> ,("select a from t order by a, b" -> ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) DirDefault NullsOrderDefault]) - -> ,("select a from t order by a asc" -> ,ms [SortSpec (Iden [Name "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]) - -> ,("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]) - -> ] -> where -> ms o = makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeOrderBy = o} - -> offsetFetch :: TestItem -> offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr SQL2011)) -> [-- ansi standard -> ("select a from t offset 5 rows fetch next 10 rows only" -> ,ms (Just $ NumLit "5") (Just $ NumLit "10")) -> ,("select a from t offset 5 rows;" -> ,ms (Just $ NumLit "5") Nothing) -> ,("select a from t fetch next 10 row only;" -> ,ms Nothing (Just $ NumLit "10")) -> ,("select a from t offset 5 row fetch first 10 row only" -> ,ms (Just $ NumLit "5") (Just $ NumLit "10")) -> -- postgres: disabled, will add back when postgres -> -- dialect is added -> --,("select a from t limit 10 offset 5" -> -- ,ms (Just $ NumLit "5") (Just $ NumLit "10")) -> ] -> where -> ms o l = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeOffset = o -> ,qeFetchFirst = l} - -> combos :: TestItem -> combos = Group "combos" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a from t union select b from u" -> ,CombineQueryExpr ms1 Union SQDefault Respectively ms2) - -> ,("select a from t intersect select b from u" -> ,CombineQueryExpr ms1 Intersect SQDefault Respectively ms2) - -> ,("select a from t except all select b from u" -> ,CombineQueryExpr ms1 Except All Respectively ms2) - -> ,("select a from t union distinct corresponding \ -> \select b from u" -> ,CombineQueryExpr 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)) -> ] -> where -> ms1 = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} -> ms2 = makeSelect -> {qeSelectList = [(Iden [Name "b"],Nothing)] -> ,qeFrom = [TRSimple [Name "u"]]} - - -> withQueries :: TestItem -> withQueries = Group "with queries" $ map (uncurry (TestQueryExpr SQL2011)) -> [("with u as (select a from t) select a from u" -> ,With False [(Alias (Name "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 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 recursive u as (select a from t) select a from u" -> ,With True [(Alias (Name "u") Nothing, ms1)] ms2) -> ] -> where -> ms c t = makeSelect -> {qeSelectList = [(Iden [Name c],Nothing)] -> ,qeFrom = [TRSimple [Name t]]} -> ms1 = ms "a" "t" -> ms2 = ms "a" "u" -> ms3 = ms "a" "x" - -> values :: TestItem -> values = Group "values" $ map (uncurry (TestQueryExpr SQL2011)) -> [("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"]) -> ] diff --git a/tools/Language/SQL/SimpleSQL/QueryExprs.lhs b/tools/Language/SQL/SimpleSQL/QueryExprs.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/QueryExprs.lhs +++ /dev/null @@ -1,18 +0,0 @@ - -These are the tests for the queryExprs parsing which parses multiple -query expressions from one string. - -> module Language.SQL.SimpleSQL.QueryExprs (queryExprsTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - -> queryExprsTests :: TestItem -> queryExprsTests = Group "query exprs" $ map (uncurry (TestQueryExprs SQL2011)) -> [("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)]} 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 - - ::= - - | - |
::= - - ::= - - ::= [ ] - - ::= - - ::= - - ::= [ ] - - ::= - [ ] - - ::= | - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - [ ] - - ::= MODULE - - ::= - - ::= - - ::= - - ::= | - - ::= - - ::= - - ::= [ ] - - ::= - - ::= - - ::= - - ::= [ ] - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= - - ::= | - - ::= - - ::= [ ] - - ::= | - - ::= [ ] - - ::= - - | - - ::= - - ::= [ ] - - ::= GLOBAL | LOCAL - - ::= - -= 6 Scalar expressions - -== 6.1 - -Function -Specify a data type. - - ::= - - | - | - | - | - - ::= - [ CHARACTER SET ] - [ ] - | [ ] - | - | - | - | - | - - ::= - CHARACTER [ ] - | CHAR [ ] - | CHARACTER VARYING - | CHAR VARYING - | VARCHAR - | - - ::= - CHARACTER LARGE OBJECT [ ] - | CHAR LARGE OBJECT [ ] - | CLOB [ ] - - ::= - NATIONAL CHARACTER [ ] - | NATIONAL CHAR [ ] - | NCHAR [ ] - | NATIONAL CHARACTER VARYING - | NATIONAL CHAR VARYING - | NCHAR VARYING - | - - ::= - NATIONAL CHARACTER LARGE OBJECT [ ] - | NCHAR LARGE OBJECT [ ] - | NCLOB [ ] - - ::= - BINARY [ ] - | BINARY VARYING - | VARBINARY - | - - ::= - BINARY LARGE OBJECT [ ] - | BLOB [ ] - - ::= | - - ::= - NUMERIC [ [ ] ] - | DECIMAL [ [ ] ] - | DEC [ [ ] ] - | SMALLINT - | INTEGER - | INT - | BIGINT - - ::= - FLOAT [ ] - | REAL - | DOUBLE PRECISION - - ::= - - ::= [ ] - - ::= - [ ] - | - - ::= - [ ] - - ::= CHARACTERS | OCTETS - - ::= - - ::= - - ::= BOOLEAN - - ::= - DATE - | TIME [
- - ::= - - ::= - - ::= | - - ::= - ARRAY - [ ] - - ::= - - ::= MULTISET - -TODO: below, add new stuff: -review the length syntaxes -binary, binary varying/varbinary -new multipliers - -create a list of type name variations: - -> typeNames :: [(String,TypeName)] -> typeNames = -> basicTypes -> ++ concatMap makeArray basicTypes -> ++ map makeMultiset basicTypes -> where -> makeArray (s,t) = [(s ++ " array", ArrayTypeName t Nothing) -> ,(s ++ " array[5]", ArrayTypeName t (Just 5))] -> makeMultiset (s,t) = (s ++ " multiset", MultisetTypeName t) -> basicTypes = -> -- example of every standard type name -> map (\t -> (t,TypeName [Name t])) -> ["binary" -> ,"binary varying" -> ,"character" -> ,"char" -> ,"character varying" -> ,"char varying" -> ,"varbinary" -> ,"varchar" -> ,"character large object" -> ,"char large object" -> ,"clob" -> ,"national character" -> ,"national char" -> ,"nchar" -> ,"national character varying" -> ,"national char varying" -> ,"nchar varying" -> ,"national character large object" -> ,"nchar large object" -> ,"nclob" -> ,"binary large object" -> ,"blob" -> ,"numeric" -> ,"decimal" -> ,"dec" -> ,"smallint" -> ,"integer" -> ,"int" -> ,"bigint" -> ,"float" -> ,"real" -> ,"double precision" -> ,"boolean" -> ,"date" -> ,"time" -> ,"timestamp"] -> --interval -- not allowed without interval qualifier -> --row -- not allowed without row type body -> -- array -- not allowed on own -> -- multiset -- not allowed on own - -> ++ -> [-- 1 single prec + 1 with multiname -> ("char(5)", PrecTypeName [Name "char"] 5) -> ,("char varying(5)", PrecTypeName [Name "char varying"] 5) -> -- 1 scale -> ,("decimal(15,2)", PrecScaleTypeName [Name "decimal"] 15 2) -> ,("char(3 octets)" -> ,PrecLengthTypeName [Name "char"] 3 Nothing (Just PrecOctets)) -> ,("varchar(50 characters)" -> ,PrecLengthTypeName [Name "varchar"] 50 Nothing (Just PrecCharacters)) -> -- lob prec + with multiname -> ,("blob(3M)", PrecLengthTypeName [Name "blob"] 3 (Just PrecM) Nothing) -> ,("blob(3T)", PrecLengthTypeName [Name "blob"] 3 (Just PrecT) Nothing) -> ,("blob(3P)", PrecLengthTypeName [Name "blob"] 3 (Just PrecP) Nothing) -> ,("blob(4M characters) " -> ,PrecLengthTypeName [Name "blob"] 4 (Just PrecM) (Just PrecCharacters)) -> ,("blob(6G octets) " -> ,PrecLengthTypeName [Name "blob"] 6 (Just PrecG) (Just PrecOctets)) -> ,("national character large object(7K) " -> ,PrecLengthTypeName [Name "national character large object"] -> 7 (Just PrecK) Nothing) -> -- 1 with and without tz -> ,("time with time zone" -> ,TimeTypeName [Name "time"] Nothing True) -> ,("datetime(3) without time zone" -> ,TimeTypeName [Name "datetime"] (Just 3) False) -> -- chars: (single/multiname) x prec x charset x collate -> -- 1111 -> ,("char varying(5) character set something collate something_insensitive" -> ,CharTypeName [Name "char varying"] (Just 5) -> [Name "something"] [Name "something_insensitive"]) -> -- 0111 -> ,("char(5) character set something collate something_insensitive" -> ,CharTypeName [Name "char"] (Just 5) -> [Name "something"] [Name "something_insensitive"]) - -> -- 1011 -> ,("char varying character set something collate something_insensitive" -> ,CharTypeName [Name "char varying"] Nothing -> [Name "something"] [Name "something_insensitive"]) -> -- 0011 -> ,("char character set something collate something_insensitive" -> ,CharTypeName [Name "char"] Nothing -> [Name "something"] [Name "something_insensitive"]) - -> -- 1101 -> ,("char varying(5) collate something_insensitive" -> ,CharTypeName [Name "char varying"] (Just 5) -> [] [Name "something_insensitive"]) -> -- 0101 -> ,("char(5) collate something_insensitive" -> ,CharTypeName [Name "char"] (Just 5) -> [] [Name "something_insensitive"]) -> -- 1001 -> ,("char varying collate something_insensitive" -> ,CharTypeName [Name "char varying"] Nothing -> [] [Name "something_insensitive"]) -> -- 0001 -> ,("char collate something_insensitive" -> ,CharTypeName [Name "char"] Nothing -> [] [Name "something_insensitive"]) - -> -- 1110 -> ,("char varying(5) character set something" -> ,CharTypeName [Name "char varying"] (Just 5) -> [Name "something"] []) -> -- 0110 -> ,("char(5) character set something" -> ,CharTypeName [Name "char"] (Just 5) -> [Name "something"] []) -> -- 1010 -> ,("char varying character set something" -> ,CharTypeName [Name "char varying"] Nothing -> [Name "something"] []) -> -- 0010 -> ,("char character set something" -> ,CharTypeName [Name "char"] Nothing -> [Name "something"] []) -> -- 1100 -> ,("char varying character set something" -> ,CharTypeName [Name "char varying"] Nothing -> [Name "something"] []) - -> -- single row field, two row field -> ,("row(a int)", RowTypeName [(Name "a", TypeName [Name "int"])]) -> ,("row(a int,b char)" -> ,RowTypeName [(Name "a", TypeName [Name "int"]) -> ,(Name "b", TypeName [Name "char"])]) -> -- interval each type raw -> ,("interval year" -> ,IntervalTypeName (Itf "year" Nothing) Nothing) -> -- one type with single suffix -> -- one type with double suffix -> ,("interval year(2)" -> ,IntervalTypeName (Itf "year" $ Just (2,Nothing)) Nothing) -> ,("interval second(2,5)" -> ,IntervalTypeName (Itf "second" $ Just (2,Just 5)) Nothing) -> -- a to b with raw -> -- a to b with single suffix -> ,("interval year to month" -> ,IntervalTypeName (Itf "year" Nothing) -> (Just $ Itf "month" Nothing)) -> ,("interval year(4) to second(2,3)" -> ,IntervalTypeName (Itf "year" $ Just (4,Nothing)) -> (Just $ Itf "second" $ Just (2, Just 3))) -> ] - -Now test each variation in both cast expression and typed literal -expression - -> typeNameTests :: TestItem -> typeNameTests = Group "type names" $ map (uncurry (TestValueExpr SQL2011)) -> $ concatMap makeTests typeNames -> where -> makeTests (ctn, stn) = -> [("cast('test' as " ++ ctn ++ ")", Cast (StringLit "test") stn) -> ,(ctn ++ " 'test'", TypedLit stn "test") -> ] - - -== 6.2 - -Function -Define a field of a row type. - - ::= - -> fieldDefinition :: TestItem -> fieldDefinition = Group "field definition" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("cast('(1,2)' as row(a int,b char))" -> ,Cast (StringLit "(1,2)") -> $ RowTypeName [(Name "a", TypeName [Name "int"]) -> ,(Name "b", TypeName [Name "char"])])] - -== 6.3 - -Function -Specify a value that is syntactically self-delimited. - - ::= - - | - - ::= - - - ::= - - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - - ::= - - | - -> valueExpressions :: TestItem -> valueExpressions = Group "value expressions" -> [generalValueSpecification -> ,parameterSpecification -> ,contextuallyTypedValueSpecification -> ,identifierChain -> ,columnReference -> ,setFunctionSpecification -> ,windowFunction -> ,nestedWindowFunction -> ,caseExpression -> ,castSpecification -> ,nextValueExpression -> ,fieldReference -> ,arrayElementReference -> ,multisetElementReference -> ,numericValueExpression -> ,numericValueFunction -> ,stringValueExpression -> ,stringValueFunction -> ,datetimeValueExpression -> ,datetimeValueFunction -> ,intervalValueExpression -> ,intervalValueFunction -> ,booleanValueExpression -> ,arrayValueExpression -> ,arrayValueFunction -> ,arrayValueConstructor -> ,multisetValueExpression -> ,multisetValueFunction -> ,multisetValueConstructor -> ,parenthesizedValueExpression -> ] - -> parenthesizedValueExpression :: TestItem -> parenthesizedValueExpression = Group "parenthesized value expression" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("(3)", Parens (NumLit "3")) -> ,("((3))", Parens $ Parens (NumLit "3")) -> ] - -== 6.4 and - -Function -Specify one or more values, host parameters, SQL parameters, dynamic parameters, or host variables. - - ::= | - - ::= - - | - - ::= - - | - | - | - | - | CURRENT_CATALOG - | CURRENT_DEFAULT_TRANSFORM_GROUP - | CURRENT_PATH - | CURRENT_ROLE - | CURRENT_SCHEMA - | CURRENT_TRANSFORM_GROUP_FOR_TYPE - | CURRENT_USER - | SESSION_USER - | SYSTEM_USER - | USER - | VALUE - -> generalValueSpecification :: TestItem -> generalValueSpecification = Group "general value specification" -> $ map (uncurry (TestValueExpr SQL2011)) $ -> map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP" -> ,"CURRENT_PATH" -> ,"CURRENT_ROLE" -> ,"CURRENT_USER" -> ,"SESSION_USER" -> ,"SYSTEM_USER" -> ,"USER" -> ,"VALUE"] -> where -> mkIden nm = (nm,Iden [Name nm]) - -TODO: add the missing bits - - ::= - - | - | - | - - ::= - - | - | - | - | - | - - ::= - - | - | - | - - ::= - [ ] - - ::= - - ::= - [ ] - - ::= [ INDICATOR ] - - ::= [ INDICATOR ] - - ::= - - - - ::= | - -> parameterSpecification :: TestItem -> parameterSpecification = Group "parameter specification" -> $ map (uncurry (TestValueExpr SQL2011)) -> [(":hostparam", HostParameter "hostparam" Nothing) -> ,(":hostparam indicator :another_host_param" -> ,HostParameter "hostparam" $ Just "another_host_param") -> ,("?", Parameter) -> ,(":h[3]", Array (HostParameter "h" Nothing) [NumLit "3"]) -> ] - - ::= - COLLATION FOR - -TODO: review the modules stuff - -== 6.5 - -Function -Specify a value whose data type is to be inferred from its context. - - ::= - - | - - ::= - - | - - ::= NULL - - ::= - ARRAY - | MULTISET - - ::= DEFAULT - -> contextuallyTypedValueSpecification :: TestItem -> contextuallyTypedValueSpecification = -> Group "contextually typed value specification" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("null", Iden [Name "null"]) -> ,("array[]", Array (Iden [Name "array"]) []) -> ,("multiset[]", MultisetCtor []) -> ,("default", Iden [Name "default"]) -> ] - -== 6.6 - -Function -Disambiguate a -separated chain of identifiers. - - ::= [ { }... ] - - ::= - -> identifierChain :: TestItem -> identifierChain = Group "identifier chain" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("a.b", Iden [Name "a",Name "b"])] - -== 6.7 - -Function -Reference a column. - - ::= - - | MODULE - -> columnReference :: TestItem -> columnReference = Group "column reference" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("module.a.b", Iden [Name "module",Name "a",Name "b"])] - -== 6.8 - -Function -Reference an SQL parameter. - - ::= - -== 6.9 - -Function -Specify a value derived by the application of a function to an argument. - - ::= | - - ::= - GROUPING - [ { }... ] - -> setFunctionSpecification :: TestItem -> setFunctionSpecification = Group "set function specification" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\ -> \ GROUPING(SalesQuota) AS Grouping\n\ -> \FROM Sales.SalesPerson\n\ -> \GROUP BY ROLLUP(SalesQuota);" -> ,makeSelect -> {qeSelectList = [(Iden [Name "SalesQuota"],Nothing) -> ,(App [Name "SUM"] [Iden [Name "SalesYTD"]] -> ,Just (Name "TotalSalesYTD")) -> ,(App [Name "GROUPING"] [Iden [Name "SalesQuota"]] -> ,Just (Name "Grouping"))] -> ,qeFrom = [TRSimple [Name "Sales",Name "SalesPerson"]] -> ,qeGroupBy = [Rollup [SimpleGroup (Iden [Name "SalesQuota"])]]}) -> ] - -== 6.10 - -Function -Specify a window function. - - ::= - OVER - - ::= - - | ROW_NUMBER - | - | - | - | - | - - ::= RANK | DENSE_RANK | PERCENT_RANK | CUME_DIST - - ::= NTILE - - ::= - - | - - ::= - - [ [ ] ] - [ ] - - ::= LEAD | LAG - - ::= - - ::= - - ::= - - ::= RESPECT NULLS | IGNORE NULLS - - ::= - [ - ] - - ::= FIRST_VALUE | LAST_VALUE - - ::= - NTH_VALUE - [ ] [ ] - - ::= | - - ::= FROM FIRST | FROM LAST - - ::= - - | - - ::= - -> windowFunction :: TestItem -> windowFunction = Group "window function" -> [-- todo: window function -> ] - -== 6.11 - -Function - -Specify a function nested in an aggregated argument of an - simply contained in a . - - ::= - - | - - ::= - ROW_NUMBER - - ::= - VALUE_OF AT - [ ] - - ::= - BEGIN_PARTITION - | BEGIN_FRAME - | CURRENT_ROW - | FRAME_ROW - | END_FRAME - | END_PARTITION - - ::= [ ] - - ::= - - | - - ::= - - | - - ::= - -> nestedWindowFunction :: TestItem -> nestedWindowFunction = Group "nested window function" -> [-- todo: nested window function -> ] - - -== 6.12 - -Function -Specify a conditional value. - - ::= | - - ::= - NULLIF - | COALESCE - { }... - - ::= | - - ::= - CASE ... [ ] END - - ::= CASE ... [ ] END - - ::= WHEN THEN - - ::= WHEN THEN - - ::= ELSE - - ::= | - - ::= [ { }... ] - - ::= - - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - -I haven't seen these part 2 style when operands in the wild. It -doesn't even allow all the binary operators here. We will allow them -all, and parser and represent these expressions by considering all the -binary ops as unary prefix ops. - - ::= | NULL - - ::= - -> caseExpression :: TestItem -> caseExpression = Group "case expression" -> [-- todo: case expression -> ] - -== 6.13 - -Function -Specify a data conversion. - - ::= - CAST AS - - ::= | - - ::= | - -> castSpecification :: TestItem -> castSpecification = Group "cast specification" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("cast(a as int)" -> ,Cast (Iden [Name "a"]) (TypeName [Name "int"])) -> ] - -== 6.14 - -Function -Return the next value of a sequence generator. - - ::= NEXT VALUE FOR - -> nextValueExpression :: TestItem -> nextValueExpression = Group "next value expression" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("next value for a.b", NextValueFor [Name "a", Name "b"]) -> ] - -== 6.15 - -Function -Reference a field of a row value. - - ::= - -> fieldReference :: TestItem -> fieldReference = Group "field reference" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("f(something).a" -> ,BinOp (App [Name "f"] [Iden [Name "something"]]) -> [Name "."] -> (Iden [Name "a"])) -> ] - -TODO: try all possible value expression syntax variations followed by -field reference - -== 6.16 - -Function -Modify the declared type of an expression. - - ::= - TREAT AS - - ::= - - ::= | - -todo: subtype treatment - -== 6.17 - -Function -Reference an SQL-invoked method of a user-defined type value. - - ::= | - - ::= - [ ] - - ::= - AS - [ ] - - ::= - - ::= - -todo: method invocation - -== 6.18 - -Function -Invoke a static method. - - ::= - - [ ] - - ::= - -todo: static method invocation - -== 6.19 - -Function -Invoke a method on a newly-constructed value of a structured type. - - ::= - NEW - - ::= | - -todo: new specification - -== 6.20 - -Function -Return a value acquired by accessing a column of the row identified by -a value of a reference type or by invoking an SQL-invoked method. - - ::= - - [ ] - - ::= - -todo: attribute of method reference - -== 6.21 - -Function -Access a column of the row identified by a value of a reference type. - - ::= - - -todo: deference operation - -== 6.22 - -Function -Return a value acquired from invoking an SQL-invoked routine that is a method. - - ::= - - -todo: method reference - -== 6.23 - -Function -Obtain the value referenced by a reference value. - - ::= - DEREF - -todo: reference resolution - -== 6.24 - -Function -Return an element of an array. - - ::= - - - -> arrayElementReference :: TestItem -> arrayElementReference = Group "array element reference" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("something[3]" -> ,Array (Iden [Name "something"]) [NumLit "3"]) -> ,("(something(a))[x]" -> ,Array (Parens (App [Name "something"] [Iden [Name "a"]])) -> [Iden [Name "x"]]) -> ,("(something(a))[x][y] " -> ,Array ( -> Array (Parens (App [Name "something"] [Iden [Name "a"]])) -> [Iden [Name "x"]]) -> [Iden [Name "y"]]) -> ] - -== 6.25 - -Function -Return the sole element of a multiset of one element. - - ::= - ELEMENT - -> multisetElementReference :: TestItem -> multisetElementReference = Group "multisetElementReference" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("element(something)" -> ,App [Name "element"] [Iden [Name "something"]]) -> ] - -== 6.26 - -Function -Specify a value. - - ::= - - | - | - - ::= - - | - | - | - | - | - | - - ::= - - ::= - - ::= - - | - -== 6.27 - -Function -Specify a numeric value. - - ::= - - | - | - - ::= | | - - ::= [ ] - - ::= | - -> numericValueExpression :: TestItem -> numericValueExpression = Group "numeric value expression" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("a + b", binOp "+") -> ,("a - b", binOp "-") -> ,("a * b", binOp "*") -> ,("a / b", binOp "/") -> ,("+a", prefOp "+") -> ,("-a", prefOp "-") -> ] -> where -> binOp o = BinOp (Iden [Name "a"]) [Name o] (Iden [Name "b"]) -> prefOp o = PrefixOp [Name o] (Iden [Name "a"]) - -TODO: precedence and associativity tests (need to review all operators -for what precendence and associativity tests to write) - -== 6.28 - -Function -Specify a function yielding a value of type numeric. - - ::= - - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - - -> numericValueFunction :: TestItem -> numericValueFunction = Group "numeric value function" -> [-- todo: numeric value function -> ] - - ::= - - | - - ::= - OCCURRENCES_REGEX - [ FLAG ] - IN - [ FROM ] - [ USING ] - - - ::= - - ::= - - ::= - - ::= - POSITION_REGEX - [ ] - [ FLAG ] - IN - [ FROM ] - [ USING ] - [ OCCURRENCE ] - [ GROUP ] - - - ::= START | AFTER - - ::= - - ::= - - ::= - POSITION IN - [ USING ] - - ::= - - ::= - - ::= - POSITION IN - - ::= | - - ::= - { CHAR_LENGTH | CHARACTER_LENGTH } - [ USING ] - - ::= - OCTET_LENGTH - - ::= - EXTRACT FROM - - ::= |
- -> arrayValueConstructor :: TestItem -> arrayValueConstructor = Group "array value constructor" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("array[1,2,3]" -> ,Array (Iden [Name "array"]) -> [NumLit "1", NumLit "2", NumLit "3"]) -> ,("array[a,b,c]" -> ,Array (Iden [Name "array"]) -> [Iden [Name "a"], Iden [Name "b"], Iden [Name "c"]]) -> ,("array(select * from t)" -> ,ArrayCtor (makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]})) -> ,("array(select * from t order by a)" -> ,ArrayCtor (makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeOrderBy = [SortSpec (Iden [Name "a"]) -> DirDefault NullsOrderDefault]})) -> ] - - -== 6.39 - -Function -Specify a multiset value. - - ::= - - | MULTISET UNION [ ALL | DISTINCT ] - | MULTISET EXCEPT [ ALL | DISTINCT ] - - ::= - - | MULTISET INTERSECT [ ALL | DISTINCT ] - - ::= | - -> multisetValueExpression :: TestItem -> multisetValueExpression = Group "multiset value expression" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("a multiset union b" -> ,MultisetBinOp (Iden [Name "a"]) Union SQDefault (Iden [Name "b"])) -> ,("a multiset union all b" -> ,MultisetBinOp (Iden [Name "a"]) Union All (Iden [Name "b"])) -> ,("a multiset union distinct b" -> ,MultisetBinOp (Iden [Name "a"]) Union Distinct (Iden [Name "b"])) -> ,("a multiset except b" -> ,MultisetBinOp (Iden [Name "a"]) Except SQDefault (Iden [Name "b"])) -> ,("a multiset intersect b" -> ,MultisetBinOp (Iden [Name "a"]) Intersect SQDefault (Iden [Name "b"])) -> ] - -TODO: check precedence and associativity - -== 6.40 - -Function -Specify a function yielding a value of a multiset type. - - ::= - - ::= - SET - -> multisetValueFunction :: TestItem -> multisetValueFunction = Group "multiset value function" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("set(a)", App [Name "set"] [Iden [Name "a"]]) -> ] - -== 6.41 - -Function -Specify construction of a multiset. - - ::= - - | - |
- - ::= - MULTISET - - ::= - [ { }... ] - - ::= - - ::= MULTISET
- -
::= TABLE
- -> multisetValueConstructor :: TestItem -> multisetValueConstructor = Group "multiset value constructor" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("multiset[a,b,c]", MultisetCtor[Iden [Name "a"] -> ,Iden [Name "b"], Iden [Name "c"]]) -> ,("multiset(select * from t)", MultisetQueryCtor qe) -> ,("table(select * from t)", MultisetQueryCtor qe) -> ] -> where -> qe = makeSelect {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} - - -= 7 Query expressions - -> queryExpressions :: TestItem -> queryExpressions = Group "query expressions" -> [rowValueConstructor -> ,tableValueConstructor -> ,fromClause -> ,tableReference -> ,joinedTable -> ,whereClause -> ,groupByClause -> ,havingClause -> ,windowClause -> ,querySpecification -> ,withQueryExpression -> ,setOpQueryExpression -> ,explicitTableQueryExpression -> ,orderOffsetFetchQueryExpression -> ,searchOrCycleClause -> ] - - -== 7.1 - -Function -Specify a value or list of values to be constructed into a row. - - ::= - - | - | - - ::= - - - | ROW - | - - ::= - [ { }... ] - - ::= - - ::= - - | - | - | - | - - | ROW - - ::= - - [ { }... ] - - ::= - - | - - ::= - - | - | - -> rowValueConstructor :: TestItem -> rowValueConstructor = Group "row value constructor" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("(a,b)" -> ,SpecialOp [Name "rowctor"] [Iden [Name "a"], Iden [Name "b"]]) -> ,("row(1)",App [Name "row"] [NumLit "1"]) -> ,("row(1,2)",App [Name "row"] [NumLit "1",NumLit "2"]) -> ] - -== 7.2 - -Function -Specify a row value. - - ::= - - | - -
::= - - | - - ::= - - | - - ::= - - | - - ::= - -There is nothing new here. - -== 7.3
- -Function -Specify a set of s to be constructed into a table. - -
::= VALUES - - ::= -
[ {
}... ] - - ::= - VALUES - - ::= - - [ { }... ] - -> tableValueConstructor :: TestItem -> tableValueConstructor = Group "table value constructor" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("values (1,2), (a+b,(select count(*) from t));" -> ,Values [[NumLit "1", NumLit "2"] -> ,[BinOp (Iden [Name "a"]) [Name "+"] -> (Iden [Name "b"]) -> ,SubQueryExpr SqSq -> (makeSelect -> {qeSelectList = [(App [Name "count"] [Star],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]})]]) -> ] - -== 7.4
- -Function -Specify a table or a grouped table. - -
::= - - [ ] - [ ] - [ ] - [ ] - -== 7.5 - -Function -Specify a table derived from one or more tables. - - ::= FROM
- -
::= -
[ {
}... ] - -> fromClause :: TestItem -> fromClause = Group "fromClause" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from tbl1,tbl2" -> ,makeSelect -> {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [TRSimple [Name "tbl1"], TRSimple [Name "tbl2"]] -> })] - - -== 7.6
- -Function -Reference a table. - -> tableReference :: TestItem -> tableReference = Group "table reference" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from t", sel) - -
::=
| - -
::=
[ ] - - ::= - TABLESAMPLE - [ ] - - ::= BERNOULLI | SYSTEM - - ::= REPEATABLE - - ::= - - ::= - -
::= -
[ ] - [ [ AS ] - [ ] ] - | [ AS ] - [ ] - | [ AS ] - [ ] - | [ AS ] - [ ] - |
[ AS ] - [ ] - | [ [ AS ] - [ ] ] - | [ [ AS ] - [ ] ] - | - - ::= - FOR SYSTEM_TIME AS OF - | FOR SYSTEM_TIME BETWEEN [ ASYMMETRIC | SYMMETRIC ] - AND - | FOR SYSTEM_TIME FROM TO - -TODO: query system time period spec - - ::= - - ::= - - ::= - - ::= ONLY
- -TODO: only - - ::= LATERAL
- - ::= - UNNEST - [ { }... ] - [ WITH ORDINALITY ] - -
::= - TABLE - - ::=
- -
::=
| | - - ::= - - ::= [ { }... ] - - ::= - TABLE - - ::= - - | - | - | - - ::= FINAL | NEW | OLD - - ::= - - | - - -> -- table or query name -> ,("select * from t u", a sel) -> ,("select * from t as u", a sel) -> ,("select * from t u(a,b)", sel1 ) -> ,("select * from t as u(a,b)", sel1) -> -- derived table TODO: realistic example -> ,("select * from (select * from t) u" -> ,a $ sel {qeFrom = [TRQueryExpr sel]}) -> -- lateral TODO: realistic example -> ,("select * from lateral t" -> ,af TRLateral sel) -> -- TODO: bug, lateral should bind more tightly than the alias -> --,("select * from lateral t u" -> -- ,a $ af sel TRLateral) -> -- collection TODO: realistic example -> -- TODO: make it work -> --,("select * from unnest(a)", undefined) -> --,("select * from unnest(a,b)", undefined) -> --,("select * from unnest(a,b) with ordinality", undefined) -> --,("select * from unnest(a,b) with ordinality u", undefined) -> --,("select * from unnest(a,b) with ordinality as u", undefined) -> -- table fn TODO: realistic example -> -- TODO: make it work -> --,("select * from table(a)", undefined) -> -- parens -> ,("select * from (a join b)", jsel) -> ,("select * from (a join b) u", a jsel) -> ,("select * from ((a join b)) u", a $ af TRParens jsel) -> ,("select * from ((a join b) u) u", a $ af TRParens $ a jsel) -> ] -> where -> sel = makeSelect -> {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} -> af f s = s {qeFrom = map f (qeFrom s)} -> a s = af (\x -> TRAlias x $ Alias (Name "u") Nothing) s -> sel1 = makeSelect -> {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [TRAlias (TRSimple [Name "t"]) -> $ Alias (Name "u") $ Just [Name "a", Name "b"]]} -> jsel = sel {qeFrom = -> [TRParens $ TRJoin (TRSimple [Name "a"]) -> False -> JInner -> (TRSimple [Name "b"]) -> Nothing]} - -== 7.7 - -Function -Specify a table derived from a Cartesian product, inner join, or outer join. - - ::= | | - - ::=
CROSS JOIN
- - ::= - {
| } - [ ] JOIN - {
| } - - - ::= -
PARTITION BY - - - ::= - - [ { }... ] - - - ::= - - ::= - {
| } - NATURAL [ ] JOIN - {
| } - - ::= | - - ::= ON - - ::= USING - - ::= INNER | [ OUTER ] - - ::= LEFT | RIGHT | FULL - - ::= - -> joinedTable :: TestItem -> joinedTable = Group "joined table" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from a cross join b" -> ,sel $ TRJoin a False JCross b Nothing) -> ,("select * from a join b on true" -> ,sel $ TRJoin a False JInner b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a join b using (c)" -> ,sel $ TRJoin a False JInner b -> (Just $ JoinUsing [Name "c"])) -> ,("select * from a inner join b on true" -> ,sel $ TRJoin a False JInner b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a left join b on true" -> ,sel $ TRJoin a False JLeft b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a left outer join b on true" -> ,sel $ TRJoin a False JLeft b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a right join b on true" -> ,sel $ TRJoin a False JRight b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a full join b on true" -> ,sel $ TRJoin a False JFull b -> (Just $ JoinOn $ Iden [Name "true"])) -> ,("select * from a natural join b" -> ,sel $ TRJoin a True JInner b Nothing) -> ,("select * from a natural inner join b" -> ,sel $ TRJoin a True JInner b Nothing) -> ,("select * from a natural left join b" -> ,sel $ TRJoin a True JLeft b Nothing) -> ,("select * from a natural left outer join b" -> ,sel $ TRJoin a True JLeft b Nothing) -> ,("select * from a natural right join b" -> ,sel $ TRJoin a True JRight b Nothing) -> ,("select * from a natural full join b" -> ,sel $ TRJoin a True JFull b Nothing) -> ] -> where -> sel t = makeSelect -> {qeSelectList = [(Star, Nothing)] -> ,qeFrom = [t]} -> a = TRSimple [Name "a"] -> b = TRSimple [Name "b"] - -TODO: partitioned joins - -== 7.8 - -Function - -Specify a table derived by the application of a to -the result of the preceding . - - ::= WHERE - -> whereClause :: TestItem -> whereClause = Group "where clause" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from t where a = 5" -> ,makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeWhere = Just $ BinOp (Iden [Name "a"]) [Name "="] (NumLit "5")})] - -== 7.9 - -Function - -Specify a grouped table derived by the application of the to the result of the previously specified clause. - - ::= GROUP BY [ ] - - ::= - [ { }... ] - - ::= - - | - | - | - | - - ::= - - | - - ::= [ ] - - ::= - [ { }... ] - - ::= - ROLLUP - - ::= - [ { }... ] - - ::= CUBE - - ::= - GROUPING SETS - - ::= [ { }... ] - - ::= - - | - | - | - | - - ::= - - -> groupByClause :: TestItem -> groupByClause = Group "group by clause" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a,sum(x) from t group by a" -> ,qe [SimpleGroup $ Iden [Name "a"]]) -> ,("select a,sum(x) from t group by a collate c" -> ,qe [SimpleGroup $ Collate (Iden [Name "a"]) [Name "c"]]) -> ,("select a,b,sum(x) from t group by a,b" -> ,qex [SimpleGroup $ Iden [Name "a"] -> ,SimpleGroup $ Iden [Name "b"]]) -> -- todo: group by set quantifier -> --,("select a,sum(x) from t group by distinct a" -> --,undefined) -> --,("select a,sum(x) from t group by all a" -> -- ,undefined) -> ,("select a,b,sum(x) from t group by rollup(a,b)" -> ,qex [Rollup [SimpleGroup $ Iden [Name "a"] -> ,SimpleGroup $ Iden [Name "b"]]]) -> ,("select a,b,sum(x) from t group by cube(a,b)" -> ,qex [Cube [SimpleGroup $ Iden [Name "a"] -> ,SimpleGroup $ Iden [Name "b"]]]) -> ,("select a,b,sum(x) from t group by grouping sets((),(a,b))" -> ,qex [GroupingSets [GroupingParens [] -> ,GroupingParens [SimpleGroup $ Iden [Name "a"] -> ,SimpleGroup $ Iden [Name "b"]]]]) -> ,("select sum(x) from t group by ()" -> ,let x = qe [GroupingParens []] -> in x {qeSelectList = tail $ qeSelectList x}) -> ] -> where -> qe g = makeSelect -> {qeSelectList = [(Iden [Name "a"], Nothing) -> ,(App [Name "sum"] [Iden [Name "x"]], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = g} -> qex g = let x = qe g -> in x {qeSelectList = let [a,b] = qeSelectList x -> in [a,(Iden [Name "b"],Nothing),b]} - -== 7.10 - -Function - -Specify a grouped table derived by the elimination of groups that do -not satisfy a . - - ::= HAVING - -> havingClause :: TestItem -> havingClause = Group "having clause" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a,sum(x) from t group by a having sum(x) > 1000" -> ,makeSelect -> {qeSelectList = [(Iden [Name "a"], Nothing) -> ,(App [Name "sum"] [Iden [Name "x"]], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeGroupBy = [SimpleGroup $ Iden [Name "a"]] -> ,qeHaving = Just $ BinOp (App [Name "sum"] [Iden [Name "x"]]) -> [Name ">"] -> (NumLit "1000")}) -> ] - -== 7.11 - -Function -Specify one or more window definitions. - - ::= WINDOW - - ::= - [ { }... ] - - ::= AS - - ::= - - ::= - - - ::= - [ ] - [ ] - [ ] - [ ] - - ::= - - ::= - PARTITION BY - - ::= - - [ { }... ] - - ::= [ ] - - ::= ORDER BY - - ::= - - [ ] - - ::= ROWS | RANGE | GROUPS - - ::= | - - ::= - UNBOUNDED PRECEDING - | - | CURRENT ROW - - ::= PRECEDING - - ::= - BETWEEN AND - - ::= - - ::= - - ::= - - | UNBOUNDED FOLLOWING - | - - ::= FOLLOWING - - ::= - EXCLUDE CURRENT ROW - | EXCLUDE GROUP - | EXCLUDE TIES - | EXCLUDE NO OTHERS - -> windowClause :: TestItem -> windowClause = Group "window clause" -> [-- todo: window clause -> ] - -== 7.12 - -Function -Specify a table derived from the result of a
. - - ::= - SELECT [ ]
- - [ { ::= | - - ::= - - | - - ::= - [ { }... ] - - ::= - - ::= [ ] - - ::= [ AS ] - - ::= - - [ AS ] - - ::= - -> querySpecification :: TestItem -> querySpecification = Group "query specification" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a from t",qe) -> ,("select all a from t",qe {qeSetQuantifier = All}) -> ,("select distinct a from t",qe {qeSetQuantifier = Distinct}) -> ,("select * from t", qe {qeSelectList = [(Star,Nothing)]}) -> ,("select a.* from t" -> ,qe {qeSelectList = [(BinOp (Iden [Name "a"]) [Name "."] Star -> ,Nothing)]}) -> ,("select a b from t" -> ,qe {qeSelectList = [(Iden [Name "a"], Just $ Name "b")]}) -> ,("select a as b from t" -> ,qe {qeSelectList = [(Iden [Name "a"], Just $ Name "b")]}) -> ,("select a,b from t" -> ,qe {qeSelectList = [(Iden [Name "a"], Nothing) -> ,(Iden [Name "b"], Nothing)]}) -> -- todo: all field reference alias -> --,("select * as (a,b) from t",undefined) -> ] -> where -> qe = makeSelect -> {qeSelectList = [(Iden [Name "a"], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> } - -== 7.13 - -Function -Specify a table. - - ::= - [ ] - [ ] [ ] [ ] - - ::= WITH [ RECURSIVE ] - - ::= [ { }... ] - - ::= - [ ] - AS
[ ] - - ::= - -> withQueryExpression :: TestItem -> withQueryExpression= Group "with query expression" -> [-- todo: with query expression -> ] - - ::= - - | UNION [ ALL | DISTINCT ] - [ ] - | EXCEPT [ ALL | DISTINCT ] - [ ] - - ::= - - | INTERSECT [ ALL | DISTINCT ] - [ ] - - ::= - - | - [ ] [ ] [ ] - - -> setOpQueryExpression :: TestItem -> setOpQueryExpression= Group "set operation query expression" -> $ map (uncurry (TestQueryExpr SQL2011)) -> -- todo: complete setop query expression tests -> [{-("select * from t union select * from t" -> ,undefined) -> ,("select * from t union all select * from t" -> ,undefined) -> ,("select * from t union distinct select * from t" -> ,undefined) -> ,("select * from t union corresponding select * from t" -> ,undefined) -> ,("select * from t union corresponding by (a,b) select * from t" -> ,undefined) -> ,("select * from t except select * from t" -> ,undefined) -> ,("select * from t in intersect select * from t" -> ,undefined)-} -> ] - -TODO: tests for the associativity and precendence - -TODO: not sure exactly where parens are allowed, we will allow them -everywhere - - ::= - - |
- | - - ::= TABLE
- - ::= - CORRESPONDING [ BY ] - - ::= - -> explicitTableQueryExpression :: TestItem -> explicitTableQueryExpression= Group "explicit table query expression" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("table t", Table [Name "t"]) -> ] - - - ::= ORDER BY - - ::= OFFSET { ROW | ROWS } - - ::= - FETCH { FIRST | NEXT } [ ] { ROW | ROWS } { ONLY | WITH TIES } - - ::= | - - ::= - - ::= - - ::= PERCENT - -> orderOffsetFetchQueryExpression :: TestItem -> orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [-- todo: finish tests for order offset and fetch -> ("select a from t order by a" -> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) -> DirDefault NullsOrderDefault]}) -> ,("select a from t offset 5 row" -> ,qe {qeOffset = Just $ NumLit "5"}) -> ,("select a from t offset 5 rows" -> ,qe {qeOffset = Just $ NumLit "5"}) -> ,("select a from t fetch first 5 row only" -> ,qe {qeFetchFirst = Just $ NumLit "5"}) -> -- todo: support with ties and percent in fetch -> --,("select a from t fetch next 5 rows with ties" -> --,("select a from t fetch first 5 percent rows only" -> ] -> where -> qe = makeSelect -> {qeSelectList = [(Iden [Name "a"], Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> } - - -== 7.14 - -Function - -Specify the generation of ordering and cycle detection information in -the result of recursive query expressions. - - ::= - - | - | - - ::= SEARCH SET - - ::= - DEPTH FIRST BY - | BREADTH FIRST BY - - ::= - - ::= - CYCLE SET TO - DEFAULT USING - - ::= [ { }... ] - - ::= - - ::= - - ::= - - ::= - - ::= - -> searchOrCycleClause :: TestItem -> searchOrCycleClause = Group "search or cycle clause" -> [-- todo: search or cycle clause -> ] - -== 7.15 - -Function - -Specify a scalar value, a row, or a table derived from a . - - ::= - - ::= - -
::= - - ::= - -> scalarSubquery :: TestItem -> scalarSubquery = Group "scalar subquery" -> [-- todo: scalar subquery -> ] - -= 8 Predicates - -== 8.1 - -Function -Specify a condition that can be evaluated to give a boolean value. - - ::= - - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - | - -> predicates :: TestItem -> predicates = Group "predicates" -> [comparisonPredicates -> ,betweenPredicate -> ,inPredicate -> ,likePredicate -> ,similarPredicate -> ,regexLikePredicate -> ,nullPredicate -> ,quantifiedComparisonPredicate -> ,existsPredicate -> ,uniquePredicate -> ,normalizedPredicate -> ,matchPredicate -> ,overlapsPredicate -> ,distinctPredicate -> ,memberPredicate -> ,submultisetPredicate -> ,setPredicate -> ,periodPredicate -> ] - - -== 8.1 - -No grammar - -== 8.2 - -Function -Specify a comparison of two row values. - - ::= - - ::= - - ::= - - | - | - | - | - | - -> comparisonPredicates :: TestItem -> comparisonPredicates = Group "comparison predicates" -> $ map (uncurry (TestValueExpr SQL2011)) -> $ map mkOp ["=", "<>", "<", ">", "<=", ">="] -> ++ [("ROW(a) = ROW(b)" -> ,BinOp (App [Name "ROW"] [a]) -> [Name "="] -> (App [Name "ROW"] [b])) -> ,("(a,b) = (c,d)" -> ,BinOp (SpecialOp [Name "rowctor"] [a,b]) -> [Name "="] -> (SpecialOp [Name "rowctor"] [Iden [Name "c"], Iden [Name "d"]])) -> ] -> where -> mkOp nm = ("a " ++ nm ++ " b" -> ,BinOp a [Name nm] b) -> a = Iden [Name "a"] -> b = Iden [Name "b"] - -TODO: what other tests, more complex expressions with comparisons? - -== 8.3 - -Function -Specify a range comparison. - - ::= - - ::= - [ NOT ] BETWEEN [ ASYMMETRIC | SYMMETRIC ] - AND - -> betweenPredicate :: TestItem -> betweenPredicate = Group "between predicate" -> [-- todo: between predicate -> ] - -== 8.4 - -Function -Specify a quantified comparison. - - ::= - - ::= [ NOT ] IN - - ::= -
- | - - ::= - [ { }... ] - -> inPredicate :: TestItem -> inPredicate = Group "in predicate" -> [-- todo: in predicate -> ] - -== 8.5 - -Function -Specify a pattern-match comparison. - - ::= | - - ::= - - - ::= - [ NOT ] LIKE [ ESCAPE ] - - ::= - - ::= - - ::= - - ::= - [ NOT ] LIKE [ ESCAPE ] - - ::= - - ::= - -> likePredicate :: TestItem -> likePredicate = Group "like predicate" -> [-- todo: like predicate -> ] - -== 8.6 - -Function -Specify a character string similarity by means of a regular expression. - - ::= - - ::= - [ NOT ] SIMILAR TO [ ESCAPE ] - - ::= - - ::= - - | - - ::= | - - ::= - - | - | - | - | - - ::= [ ] - - ::= [ ] - - ::= - - ::= - - ::= - - | - | - | - - ::= | - - ::= !! See the Syntax Rules. - - ::= !! See the Syntax Rules. - - ::= - - | ... - | ... - | ... - ... - - ::= - - ::= - - ::= - - | - | - - ::= - -> similarPredicate :: TestItem -> similarPredicate = Group "similar predicate" -> [-- todo: similar predicate -> ] - - -== 8.7 - -Function -Specify a pattern-match comparison using an XQuery regular expression. - - ::= - - ::= - [ NOT ] LIKE_REGEX [ FLAG ] - -> regexLikePredicate :: TestItem -> regexLikePredicate = Group "regex like predicate" -> [-- todo: regex like predicate -> ] - -== 8.8 - -Function -Specify a test for a null value. - - ::= - - ::= IS [ NOT ] NULL - -> nullPredicate :: TestItem -> nullPredicate = Group "null predicate" -> [-- todo: null predicate -> ] - -== 8.9 - -Function -Specify a quantified comparison. - - ::= - - - ::= -
- - ::= | - - ::= ALL - - ::= SOME | ANY - -> quantifiedComparisonPredicate :: TestItem -> quantifiedComparisonPredicate = Group "quantified comparison predicate" -> $ map (uncurry (TestValueExpr SQL2011)) - -> [("a = any (select * from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name "="] CPAny qe) -> ,("a <= some (select * from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name "<="] CPSome qe) -> ,("a > all (select * from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name ">"] CPAll qe) -> ,("(a,b) <> all (select * from t)" -> ,QuantifiedComparison -> (SpecialOp [Name "rowctor"] [Iden [Name "a"] -> ,Iden [Name "b"]]) [Name "<>"] CPAll qe) -> ] -> where -> qe = makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} - -== 8.10 - -Function -Specify a test for a non-empty set. - - ::= EXISTS
- -> existsPredicate :: TestItem -> existsPredicate = Group "exists predicate" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("exists(select * from t where a = 4)" -> ,SubQueryExpr SqExists -> $ makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeWhere = Just (BinOp (Iden [Name "a"]) [Name "="] (NumLit "4")) -> } -> )] - -== 8.11 - -Function -Specify a test for the absence of duplicate rows. - - ::= UNIQUE
- -> uniquePredicate :: TestItem -> uniquePredicate = Group "unique predicate" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("unique(select * from t where a = 4)" -> ,SubQueryExpr SqUnique -> $ makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> ,qeWhere = Just (BinOp (Iden [Name "a"]) [Name "="] (NumLit "4")) -> } -> )] - -== 8.12 - -Function -Determine whether a character string value is normalized. - - ::= - - ::= IS [ NOT ] [ ] NORMALIZED - -> normalizedPredicate :: TestItem -> normalizedPredicate = Group "normalized predicate" -> [-- todo: normalized predicate -> ] - -== 8.13 - -Function -Specify a test for matching rows. - - ::= - - ::= - MATCH [ UNIQUE ] [ SIMPLE | PARTIAL | FULL ]
- -> matchPredicate :: TestItem -> matchPredicate = Group "match predicate" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("a match (select a from t)" -> ,Match (Iden [Name "a"]) False qe) -> ,("(a,b) match (select a,b from t)" -> ,Match (SpecialOp [Name "rowctor"] -> [Iden [Name "a"], Iden [Name "b"]]) False qea) -> ,("(a,b) match unique (select a,b from t)" -> ,Match (SpecialOp [Name "rowctor"] -> [Iden [Name "a"], Iden [Name "b"]]) True qea) -> ] -> where -> qe = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} -> qea = qe {qeSelectList = qeSelectList qe -> ++ [(Iden [Name "b"],Nothing)]} - -TODO: simple, partial and full - -== 8.14 - -Function -Specify a test for an overlap between two datetime periods. - - ::= - - - ::= - - ::= OVERLAPS - - ::= - - ::= - -> overlapsPredicate :: TestItem -> overlapsPredicate = Group "overlaps predicate" -> [-- todo: overlaps predicate -> ] - -== 8.15 - -Function -Specify a test of whether two row values are distinct - - ::= - - ::= - IS [ NOT ] DISTINCT FROM - - ::= - - ::= - -> distinctPredicate :: TestItem -> distinctPredicate = Group "distinct predicate" -> [-- todo: distinct predicate -> ] - -== 8.16 - -Function -Specify a test of whether a value is a member of a multiset. - - ::= - - ::= [ NOT ] MEMBER [ OF ] - -> memberPredicate :: TestItem -> memberPredicate = Group "member predicate" -> [-- todo: member predicate -> ] - -== 8.17 - -Function -Specify a test of whether a multiset is a submultiset of another multiset. - - ::= - - - ::= - [ NOT ] SUBMULTISET [ OF ] - -> submultisetPredicate :: TestItem -> submultisetPredicate = Group "submultiset predicate" -> [-- todo: submultiset predicate -> ] - -== 8.18 - -Function - -Specify a test of whether a multiset is a set (that is, does not -contain any duplicates). - - ::= - - ::= IS [ NOT ] A SET - -> setPredicate :: TestItem -> setPredicate = Group "set predicate" -> [-- todo: set predicate -> ] - -== 8.19 - -Function -Specify a type test. - - ::= - - ::= - IS [ NOT ] OF - - ::= - - [ { }... ] - - ::= - - | - - ::= - - - ::= - ONLY - -TODO: type predicate - -== 8.20 - -Function -Specify a test to determine the relationship between periods. - - ::= - - | - | - | - | - | - | - - ::= - - - ::= OVERLAPS - - ::= - - ::= - - ::= - - | PERIOD - - ::= - - ::= - - ::= - - ::= - - - ::= EQUALS - - ::= - - - ::= - CONTAINS - - ::= - - | - - ::= - - - ::= PRECEDES - - ::= - - - ::= SUCCEEDS - - ::= - - - ::= - IMMEDIATELY PRECEDES - - ::= - - - ::= - IMMEDIATELY SUCCEEDS - -> periodPredicate :: TestItem -> periodPredicate = Group "period predicate" -> [-- todo: period predicate -> ] - -== 8.21 - -Function - -Specify a condition that is True, False, or Unknown, depending on the -value of a . - - ::= - -= 10 Additional common elements - -== 10.1 - -Function -Specify the precision of an interval data type. - - ::= TO | - - ::= - - [ ] - - ::= - - | SECOND [ ] - - ::= - - [ ] - | SECOND [ - [ ] ] - - ::= | SECOND - - ::= YEAR | MONTH | DAY | HOUR | MINUTE - - ::= - - ::= - -> intervalQualifier :: TestItem -> intervalQualifier = Group "interval qualifier" -> [-- todo: interval qualifier -> ] - -todo: also test all of these in the typenames and in the interval -literal tests - -== 10.2 - -Function -Specify a programming language. - - ::= LANGUAGE - - ::= ADA | C | COBOL | FORTRAN | M | MUMPS | PASCAL | PLI | SQL - -== 10.3 - -Function -Specify an order for searching for an SQL-invoked routine. - - ::= PATH - - ::= [ { }... ] - -== 10.4 - -Function -Invoke an SQL-invoked routine. - - ::= - - ::= [ ] - - ::= - [ [ { }... ] ] - - ::= - - | - | - | - | - - ::= - AS - - ::= - - - - ::= - - | - | - -== 10.5 - -Function -Identify a character set. - - ::= - - | - | - - ::= - - ::= - - ::= - -tested in the type names - -== 10.6 - -Function -Specify an SQL-invoked routine. - - ::= - SPECIFIC - | [ FOR ] - - ::= - ROUTINE - | FUNCTION - | PROCEDURE - | [ INSTANCE | STATIC | CONSTRUCTOR ] METHOD - - ::= [ ] - - ::= | - - ::= - [ [ { }... ] ] - -== 10.7 - -Function -Specify a default collation. - - ::= COLLATE - -> collateClause :: TestItem -> collateClause = Group "collate clause" -> $ map (uncurry (TestValueExpr SQL2011)) -> [("a collate my_collation" -> ,Collate (Iden [Name "a"]) [Name "my_collation"])] - -== 10.8 and - -Function -Specify the name of a constraint and its characteristics. - - ::= CONSTRAINT - - ::= - [ [ NOT ] DEFERRABLE ] [ ] - | [ NOT ] DEFERRABLE [ ] [ ] - | - - ::= INITIALLY DEFERRED | INITIALLY IMMEDIATE - - ::= [ NOT ] ENFORCED - -== 10.9 - -Function -Specify a value computed from a collection of rows. - - ::= - COUNT [ ] - | [ ] - | [ ] - | [ ] - | [ ] - - ::= - [ ] - - - ::= - - ::= - AVG - | MAX - | MIN - | SUM - | EVERY - | ANY - | SOME - | COUNT - | STDDEV_POP - | STDDEV_SAMP - | VAR_SAMP - | VAR_POP - | COLLECT - | FUSION - | INTERSECTION - - ::= DISTINCT | ALL - - ::= FILTER WHERE - - ::= - - - - ::= - COVAR_POP - | COVAR_SAMP - | CORR - | REGR_SLOPE - | REGR_INTERCEPT - | REGR_COUNT - | REGR_R2 - | REGR_AVGX - | REGR_AVGY - | REGR_SXX - | REGR_SYY - | REGR_SXY - - ::= - - ::= - - ::= - - | - - ::= - - - - - ::= - WITHIN GROUP ORDER BY - - ::= - [ { }... ] - - ::= - - - - - ::= - - ::= PERCENTILE_CONT | PERCENTILE_DISC - - ::= - ARRAY_AGG - [ ORDER BY ] - -> aggregateFunction :: TestItem -> aggregateFunction = Group "aggregate function" -> $ map (uncurry (TestValueExpr SQL2011)) $ -> [("count(*)",App [Name "count"] [Star]) -> ,("count(*) filter (where something > 5)" -> ,AggregateApp [Name "count"] SQDefault [Star] [] fil) - -gsf - -> ,("count(a)",App [Name "count"] [Iden [Name "a"]]) -> ,("count(distinct a)" -> ,AggregateApp [Name "count"] -> Distinct -> [Iden [Name "a"]] [] Nothing) -> ,("count(all a)" -> ,AggregateApp [Name "count"] -> All -> [Iden [Name "a"]] [] Nothing) -> ,("count(all a) filter (where something > 5)" -> ,AggregateApp [Name "count"] -> All -> [Iden [Name "a"]] [] fil) -> ] ++ concatMap mkSimpleAgg -> ["avg","max","min","sum" -> ,"every", "any", "some" -> ,"stddev_pop","stddev_samp","var_samp","var_pop" -> ,"collect","fusion","intersection"] - -bsf - -> ++ concatMap mkBsf -> ["COVAR_POP","COVAR_SAMP","CORR","REGR_SLOPE" -> ,"REGR_INTERCEPT","REGR_COUNT","REGR_R2" -> ,"REGR_AVGX","REGR_AVGY" -> ,"REGR_SXX","REGR_SYY","REGR_SXY"] - -osf - -> ++ -> [("rank(a,c) within group (order by b)" -> ,AggregateAppGroup [Name "rank"] -> [Iden [Name "a"], Iden [Name "c"]] -> ob)] -> ++ map mkGp ["dense_rank","percent_rank" -> ,"cume_dist", "percentile_cont" -> ,"percentile_disc"] -> ++ [("array_agg(a)", App [Name "array_agg"] [Iden [Name "a"]]) -> ,("array_agg(a order by z)" -> ,AggregateApp [Name "array_agg"] -> SQDefault -> [Iden [Name "a"]] -> [SortSpec (Iden [Name "z"]) -> DirDefault NullsOrderDefault] -> Nothing)] - -> where -> fil = Just $ BinOp (Iden [Name "something"]) [Name ">"] (NumLit "5") -> ob = [SortSpec (Iden [Name "b"]) DirDefault NullsOrderDefault] -> mkGp nm = (nm ++ "(a) within group (order by b)" -> ,AggregateAppGroup [Name nm] -> [Iden [Name "a"]] -> ob) - -> mkSimpleAgg nm = -> [(nm ++ "(a)",App [Name nm] [Iden [Name "a"]]) -> ,(nm ++ "(distinct a)" -> ,AggregateApp [Name nm] -> Distinct -> [Iden [Name "a"]] [] Nothing)] -> mkBsf nm = -> [(nm ++ "(a,b)",App [Name nm] [Iden [Name "a"],Iden [Name "b"]]) -> ,(nm ++"(a,b) filter (where something > 5)" -> ,AggregateApp [Name nm] -> SQDefault -> [Iden [Name "a"],Iden [Name "b"]] [] fil)] - -== 10.10 - -Function -Specify a sort order. - - ::= - [ { }... ] - - ::= - [ ] [ ] - - ::= - - ::= ASC | DESC - - ::= - | NULLS LAST - NULLS FIRST - -> sortSpecificationList :: TestItem -> sortSpecificationList = Group "sort specification list" -> $ map (uncurry (TestQueryExpr SQL2011)) -> [("select * from t order by a" -> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) -> DirDefault NullsOrderDefault]}) -> ,("select * from t order by a,b" -> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) -> DirDefault NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) -> DirDefault NullsOrderDefault]}) -> ,("select * from t order by a asc,b" -> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) -> Asc NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) -> DirDefault NullsOrderDefault]}) -> ,("select * from t order by a desc,b" -> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"]) -> Desc NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) -> DirDefault NullsOrderDefault]}) -> ,("select * from t order by a collate x desc,b" -> ,qe {qeOrderBy = [SortSpec -> (Collate (Iden [Name "a"]) [Name "x"]) -> Desc NullsOrderDefault -> ,SortSpec (Iden [Name "b"]) -> DirDefault NullsOrderDefault]}) -> ,("select * from t order by 1,2" -> ,qe {qeOrderBy = [SortSpec (NumLit "1") -> DirDefault NullsOrderDefault -> ,SortSpec (NumLit "2") -> DirDefault NullsOrderDefault]}) -> ] -> where -> qe = makeSelect -> {qeSelectList = [(Star,Nothing)] -> ,qeFrom = [TRSimple [Name "t"]]} diff --git a/tools/Language/SQL/SimpleSQL/TableRefs.lhs b/tools/Language/SQL/SimpleSQL/TableRefs.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/TableRefs.lhs +++ /dev/null @@ -1,105 +0,0 @@ - -These are the tests for parsing focusing on the from part of query -expression - -> module Language.SQL.SimpleSQL.TableRefs (tableRefTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - - -> tableRefTests :: TestItem -> tableRefTests = Group "tableRefTests" $ map (uncurry (TestQueryExpr SQL2011)) -> [("select a from t" -> ,ms [TRSimple [Name "t"]]) - -> ,("select a from f(a)" -> ,ms [TRFunction [Name "f"] [Iden [Name "a"]]]) - -> ,("select a from t,u" -> ,ms [TRSimple [Name "t"], TRSimple [Name "u"]]) - -> ,("select a from s.t" -> ,ms [TRSimple [Name "s", Name "t"]]) - -these lateral queries make no sense but the syntax is valid - -> ,("select a from lateral a" -> ,ms [TRLateral $ TRSimple [Name "a"]]) - -> ,("select a from lateral a,b" -> ,ms [TRLateral $ TRSimple [Name "a"], TRSimple [Name "b"]]) - -> ,("select a from a, lateral b" -> ,ms [TRSimple [Name "a"], TRLateral $ TRSimple [Name "b"]]) - -> ,("select a from a natural join lateral b" -> ,ms [TRJoin (TRSimple [Name "a"]) True JInner -> (TRLateral $ TRSimple [Name "b"]) -> Nothing]) - -> ,("select a from lateral a natural join lateral b" -> ,ms [TRJoin (TRLateral $ TRSimple [Name "a"]) True JInner -> (TRLateral $ TRSimple [Name "b"]) -> Nothing]) - - -> ,("select a from t inner join u on expr" -> ,ms [TRJoin (TRSimple [Name "t"]) False JInner (TRSimple [Name "u"]) -> (Just $ JoinOn $ Iden [Name "expr"])]) - -> ,("select a from t join u on expr" -> ,ms [TRJoin (TRSimple [Name "t"]) False JInner (TRSimple [Name "u"]) -> (Just $ JoinOn $ Iden [Name "expr"])]) - -> ,("select a from t left join u on expr" -> ,ms [TRJoin (TRSimple [Name "t"]) False JLeft (TRSimple [Name "u"]) -> (Just $ JoinOn $ Iden [Name "expr"])]) - -> ,("select a from t right join u on expr" -> ,ms [TRJoin (TRSimple [Name "t"]) False JRight (TRSimple [Name "u"]) -> (Just $ JoinOn $ Iden [Name "expr"])]) - -> ,("select a from t full join u on expr" -> ,ms [TRJoin (TRSimple [Name "t"]) False JFull (TRSimple [Name "u"]) -> (Just $ JoinOn $ Iden [Name "expr"])]) - -> ,("select a from t cross join u" -> ,ms [TRJoin (TRSimple [Name "t"]) False -> JCross (TRSimple [Name "u"]) Nothing]) - -> ,("select a from t natural inner join u" -> ,ms [TRJoin (TRSimple [Name "t"]) True JInner (TRSimple [Name "u"]) -> Nothing]) - -> ,("select a from t inner join u using(a,b)" -> ,ms [TRJoin (TRSimple [Name "t"]) False JInner (TRSimple [Name "u"]) -> (Just $ JoinUsing [Name "a", Name "b"])]) - -> ,("select a from (select a from t)" -> ,ms [TRQueryExpr $ ms [TRSimple [Name "t"]]]) - -> ,("select a from t as u" -> ,ms [TRAlias (TRSimple [Name "t"]) (Alias (Name "u") Nothing)]) - -> ,("select a from t u" -> ,ms [TRAlias (TRSimple [Name "t"]) (Alias (Name "u") Nothing)]) - -> ,("select a from t u(b)" -> ,ms [TRAlias (TRSimple [Name "t"]) (Alias (Name "u") $ Just [Name "b"])]) - -> ,("select a from (t cross join u) as u" -> ,ms [TRAlias (TRParens $ -> TRJoin (TRSimple [Name "t"]) False JCross (TRSimple [Name "u"]) Nothing) -> (Alias (Name "u") Nothing)]) -> -- todo: not sure if the associativity is correct - -> ,("select a from t cross join u cross join v", -> ms [TRJoin -> (TRJoin (TRSimple [Name "t"]) False -> JCross (TRSimple [Name "u"]) Nothing) -> False JCross (TRSimple [Name "v"]) Nothing]) -> ] -> where -> ms f = makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = f} diff --git a/tools/Language/SQL/SimpleSQL/TestTypes.lhs b/tools/Language/SQL/SimpleSQL/TestTypes.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/TestTypes.lhs +++ /dev/null @@ -1,31 +0,0 @@ - -This is the types used to define the tests as pure data. See the -Tests.lhs module for the 'interpreter'. - -> module Language.SQL.SimpleSQL.TestTypes -> (TestItem(..) -> ,Dialect(..)) where - -> import Language.SQL.SimpleSQL.Syntax - -TODO: maybe make the dialect args into [dialect], then each test -checks all the dialects mentioned work, and all the dialects not -mentioned give a parse error. Not sure if this will be too awkward due -to lots of tricky exceptions/variationsx. - -> data TestItem = Group String [TestItem] -> | TestValueExpr Dialect String ValueExpr -> | TestQueryExpr Dialect String QueryExpr -> | TestQueryExprs Dialect String [QueryExpr] - -this just checks the sql parses without error, mostly just a -intermediate when I'm too lazy to write out the parsed AST. These -should all be TODO to convert to a testqueryexpr test. - -> | ParseQueryExpr Dialect String - -check that the string given fails to parse - -> | ParseQueryExprFails Dialect String -> | ParseValueExprFails Dialect String -> deriving (Eq,Show) diff --git a/tools/Language/SQL/SimpleSQL/Tests.lhs b/tools/Language/SQL/SimpleSQL/Tests.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/Tests.lhs +++ /dev/null @@ -1,132 +0,0 @@ - -This is the main tests module which exposes the test data plus the -Test.Framework tests. It also contains the code which converts the -test data to the Test.Framework tests. - -> module Language.SQL.SimpleSQL.Tests -> (testData -> ,tests -> ,TestItem(..) -> ) where - -> import Test.Framework -> import Test.Framework.Providers.HUnit -> import qualified Test.HUnit as H - -> --import Language.SQL.SimpleSQL.Syntax -> import Language.SQL.SimpleSQL.Pretty -> import Language.SQL.SimpleSQL.Parser - -> import Language.SQL.SimpleSQL.TestTypes - -> import Language.SQL.SimpleSQL.FullQueries -> import Language.SQL.SimpleSQL.GroupBy -> import Language.SQL.SimpleSQL.Postgres -> import Language.SQL.SimpleSQL.QueryExprComponents -> import Language.SQL.SimpleSQL.QueryExprs -> import Language.SQL.SimpleSQL.TableRefs -> import Language.SQL.SimpleSQL.ValueExprs -> import Language.SQL.SimpleSQL.Tpch - -> import Language.SQL.SimpleSQL.SQL2011 - -> import Language.SQL.SimpleSQL.MySQL - -Order the tests to start from the simplest first. This is also the -order on the generated documentation. - -> testData :: TestItem -> testData = -> Group "parserTest" -> [valueExprTests -> ,queryExprComponentTests -> ,queryExprsTests -> ,tableRefTests -> ,groupByTests -> ,fullQueriesTests -> ,postgresTests -> ,tpchTests -> ,sql2011Tests -> ,mySQLTests -> ] - -> tests :: Test.Framework.Test -> tests = itemToTest testData - -> --runTests :: IO () -> --runTests = void $ H.runTestTT $ itemToTest testData - -> itemToTest :: TestItem -> Test.Framework.Test -> itemToTest (Group nm ts) = -> testGroup nm $ map itemToTest ts -> itemToTest (TestValueExpr d str expected) = -> toTest parseValueExpr prettyValueExpr d str expected -> itemToTest (TestQueryExpr d str expected) = -> toTest parseQueryExpr prettyQueryExpr d str expected -> itemToTest (TestQueryExprs d str expected) = -> toTest parseQueryExprs prettyQueryExprs d str expected -> itemToTest (ParseQueryExpr d str) = -> toPTest parseQueryExpr prettyQueryExpr d str - -> itemToTest (ParseQueryExprFails d str) = -> toFTest parseQueryExpr prettyQueryExpr d str - -> itemToTest (ParseValueExprFails d str) = -> toFTest parseValueExpr prettyValueExpr d str - - -> toTest :: (Eq a, Show a) => -> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a) -> -> (Dialect -> a -> String) -> -> Dialect -> -> String -> -> a -> -> Test.Framework.Test -> toTest parser pp d str expected = testCase str $ do -> let egot = parser d "" Nothing str -> case egot of -> Left e -> H.assertFailure $ peFormattedError e -> Right got -> do -> H.assertEqual "" expected got -> let str' = pp d got -> let egot' = parser d "" Nothing str' -> case egot' of -> Left e' -> H.assertFailure $ "pp roundtrip" -> ++ "\n" ++ str' -> ++ peFormattedError e' -> Right got' -> H.assertEqual -> ("pp roundtrip" ++ "\n" ++ str') -> expected got' - -> toPTest :: (Eq a, Show a) => -> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a) -> -> (Dialect -> a -> String) -> -> Dialect -> -> String -> -> Test.Framework.Test -> toPTest parser pp d str = testCase str $ do -> let egot = parser d "" Nothing str -> case egot of -> Left e -> H.assertFailure $ peFormattedError e -> Right got -> do -> let str' = pp d got -> let egot' = parser d "" Nothing str' -> case egot' of -> Left e' -> H.assertFailure $ "pp roundtrip " -> ++ "\n" ++ str' ++ "\n" -> ++ peFormattedError e' -> Right _got' -> return () - - -> toFTest :: (Eq a, Show a) => -> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a) -> -> (Dialect -> a -> String) -> -> Dialect -> -> String -> -> Test.Framework.Test -> toFTest parser pp d str = testCase str $ do -> let egot = parser d "" Nothing str -> case egot of -> Left e -> return () -> Right got -> -> H.assertFailure $ "parse didn't fail: " ++ show d ++ "\n" ++ str diff --git a/tools/Language/SQL/SimpleSQL/Tpch.lhs b/tools/Language/SQL/SimpleSQL/Tpch.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/Tpch.lhs +++ /dev/null @@ -1,683 +0,0 @@ - -Some tests for parsing the tpch queries - -The changes made to the official syntax are: -1. replace the set rowcount with ansi standard fetch first n rows only -2. replace the create view, query, drop view sequence with a query - using a common table expression - -> module Language.SQL.SimpleSQL.Tpch (tpchTests,tpchQueries) where - -> import Language.SQL.SimpleSQL.TestTypes - -> tpchTests :: TestItem -> tpchTests = -> Group "parse tpch" -> $ map (ParseQueryExpr SQL2011 . snd) tpchQueries - -> tpchQueries :: [(String,String)] -> tpchQueries = -> [("Q1","\n\ -> \select\n\ -> \ l_returnflag,\n\ -> \ l_linestatus,\n\ -> \ sum(l_quantity) as sum_qty,\n\ -> \ sum(l_extendedprice) as sum_base_price,\n\ -> \ sum(l_extendedprice * (1 - l_discount)) as sum_disc_price,\n\ -> \ sum(l_extendedprice * (1 - l_discount) * (1 + l_tax)) as sum_charge,\n\ -> \ avg(l_quantity) as avg_qty,\n\ -> \ avg(l_extendedprice) as avg_price,\n\ -> \ avg(l_discount) as avg_disc,\n\ -> \ count(*) as count_order\n\ -> \from\n\ -> \ lineitem\n\ -> \where\n\ -> \ l_shipdate <= date '1998-12-01' - interval '63' day (3)\n\ -> \group by\n\ -> \ l_returnflag,\n\ -> \ l_linestatus\n\ -> \order by\n\ -> \ l_returnflag,\n\ -> \ l_linestatus") -> ,("Q2","\n\ -> \select\n\ -> \ s_acctbal,\n\ -> \ s_name,\n\ -> \ n_name,\n\ -> \ p_partkey,\n\ -> \ p_mfgr,\n\ -> \ s_address,\n\ -> \ s_phone,\n\ -> \ s_comment\n\ -> \from\n\ -> \ part,\n\ -> \ supplier,\n\ -> \ partsupp,\n\ -> \ nation,\n\ -> \ region\n\ -> \where\n\ -> \ p_partkey = ps_partkey\n\ -> \ and s_suppkey = ps_suppkey\n\ -> \ and p_size = 15\n\ -> \ and p_type like '%BRASS'\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_regionkey = r_regionkey\n\ -> \ and r_name = 'EUROPE'\n\ -> \ and ps_supplycost = (\n\ -> \ select\n\ -> \ min(ps_supplycost)\n\ -> \ from\n\ -> \ partsupp,\n\ -> \ supplier,\n\ -> \ nation,\n\ -> \ region\n\ -> \ where\n\ -> \ p_partkey = ps_partkey\n\ -> \ and s_suppkey = ps_suppkey\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_regionkey = r_regionkey\n\ -> \ and r_name = 'EUROPE'\n\ -> \ )\n\ -> \order by\n\ -> \ s_acctbal desc,\n\ -> \ n_name,\n\ -> \ s_name,\n\ -> \ p_partkey\n\ -> \fetch first 100 rows only") -> ,("Q3","\n\ -> \ select\n\ -> \ l_orderkey,\n\ -> \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\ -> \ o_orderdate,\n\ -> \ o_shippriority\n\ -> \ from\n\ -> \ customer,\n\ -> \ orders,\n\ -> \ lineitem\n\ -> \ where\n\ -> \ c_mktsegment = 'MACHINERY'\n\ -> \ and c_custkey = o_custkey\n\ -> \ and l_orderkey = o_orderkey\n\ -> \ and o_orderdate < date '1995-03-21'\n\ -> \ and l_shipdate > date '1995-03-21'\n\ -> \ group by\n\ -> \ l_orderkey,\n\ -> \ o_orderdate,\n\ -> \ o_shippriority\n\ -> \ order by\n\ -> \ revenue desc,\n\ -> \ o_orderdate\n\ -> \ fetch first 10 rows only") -> ,("Q4","\n\ -> \ select\n\ -> \ o_orderpriority,\n\ -> \ count(*) as order_count\n\ -> \ from\n\ -> \ orders\n\ -> \ where\n\ -> \ o_orderdate >= date '1996-03-01'\n\ -> \ and o_orderdate < date '1996-03-01' + interval '3' month\n\ -> \ and exists (\n\ -> \ select\n\ -> \ *\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_orderkey = o_orderkey\n\ -> \ and l_commitdate < l_receiptdate\n\ -> \ )\n\ -> \ group by\n\ -> \ o_orderpriority\n\ -> \ order by\n\ -> \ o_orderpriority") -> ,("Q5","\n\ -> \ select\n\ -> \ n_name,\n\ -> \ sum(l_extendedprice * (1 - l_discount)) as revenue\n\ -> \ from\n\ -> \ customer,\n\ -> \ orders,\n\ -> \ lineitem,\n\ -> \ supplier,\n\ -> \ nation,\n\ -> \ region\n\ -> \ where\n\ -> \ c_custkey = o_custkey\n\ -> \ and l_orderkey = o_orderkey\n\ -> \ and l_suppkey = s_suppkey\n\ -> \ and c_nationkey = s_nationkey\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_regionkey = r_regionkey\n\ -> \ and r_name = 'EUROPE'\n\ -> \ and o_orderdate >= date '1997-01-01'\n\ -> \ and o_orderdate < date '1997-01-01' + interval '1' year\n\ -> \ group by\n\ -> \ n_name\n\ -> \ order by\n\ -> \ revenue desc") -> ,("Q6","\n\ -> \ select\n\ -> \ sum(l_extendedprice * l_discount) as revenue\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_shipdate >= date '1997-01-01'\n\ -> \ and l_shipdate < date '1997-01-01' + interval '1' year\n\ -> \ and l_discount between 0.07 - 0.01 and 0.07 + 0.01\n\ -> \ and l_quantity < 24") -> ,("Q7","\n\ -> \ select\n\ -> \ supp_nation,\n\ -> \ cust_nation,\n\ -> \ l_year,\n\ -> \ sum(volume) as revenue\n\ -> \ from\n\ -> \ (\n\ -> \ select\n\ -> \ n1.n_name as supp_nation,\n\ -> \ n2.n_name as cust_nation,\n\ -> \ extract(year from l_shipdate) as l_year,\n\ -> \ l_extendedprice * (1 - l_discount) as volume\n\ -> \ from\n\ -> \ supplier,\n\ -> \ lineitem,\n\ -> \ orders,\n\ -> \ customer,\n\ -> \ nation n1,\n\ -> \ nation n2\n\ -> \ where\n\ -> \ s_suppkey = l_suppkey\n\ -> \ and o_orderkey = l_orderkey\n\ -> \ and c_custkey = o_custkey\n\ -> \ and s_nationkey = n1.n_nationkey\n\ -> \ and c_nationkey = n2.n_nationkey\n\ -> \ and (\n\ -> \ (n1.n_name = 'PERU' and n2.n_name = 'IRAQ')\n\ -> \ or (n1.n_name = 'IRAQ' and n2.n_name = 'PERU')\n\ -> \ )\n\ -> \ and l_shipdate between date '1995-01-01' and date '1996-12-31'\n\ -> \ ) as shipping\n\ -> \ group by\n\ -> \ supp_nation,\n\ -> \ cust_nation,\n\ -> \ l_year\n\ -> \ order by\n\ -> \ supp_nation,\n\ -> \ cust_nation,\n\ -> \ l_year") -> ,("Q8","\n\ -> \ select\n\ -> \ o_year,\n\ -> \ sum(case\n\ -> \ when nation = 'IRAQ' then volume\n\ -> \ else 0\n\ -> \ end) / sum(volume) as mkt_share\n\ -> \ from\n\ -> \ (\n\ -> \ select\n\ -> \ extract(year from o_orderdate) as o_year,\n\ -> \ l_extendedprice * (1 - l_discount) as volume,\n\ -> \ n2.n_name as nation\n\ -> \ from\n\ -> \ part,\n\ -> \ supplier,\n\ -> \ lineitem,\n\ -> \ orders,\n\ -> \ customer,\n\ -> \ nation n1,\n\ -> \ nation n2,\n\ -> \ region\n\ -> \ where\n\ -> \ p_partkey = l_partkey\n\ -> \ and s_suppkey = l_suppkey\n\ -> \ and l_orderkey = o_orderkey\n\ -> \ and o_custkey = c_custkey\n\ -> \ and c_nationkey = n1.n_nationkey\n\ -> \ and n1.n_regionkey = r_regionkey\n\ -> \ and r_name = 'MIDDLE EAST'\n\ -> \ and s_nationkey = n2.n_nationkey\n\ -> \ and o_orderdate between date '1995-01-01' and date '1996-12-31'\n\ -> \ and p_type = 'STANDARD ANODIZED BRASS'\n\ -> \ ) as all_nations\n\ -> \ group by\n\ -> \ o_year\n\ -> \ order by\n\ -> \ o_year") -> ,("Q9","\n\ -> \ select\n\ -> \ nation,\n\ -> \ o_year,\n\ -> \ sum(amount) as sum_profit\n\ -> \ from\n\ -> \ (\n\ -> \ select\n\ -> \ n_name as nation,\n\ -> \ extract(year from o_orderdate) as o_year,\n\ -> \ l_extendedprice * (1 - l_discount) - ps_supplycost * l_quantity as amount\n\ -> \ from\n\ -> \ part,\n\ -> \ supplier,\n\ -> \ lineitem,\n\ -> \ partsupp,\n\ -> \ orders,\n\ -> \ nation\n\ -> \ where\n\ -> \ s_suppkey = l_suppkey\n\ -> \ and ps_suppkey = l_suppkey\n\ -> \ and ps_partkey = l_partkey\n\ -> \ and p_partkey = l_partkey\n\ -> \ and o_orderkey = l_orderkey\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and p_name like '%antique%'\n\ -> \ ) as profit\n\ -> \ group by\n\ -> \ nation,\n\ -> \ o_year\n\ -> \ order by\n\ -> \ nation,\n\ -> \ o_year desc") -> ,("Q10","\n\ -> \ select\n\ -> \ c_custkey,\n\ -> \ c_name,\n\ -> \ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\ -> \ c_acctbal,\n\ -> \ n_name,\n\ -> \ c_address,\n\ -> \ c_phone,\n\ -> \ c_comment\n\ -> \ from\n\ -> \ customer,\n\ -> \ orders,\n\ -> \ lineitem,\n\ -> \ nation\n\ -> \ where\n\ -> \ c_custkey = o_custkey\n\ -> \ and l_orderkey = o_orderkey\n\ -> \ and o_orderdate >= date '1993-12-01'\n\ -> \ and o_orderdate < date '1993-12-01' + interval '3' month\n\ -> \ and l_returnflag = 'R'\n\ -> \ and c_nationkey = n_nationkey\n\ -> \ group by\n\ -> \ c_custkey,\n\ -> \ c_name,\n\ -> \ c_acctbal,\n\ -> \ c_phone,\n\ -> \ n_name,\n\ -> \ c_address,\n\ -> \ c_comment\n\ -> \ order by\n\ -> \ revenue desc\n\ -> \ fetch first 20 rows only") -> ,("Q11","\n\ -> \ select\n\ -> \ ps_partkey,\n\ -> \ sum(ps_supplycost * ps_availqty) as value\n\ -> \ from\n\ -> \ partsupp,\n\ -> \ supplier,\n\ -> \ nation\n\ -> \ where\n\ -> \ ps_suppkey = s_suppkey\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_name = 'CHINA'\n\ -> \ group by\n\ -> \ ps_partkey having\n\ -> \ sum(ps_supplycost * ps_availqty) > (\n\ -> \ select\n\ -> \ sum(ps_supplycost * ps_availqty) * 0.0001000000\n\ -> \ from\n\ -> \ partsupp,\n\ -> \ supplier,\n\ -> \ nation\n\ -> \ where\n\ -> \ ps_suppkey = s_suppkey\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_name = 'CHINA'\n\ -> \ )\n\ -> \ order by\n\ -> \ value desc") -> ,("Q12","\n\ -> \ select\n\ -> \ l_shipmode,\n\ -> \ sum(case\n\ -> \ when o_orderpriority = '1-URGENT'\n\ -> \ or o_orderpriority = '2-HIGH'\n\ -> \ then 1\n\ -> \ else 0\n\ -> \ end) as high_line_count,\n\ -> \ sum(case\n\ -> \ when o_orderpriority <> '1-URGENT'\n\ -> \ and o_orderpriority <> '2-HIGH'\n\ -> \ then 1\n\ -> \ else 0\n\ -> \ end) as low_line_count\n\ -> \ from\n\ -> \ orders,\n\ -> \ lineitem\n\ -> \ where\n\ -> \ o_orderkey = l_orderkey\n\ -> \ and l_shipmode in ('AIR', 'RAIL')\n\ -> \ and l_commitdate < l_receiptdate\n\ -> \ and l_shipdate < l_commitdate\n\ -> \ and l_receiptdate >= date '1994-01-01'\n\ -> \ and l_receiptdate < date '1994-01-01' + interval '1' year\n\ -> \ group by\n\ -> \ l_shipmode\n\ -> \ order by\n\ -> \ l_shipmode") -> ,("Q13","\n\ -> \ select\n\ -> \ c_count,\n\ -> \ count(*) as custdist\n\ -> \ from\n\ -> \ (\n\ -> \ select\n\ -> \ c_custkey,\n\ -> \ count(o_orderkey)\n\ -> \ from\n\ -> \ customer left outer join orders on\n\ -> \ c_custkey = o_custkey\n\ -> \ and o_comment not like '%pending%requests%'\n\ -> \ group by\n\ -> \ c_custkey\n\ -> \ ) as c_orders (c_custkey, c_count)\n\ -> \ group by\n\ -> \ c_count\n\ -> \ order by\n\ -> \ custdist desc,\n\ -> \ c_count desc") -> ,("Q14","\n\ -> \ select\n\ -> \ 100.00 * sum(case\n\ -> \ when p_type like 'PROMO%'\n\ -> \ then l_extendedprice * (1 - l_discount)\n\ -> \ else 0\n\ -> \ end) / sum(l_extendedprice * (1 - l_discount)) as promo_revenue\n\ -> \ from\n\ -> \ lineitem,\n\ -> \ part\n\ -> \ where\n\ -> \ l_partkey = p_partkey\n\ -> \ and l_shipdate >= date '1994-12-01'\n\ -> \ and l_shipdate < date '1994-12-01' + interval '1' month") -> ,("Q15","\n\ -> \ /*create view revenue0 (supplier_no, total_revenue) as\n\ -> \ select\n\ -> \ l_suppkey,\n\ -> \ sum(l_extendedprice * (1 - l_discount))\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_shipdate >= date '1995-06-01'\n\ -> \ and l_shipdate < date '1995-06-01' + interval '3' month\n\ -> \ group by\n\ -> \ l_suppkey;*/\n\ -> \ with\n\ -> \ revenue0 as\n\ -> \ (select\n\ -> \ l_suppkey as supplier_no,\n\ -> \ sum(l_extendedprice * (1 - l_discount)) as total_revenue\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_shipdate >= date '1995-06-01'\n\ -> \ and l_shipdate < date '1995-06-01' + interval '3' month\n\ -> \ group by\n\ -> \ l_suppkey)\n\ -> \ select\n\ -> \ s_suppkey,\n\ -> \ s_name,\n\ -> \ s_address,\n\ -> \ s_phone,\n\ -> \ total_revenue\n\ -> \ from\n\ -> \ supplier,\n\ -> \ revenue0\n\ -> \ where\n\ -> \ s_suppkey = supplier_no\n\ -> \ and total_revenue = (\n\ -> \ select\n\ -> \ max(total_revenue)\n\ -> \ from\n\ -> \ revenue0\n\ -> \ )\n\ -> \ order by\n\ -> \ s_suppkey") -> ,("Q16","\n\ -> \ select\n\ -> \ p_brand,\n\ -> \ p_type,\n\ -> \ p_size,\n\ -> \ count(distinct ps_suppkey) as supplier_cnt\n\ -> \ from\n\ -> \ partsupp,\n\ -> \ part\n\ -> \ where\n\ -> \ p_partkey = ps_partkey\n\ -> \ and p_brand <> 'Brand#15'\n\ -> \ and p_type not like 'MEDIUM BURNISHED%'\n\ -> \ and p_size in (39, 26, 18, 45, 19, 1, 3, 9)\n\ -> \ and ps_suppkey not in (\n\ -> \ select\n\ -> \ s_suppkey\n\ -> \ from\n\ -> \ supplier\n\ -> \ where\n\ -> \ s_comment like '%Customer%Complaints%'\n\ -> \ )\n\ -> \ group by\n\ -> \ p_brand,\n\ -> \ p_type,\n\ -> \ p_size\n\ -> \ order by\n\ -> \ supplier_cnt desc,\n\ -> \ p_brand,\n\ -> \ p_type,\n\ -> \ p_size") -> ,("Q17","\n\ -> \ select\n\ -> \ sum(l_extendedprice) / 7.0 as avg_yearly\n\ -> \ from\n\ -> \ lineitem,\n\ -> \ part\n\ -> \ where\n\ -> \ p_partkey = l_partkey\n\ -> \ and p_brand = 'Brand#52'\n\ -> \ and p_container = 'JUMBO CAN'\n\ -> \ and l_quantity < (\n\ -> \ select\n\ -> \ 0.2 * avg(l_quantity)\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_partkey = p_partkey\n\ -> \ )") -> ,("Q18","\n\ -> \ select\n\ -> \ c_name,\n\ -> \ c_custkey,\n\ -> \ o_orderkey,\n\ -> \ o_orderdate,\n\ -> \ o_totalprice,\n\ -> \ sum(l_quantity)\n\ -> \ from\n\ -> \ customer,\n\ -> \ orders,\n\ -> \ lineitem\n\ -> \ where\n\ -> \ o_orderkey in (\n\ -> \ select\n\ -> \ l_orderkey\n\ -> \ from\n\ -> \ lineitem\n\ -> \ group by\n\ -> \ l_orderkey having\n\ -> \ sum(l_quantity) > 313\n\ -> \ )\n\ -> \ and c_custkey = o_custkey\n\ -> \ and o_orderkey = l_orderkey\n\ -> \ group by\n\ -> \ c_name,\n\ -> \ c_custkey,\n\ -> \ o_orderkey,\n\ -> \ o_orderdate,\n\ -> \ o_totalprice\n\ -> \ order by\n\ -> \ o_totalprice desc,\n\ -> \ o_orderdate\n\ -> \ fetch first 100 rows only") -> ,("Q19","\n\ -> \ select\n\ -> \ sum(l_extendedprice* (1 - l_discount)) as revenue\n\ -> \ from\n\ -> \ lineitem,\n\ -> \ part\n\ -> \ where\n\ -> \ (\n\ -> \ p_partkey = l_partkey\n\ -> \ and p_brand = 'Brand#43'\n\ -> \ and p_container in ('SM CASE', 'SM BOX', 'SM PACK', 'SM PKG')\n\ -> \ and l_quantity >= 3 and l_quantity <= 3 + 10\n\ -> \ and p_size between 1 and 5\n\ -> \ and l_shipmode in ('AIR', 'AIR REG')\n\ -> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ -> \ )\n\ -> \ or\n\ -> \ (\n\ -> \ p_partkey = l_partkey\n\ -> \ and p_brand = 'Brand#25'\n\ -> \ and p_container in ('MED BAG', 'MED BOX', 'MED PKG', 'MED PACK')\n\ -> \ and l_quantity >= 10 and l_quantity <= 10 + 10\n\ -> \ and p_size between 1 and 10\n\ -> \ and l_shipmode in ('AIR', 'AIR REG')\n\ -> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ -> \ )\n\ -> \ or\n\ -> \ (\n\ -> \ p_partkey = l_partkey\n\ -> \ and p_brand = 'Brand#24'\n\ -> \ and p_container in ('LG CASE', 'LG BOX', 'LG PACK', 'LG PKG')\n\ -> \ and l_quantity >= 22 and l_quantity <= 22 + 10\n\ -> \ and p_size between 1 and 15\n\ -> \ and l_shipmode in ('AIR', 'AIR REG')\n\ -> \ and l_shipinstruct = 'DELIVER IN PERSON'\n\ -> \ )") -> ,("Q20","\n\ -> \ select\n\ -> \ s_name,\n\ -> \ s_address\n\ -> \ from\n\ -> \ supplier,\n\ -> \ nation\n\ -> \ where\n\ -> \ s_suppkey in (\n\ -> \ select\n\ -> \ ps_suppkey\n\ -> \ from\n\ -> \ partsupp\n\ -> \ where\n\ -> \ ps_partkey in (\n\ -> \ select\n\ -> \ p_partkey\n\ -> \ from\n\ -> \ part\n\ -> \ where\n\ -> \ p_name like 'lime%'\n\ -> \ )\n\ -> \ and ps_availqty > (\n\ -> \ select\n\ -> \ 0.5 * sum(l_quantity)\n\ -> \ from\n\ -> \ lineitem\n\ -> \ where\n\ -> \ l_partkey = ps_partkey\n\ -> \ and l_suppkey = ps_suppkey\n\ -> \ and l_shipdate >= date '1994-01-01'\n\ -> \ and l_shipdate < date '1994-01-01' + interval '1' year\n\ -> \ )\n\ -> \ )\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_name = 'VIETNAM'\n\ -> \ order by\n\ -> \ s_name") -> ,("Q21","\n\ -> \ select\n\ -> \ s_name,\n\ -> \ count(*) as numwait\n\ -> \ from\n\ -> \ supplier,\n\ -> \ lineitem l1,\n\ -> \ orders,\n\ -> \ nation\n\ -> \ where\n\ -> \ s_suppkey = l1.l_suppkey\n\ -> \ and o_orderkey = l1.l_orderkey\n\ -> \ and o_orderstatus = 'F'\n\ -> \ and l1.l_receiptdate > l1.l_commitdate\n\ -> \ and exists (\n\ -> \ select\n\ -> \ *\n\ -> \ from\n\ -> \ lineitem l2\n\ -> \ where\n\ -> \ l2.l_orderkey = l1.l_orderkey\n\ -> \ and l2.l_suppkey <> l1.l_suppkey\n\ -> \ )\n\ -> \ and not exists (\n\ -> \ select\n\ -> \ *\n\ -> \ from\n\ -> \ lineitem l3\n\ -> \ where\n\ -> \ l3.l_orderkey = l1.l_orderkey\n\ -> \ and l3.l_suppkey <> l1.l_suppkey\n\ -> \ and l3.l_receiptdate > l3.l_commitdate\n\ -> \ )\n\ -> \ and s_nationkey = n_nationkey\n\ -> \ and n_name = 'INDIA'\n\ -> \ group by\n\ -> \ s_name\n\ -> \ order by\n\ -> \ numwait desc,\n\ -> \ s_name\n\ -> \ fetch first 100 rows only") -> ,("Q22","\n\ -> \ select\n\ -> \ cntrycode,\n\ -> \ count(*) as numcust,\n\ -> \ sum(c_acctbal) as totacctbal\n\ -> \ from\n\ -> \ (\n\ -> \ select\n\ -> \ substring(c_phone from 1 for 2) as cntrycode,\n\ -> \ c_acctbal\n\ -> \ from\n\ -> \ customer\n\ -> \ where\n\ -> \ substring(c_phone from 1 for 2) in\n\ -> \ ('41', '28', '39', '21', '24', '29', '44')\n\ -> \ and c_acctbal > (\n\ -> \ select\n\ -> \ avg(c_acctbal)\n\ -> \ from\n\ -> \ customer\n\ -> \ where\n\ -> \ c_acctbal > 0.00\n\ -> \ and substring(c_phone from 1 for 2) in\n\ -> \ ('41', '28', '39', '21', '24', '29', '44')\n\ -> \ )\n\ -> \ and not exists (\n\ -> \ select\n\ -> \ *\n\ -> \ from\n\ -> \ orders\n\ -> \ where\n\ -> \ o_custkey = c_custkey\n\ -> \ )\n\ -> \ ) as custsale\n\ -> \ group by\n\ -> \ cntrycode\n\ -> \ order by\n\ -> \ cntrycode") -> ] diff --git a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs b/tools/Language/SQL/SimpleSQL/ValueExprs.lhs deleted file mode 100644 --- a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs +++ /dev/null @@ -1,406 +0,0 @@ - -Tests for parsing value expressions - -> module Language.SQL.SimpleSQL.ValueExprs (valueExprTests) where - -> import Language.SQL.SimpleSQL.TestTypes -> import Language.SQL.SimpleSQL.Syntax - -> valueExprTests :: TestItem -> valueExprTests = Group "valueExprTests" -> [literals -> ,identifiers -> ,star -> ,parameter -> ,dots -> ,app -> ,caseexp -> ,operators -> ,parens -> ,subqueries -> ,aggregates -> ,windowFunctions -> ] - -> literals :: TestItem -> literals = Group "literals" $ map (uncurry (TestValueExpr SQL2011)) -> [("3", NumLit "3") -> ,("3.", NumLit "3.") -> ,("3.3", NumLit "3.3") -> ,(".3", NumLit ".3") -> ,("3.e3", NumLit "3.e3") -> ,("3.3e3", NumLit "3.3e3") -> ,(".3e3", NumLit ".3e3") -> ,("3e3", NumLit "3e3") -> ,("3e+3", NumLit "3e+3") -> ,("3e-3", NumLit "3e-3") -> ,("'string'", StringLit "string") -> ,("'string with a '' quote'", StringLit "string with a ' quote") -> ,("'1'", StringLit "1") -> ,("interval '3' day" -> ,IntervalLit Nothing "3" (Itf "day" Nothing) Nothing) -> ,("interval '3' day (3)" -> ,IntervalLit Nothing "3" (Itf "day" $ Just (3,Nothing)) Nothing) -> ,("interval '3 weeks'", TypedLit (TypeName [Name "interval"]) "3 weeks") -> ] - -> identifiers :: TestItem -> identifiers = Group "identifiers" $ map (uncurry (TestValueExpr SQL2011)) -> [("iden1", Iden [Name "iden1"]) -> --,("t.a", Iden2 "t" "a") -> ,("\"quoted identifier\"", Iden [QName "quoted identifier"]) -> ] - -> star :: TestItem -> star = Group "star" $ map (uncurry (TestValueExpr SQL2011)) -> [("*", Star) -> --,("t.*", Star2 "t") -> --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"]) -> ] - -> parameter :: TestItem -> parameter = Group "parameter" $ map (uncurry (TestValueExpr SQL2011)) -> [("?", Parameter) -> ] - - -> dots :: TestItem -> dots = Group "dot" $ map (uncurry (TestValueExpr SQL2011)) -> [("t.a", Iden [Name "t",Name "a"]) -> ,("t.*", BinOp (Iden [Name "t"]) [Name "."] Star) -> ,("a.b.c", Iden [Name "a",Name "b",Name "c"]) -> ,("ROW(t.*,42)", App [Name "ROW"] [BinOp (Iden [Name "t"]) [Name "."] Star, NumLit "42"]) -> ] - -> app :: TestItem -> app = Group "app" $ map (uncurry (TestValueExpr SQL2011)) -> [("f()", App [Name "f"] []) -> ,("f(a)", App [Name "f"] [Iden [Name "a"]]) -> ,("f(a,b)", App [Name "f"] [Iden [Name "a"], Iden [Name "b"]]) -> ] - -> caseexp :: TestItem -> caseexp = Group "caseexp" $ map (uncurry (TestValueExpr SQL2011)) -> [("case a when 1 then 2 end" -> ,Case (Just $ Iden [Name "a"]) [([NumLit "1"] -> ,NumLit "2")] Nothing) - -> ,("case a when 1 then 2 when 3 then 4 end" -> ,Case (Just $ Iden [Name "a"]) [([NumLit "1"], NumLit "2") -> ,([NumLit "3"], NumLit "4")] Nothing) - -> ,("case a when 1 then 2 when 3 then 4 else 5 end" -> ,Case (Just $ Iden [Name "a"]) [([NumLit "1"], NumLit "2") -> ,([NumLit "3"], NumLit "4")] -> (Just $ NumLit "5")) - -> ,("case when a=1 then 2 when a=3 then 4 else 5 end" -> ,Case Nothing [([BinOp (Iden [Name "a"]) [Name "="] (NumLit "1")], NumLit "2") -> ,([BinOp (Iden [Name "a"]) [Name "="] (NumLit "3")], NumLit "4")] -> (Just $ NumLit "5")) - -> ,("case a when 1,2 then 10 when 3,4 then 20 end" -> ,Case (Just $ Iden [Name "a"]) [([NumLit "1",NumLit "2"] -> ,NumLit "10") -> ,([NumLit "3",NumLit "4"] -> ,NumLit "20")] -> Nothing) - -> ] - -> operators :: TestItem -> operators = Group "operators" -> [binaryOperators -> ,unaryOperators -> ,casts -> ,miscOps] - -> binaryOperators :: TestItem -> binaryOperators = Group "binaryOperators" $ map (uncurry (TestValueExpr SQL2011)) -> [("a + b", BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"])) -> -- sanity check fixities -> -- todo: add more fixity checking - -> ,("a + b * c" -> ,BinOp (Iden [Name "a"]) [Name "+"] -> (BinOp (Iden [Name "b"]) [Name "*"] (Iden [Name "c"]))) - -> ,("a * b + c" -> ,BinOp (BinOp (Iden [Name "a"]) [Name "*"] (Iden [Name "b"])) -> [Name "+"] (Iden [Name "c"])) -> ] - -> unaryOperators :: TestItem -> unaryOperators = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) -> [("not a", PrefixOp [Name "not"] $ Iden [Name "a"]) -> ,("not not a", PrefixOp [Name "not"] $ PrefixOp [Name "not"] $ Iden [Name "a"]) -> ,("+a", PrefixOp [Name "+"] $ Iden [Name "a"]) -> ,("-a", PrefixOp [Name "-"] $ Iden [Name "a"]) -> ] - - -> casts :: TestItem -> casts = Group "operators" $ map (uncurry (TestValueExpr SQL2011)) -> [("cast('1' as int)" -> ,Cast (StringLit "1") $ TypeName [Name "int"]) - -> ,("int '3'" -> ,TypedLit (TypeName [Name "int"]) "3") - -> ,("cast('1' as double precision)" -> ,Cast (StringLit "1") $ TypeName [Name "double precision"]) - -> ,("cast('1' as float(8))" -> ,Cast (StringLit "1") $ PrecTypeName [Name "float"] 8) - -> ,("cast('1' as decimal(15,2))" -> ,Cast (StringLit "1") $ PrecScaleTypeName [Name "decimal"] 15 2) - - -> ,("double precision '3'" -> ,TypedLit (TypeName [Name "double precision"]) "3") -> ] - -> subqueries :: TestItem -> subqueries = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) -> [("exists (select a from t)", SubQueryExpr SqExists ms) -> ,("(select a from t)", SubQueryExpr SqSq ms) - -> ,("a in (select a from t)" -> ,In True (Iden [Name "a"]) (InQueryExpr ms)) - -> ,("a not in (select a from t)" -> ,In False (Iden [Name "a"]) (InQueryExpr ms)) - -> ,("a > all (select a from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name ">"] CPAll ms) - -> ,("a = some (select a from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name "="] CPSome ms) - -> ,("a <= any (select a from t)" -> ,QuantifiedComparison (Iden [Name "a"]) [Name "<="] CPAny ms) -> ] -> where -> ms = makeSelect -> {qeSelectList = [(Iden [Name "a"],Nothing)] -> ,qeFrom = [TRSimple [Name "t"]] -> } - -> miscOps :: TestItem -> miscOps = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011)) -> [("a in (1,2,3)" -> ,In True (Iden [Name "a"]) $ InList $ map NumLit ["1","2","3"]) - -> ,("a is null", PostfixOp [Name "is null"] (Iden [Name "a"])) -> ,("a is not null", PostfixOp [Name "is not null"] (Iden [Name "a"])) -> ,("a is true", PostfixOp [Name "is true"] (Iden [Name "a"])) -> ,("a is not true", PostfixOp [Name "is not true"] (Iden [Name "a"])) -> ,("a is false", PostfixOp [Name "is false"] (Iden [Name "a"])) -> ,("a is not false", PostfixOp [Name "is not false"] (Iden [Name "a"])) -> ,("a is unknown", PostfixOp [Name "is unknown"] (Iden [Name "a"])) -> ,("a is not unknown", PostfixOp [Name "is not unknown"] (Iden [Name "a"])) -> ,("a is distinct from b", BinOp (Iden [Name "a"]) [Name "is distinct from"] (Iden [Name "b"])) - -> ,("a is not distinct from b" -> ,BinOp (Iden [Name "a"]) [Name "is not distinct from"] (Iden [Name "b"])) - -> ,("a like b", BinOp (Iden [Name "a"]) [Name "like"] (Iden [Name "b"])) -> ,("a not like b", BinOp (Iden [Name "a"]) [Name "not like"] (Iden [Name "b"])) -> ,("a is similar to b", BinOp (Iden [Name "a"]) [Name "is similar to"] (Iden [Name "b"])) - -> ,("a is not similar to b" -> ,BinOp (Iden [Name "a"]) [Name "is not similar to"] (Iden [Name "b"])) - -> ,("a overlaps b", BinOp (Iden [Name "a"]) [Name "overlaps"] (Iden [Name "b"])) - - -special operators - -> ,("a between b and c", SpecialOp [Name "between"] [Iden [Name "a"] -> ,Iden [Name "b"] -> ,Iden [Name "c"]]) - -> ,("a not between b and c", SpecialOp [Name "not between"] [Iden [Name "a"] -> ,Iden [Name "b"] -> ,Iden [Name "c"]]) -> ,("(1,2)" -> ,SpecialOp [Name "rowctor"] [NumLit "1", NumLit "2"]) - - -keyword special operators - -> ,("extract(day from t)" -> , SpecialOpK [Name "extract"] (Just $ Iden [Name "day"]) [("from", Iden [Name "t"])]) - -> ,("substring(x from 1 for 2)" -> ,SpecialOpK [Name "substring"] (Just $ Iden [Name "x"]) [("from", NumLit "1") -> ,("for", NumLit "2")]) - -> ,("substring(x from 1)" -> ,SpecialOpK [Name "substring"] (Just $ Iden [Name "x"]) [("from", NumLit "1")]) - -> ,("substring(x for 2)" -> ,SpecialOpK [Name "substring"] (Just $ Iden [Name "x"]) [("for", NumLit "2")]) - -> ,("substring(x from 1 for 2 collate C)" -> ,SpecialOpK [Name "substring"] (Just $ Iden [Name "x"]) -> [("from", NumLit "1") -> ,("for", Collate (NumLit "2") [Name "C"])]) - -this doesn't work because of a overlap in the 'in' parser - -> ,("POSITION( string1 IN string2 )" -> ,SpecialOpK [Name "position"] (Just $ Iden [Name "string1"]) [("in", Iden [Name "string2"])]) - -> ,("CONVERT(char_value USING conversion_char_name)" -> ,SpecialOpK [Name "convert"] (Just $ Iden [Name "char_value"]) -> [("using", Iden [Name "conversion_char_name"])]) - -> ,("TRANSLATE(char_value USING translation_name)" -> ,SpecialOpK [Name "translate"] (Just $ Iden [Name "char_value"]) -> [("using", Iden [Name "translation_name"])]) - -OVERLAY(string PLACING embedded_string FROM start -[FOR length]) - -> ,("OVERLAY(string PLACING embedded_string FROM start)" -> ,SpecialOpK [Name "overlay"] (Just $ Iden [Name "string"]) -> [("placing", Iden [Name "embedded_string"]) -> ,("from", Iden [Name "start"])]) - -> ,("OVERLAY(string PLACING embedded_string FROM start FOR length)" -> ,SpecialOpK [Name "overlay"] (Just $ Iden [Name "string"]) -> [("placing", Iden [Name "embedded_string"]) -> ,("from", Iden [Name "start"]) -> ,("for", Iden [Name "length"])]) - -TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ] -target_string -[COLLATE collation_name] ) - - - -> ,("trim(from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("both", StringLit " ") -> ,("from", Iden [Name "target_string"])]) - -> ,("trim(leading from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("leading", StringLit " ") -> ,("from", Iden [Name "target_string"])]) - -> ,("trim(trailing from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("trailing", StringLit " ") -> ,("from", Iden [Name "target_string"])]) - -> ,("trim(both from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("both", StringLit " ") -> ,("from", Iden [Name "target_string"])]) - - -> ,("trim(leading 'x' from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("leading", StringLit "x") -> ,("from", Iden [Name "target_string"])]) - -> ,("trim(trailing 'y' from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("trailing", StringLit "y") -> ,("from", Iden [Name "target_string"])]) - -> ,("trim(both 'z' from target_string collate C)" -> ,SpecialOpK [Name "trim"] Nothing -> [("both", StringLit "z") -> ,("from", Collate (Iden [Name "target_string"]) [Name "C"])]) - -> ,("trim(leading from target_string)" -> ,SpecialOpK [Name "trim"] Nothing -> [("leading", StringLit " ") -> ,("from", Iden [Name "target_string"])]) - - -> ] - -> aggregates :: TestItem -> aggregates = Group "aggregates" $ map (uncurry (TestValueExpr SQL2011)) -> [("count(*)",App [Name "count"] [Star]) - -> ,("sum(a order by a)" -> ,AggregateApp [Name "sum"] SQDefault [Iden [Name "a"]] -> [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault] Nothing) - -> ,("sum(all a)" -> ,AggregateApp [Name "sum"] All [Iden [Name "a"]] [] Nothing) - -> ,("count(distinct a)" -> ,AggregateApp [Name "count"] Distinct [Iden [Name "a"]] [] Nothing) -> ] - -> windowFunctions :: TestItem -> windowFunctions = Group "windowFunctions" $ map (uncurry (TestValueExpr SQL2011)) -> [("max(a) over ()", WindowApp [Name "max"] [Iden [Name "a"]] [] [] Nothing) -> ,("count(*) over ()", WindowApp [Name "count"] [Star] [] [] Nothing) - -> ,("max(a) over (partition by b)" -> ,WindowApp [Name "max"] [Iden [Name "a"]] [Iden [Name "b"]] [] Nothing) - -> ,("max(a) over (partition by b,c)" -> ,WindowApp [Name "max"] [Iden [Name "a"]] [Iden [Name "b"],Iden [Name "c"]] [] Nothing) - -> ,("sum(a) over (order by b)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [] -> [SortSpec (Iden [Name "b"]) DirDefault NullsOrderDefault] Nothing) - -> ,("sum(a) over (order by b desc,c)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [] -> [SortSpec (Iden [Name "b"]) Desc NullsOrderDefault -> ,SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] Nothing) - -> ,("sum(a) over (partition by b order by c)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] Nothing) - -> ,("sum(a) over (partition by b order by c range unbounded preceding)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameFrom FrameRange UnboundedPreceding) - -> ,("sum(a) over (partition by b order by c range 5 preceding)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameFrom FrameRange $ Preceding (NumLit "5")) - -> ,("sum(a) over (partition by b order by c range current row)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameFrom FrameRange Current) - -> ,("sum(a) over (partition by b order by c rows 5 following)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameFrom FrameRows $ Following (NumLit "5")) - -> ,("sum(a) over (partition by b order by c range unbounded following)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameFrom FrameRange UnboundedFollowing) - -> ,("sum(a) over (partition by b order by c \n\ -> \range between 5 preceding and 5 following)" -> ,WindowApp [Name "sum"] [Iden [Name "a"]] [Iden [Name "b"]] -> [SortSpec (Iden [Name "c"]) DirDefault NullsOrderDefault] -> $ Just $ FrameBetween FrameRange -> (Preceding (NumLit "5")) -> (Following (NumLit "5"))) - -> ] - -> parens :: TestItem -> parens = Group "parens" $ map (uncurry (TestValueExpr SQL2011)) -> [("(a)", Parens (Iden [Name "a"])) -> ,("(a + b)", Parens (BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"]))) -> ] diff --git a/tools/RunTests.lhs b/tools/RunTests.lhs deleted file mode 100644 --- a/tools/RunTests.lhs +++ /dev/null @@ -1,8 +0,0 @@ - - -> import Test.Framework - -> import Language.SQL.SimpleSQL.Tests - -> main :: IO () -> main = defaultMain [tests] diff --git a/tools/SQLIndent.lhs b/tools/SQLIndent.lhs deleted file mode 100644 --- a/tools/SQLIndent.lhs +++ /dev/null @@ -1,17 +0,0 @@ - -> import System.Environment - -> import Language.SQL.SimpleSQL.Pretty -> import Language.SQL.SimpleSQL.Parser -> import Language.SQL.SimpleSQL.Syntax - -> main :: IO () -> main = do -> args <- getArgs -> case args of -> [f] -> do -> src <- readFile f -> either (error . peFormattedError) -> (putStrLn . prettyQueryExprs SQL2011) -> $ parseQueryExprs SQL2011 f Nothing src -> _ -> error "please pass filename to indent"