starlitcanopy/simple-sql-parser
1
Fork 0
Code Activity

switch tests to hspec, improve error messages

Browse source
This commit is contained in:
Jake Wheat 2024-02-04 16:00:59 +00:00
parent fadd010942
commit c11bee4a9c
36 changed files with 2570 additions and 1809 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

347
Language/SQL/SimpleSQL/Lex.hs
View file

@ -74,7 +74,6 @@ try again to add annotation to the ast
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Language.SQL.SimpleSQL.Lex
(Token(..)
,WithPos(..)
@ -111,21 +110,26 @@ import Text.Megaparsec
,pstateSourcePos
,statePosState
,mkPos
,hidden
,setErrorOffset
,choice
,satisfy
,takeWhileP
,takeWhile1P
,(<?>)
,eof
,many
,try
,option
,(<|>)
,notFollowedBy
,manyTill
,anySingle
,lookAhead
,match
,optional
,label
,chunk
,region
,anySingle
)
import qualified Text.Megaparsec as M
import Text.Megaparsec.Char
@ -139,17 +143,17 @@ import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import Control.Applicative ((<**>))
import Data.Char
(isAlphaNum
,isAlpha
,isSpace
,isDigit
)
import Control.Monad (void, guard)
import Control.Monad (void)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
--import Text.Megaparsec.Debug (dbg)
------------------------------------------------------------------------------
@ -189,16 +193,26 @@ data Token
| 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.
-- | 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)
@ -207,13 +221,14 @@ lexSQLWithPositions
-> Text
-- ^ the SQL source to lex
-> Either ParseError [WithPos Token]
lexSQLWithPositions dialect fn p src = myParse fn p (many (sqlToken dialect) <* (eof <?> "")) src
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)
@ -222,8 +237,8 @@ lexSQL
-> Text
-- ^ the SQL source to lex
-> Either ParseError [Token]
lexSQL dialect fn p src =
map tokenVal <$> lexSQLWithPositions dialect fn p src
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 =
@ -271,6 +286,7 @@ 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
@ -281,24 +297,54 @@ prettyTokens d ts = T.concat $ map (prettyToken d) ts
-- | parser for a sql token
sqlToken :: Dialect -> Parser (WithPos Token)
sqlToken d = (do
-- possibly there's a more efficient way of doing the source positions?
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
t <- choice
[sqlString d
,identifier d
,lineComment d
,blockComment d
,sqlNumber d
,positionalArg d
,dontParseEndBlockComment d
,prefixedVariable d
,symbol d
,sqlWhitespace d]
a <- p
off1 <- getOffset
ep <- getSourcePos
pure $ WithPos sp ep (off1 - off) t) <?> "valid lexical token"
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
--------------------------------------
@ -313,27 +359,38 @@ x'hexidecimal string'
-}
sqlString :: Dialect -> Parser Token
sqlString d = dollarString <|> csString <|> normalString
sqlString d =
(if (diDollarString d)
then (dollarString <|>)
else id) csString <|> normalString
where
dollarString = do
guard $ diDollarString d
-- use try because of ambiguity with symbols and with
-- positional arg
delim <- (\x -> T.concat ["$",x,"$"])
<$> try (char '$' *> option "" identifierString <* char '$')
SqlString delim delim . T.pack <$> manyTill anySingle (try $ string delim)
normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix False "")
normalStringSuffix allowBackslash t = do
s <- takeWhileP Nothing $ if allowBackslash
then (`notElemChar` "'\\")
else (/= '\'')
-- deal with '' or \' as literal quote character
choice [do
ctu <- choice ["''" <$ try (string "''")
,"\\'" <$ string "\\'"
,"\\" <$ char '\\']
normalStringSuffix allowBackslash $ T.concat [t,s,ctu]
,T.concat [t,s] <$ char '\'']
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 '
@ -345,13 +402,13 @@ sqlString d = dollarString <|> csString <|> normalString
csString
| diEString d =
choice [SqlString <$> try (string "e'" <|> string "E'")
<*> pure "'" <*> normalStringSuffix True ""
<*> pure "'" <*> normalStringSuffix True
,csString']
| otherwise = csString'
csString' = SqlString
<$> try cs
<*> pure "'"
<*> normalStringSuffix False ""
<*> normalStringSuffix False
csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"]
cs :: Parser Text
cs = choice $ map string csPrefixes
@ -370,42 +427,49 @@ u&"unicode quoted identifier"
identifier :: Dialect -> Parser Token
identifier d =
choice
choice $
[quotedIden
,unicodeQuotedIden
,regularIden
,guard (diBackquotedIden d) >> mySqlQuotedIden
,guard (diSquareBracketQuotedIden d) >> sqlServerQuotedIden
]
,regularIden]
++ [mySqlQuotedIden | diBackquotedIden d]
++ [sqlServerQuotedIden | diSquareBracketQuotedIden d]
where
regularIden = Identifier Nothing <$> identifierString
quotedIden = Identifier (Just ("\"","\"")) <$> qidenPart
mySqlQuotedIden = Identifier (Just ("`","`"))
<$> (char '`' *> takeWhile1P Nothing (/='`') <* char '`')
sqlServerQuotedIden = Identifier (Just ("[","]"))
<$> (char '[' *> takeWhile1P Nothing (`notElemChar` "[]") <* char ']')
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 "&"))
<*> qidenPart
<*> qiden
where f x = Just (T.cons x "&\"", "\"")
qidenPart = char '"' *> qidenSuffix ""
qidenSuffix t = do
s <- takeWhileP Nothing (/='"')
void $ char '"'
-- deal with "" as literal double quote character
choice [do
void $ char '"'
qidenSuffix $ T.concat [t,s,"\"\""]
,pure $ T.concat [t,s]]
qiden =
char_ '"' *> (failEmptyIden '"' <|> fstMatch moreQIden <* char_ '"')
moreQIden =
label "\""
(takeWhileP_ Nothing (/='"')
*> hoptional_ (chunk "\"\"" *> moreQIden))
identifierString :: Parser Text
identifierString = (do
identifierString = label "identifier" $ do
c <- satisfy isFirstLetter
choice
[T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar
,pure $ T.singleton c]) <?> "identifier"
[T.cons c <$> takeWhileP Nothing isIdentifierChar
,pure $ T.singleton c]
where
isFirstLetter c = c == '_' || isAlpha c
@ -415,12 +479,11 @@ isIdentifierChar c = c == '_' || isAlphaNum c
--------------------------------------
lineComment :: Dialect -> Parser Token
lineComment _ = do
try (string_ "--") <?> ""
rest <- takeWhileP (Just "non newline character") (/='\n')
lineComment _ = LineComment <$> fstMatch (do
hidden (string_ "--")
takeWhileP_ Nothing (/='\n')
-- can you optionally read the \n to terminate the takewhilep without reparsing it?
suf <- option "" ("\n" <$ char_ '\n')
pure $ LineComment $ T.concat ["--", rest, suf]
hoptional_ $ char_ '\n')
--------------------------------------
@ -428,28 +491,30 @@ lineComment _ = do
-- 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 _ = (do
try $ string_ "/*"
BlockComment . T.concat . ("/*":) <$> more) <?> ""
blockComment _ = BlockComment <$> fstMatch bc
where
more = choice
[["*/"] <$ try (string_ "*/") -- comment ended
,char_ '*' *> (("*":) <$> more) -- comment contains * but this isn't the comment end token
-- not sure if there's an easy optimisation here
,(:) <$> takeWhile1P (Just "non comment terminator text") (/= '*') <*> more]
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 (which is a stupid thing to do). In other cases, the user
should write * / instead (I can't think of any cases when this would
be valid syntax though).
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 _ =
-- don't use try, then it should commit to the error
try (string "*/") *> fail "comment end without comment start"
failOnThis (chunk_ "*/") "comment end without comment start"
--------------------------------------
@ -482,63 +547,51 @@ followed by an optional exponent
sqlNumber :: Dialect -> Parser Token
sqlNumber d =
SqlNumber <$> completeNumber
-- this is for definitely avoiding possibly ambiguous source
<* choice [-- special case to allow e.g. 1..2
guard (diPostgresSymbols d)
*> void (lookAhead $ try (string ".." <?> ""))
<|> void (notFollowedBy (oneOf "eE."))
,notFollowedBy (oneOf "eE.")
]
SqlNumber <$> fstMatch
((numStartingWithDigits <|> numStartingWithDot)
*> hoptional_ expo *> trailingCheck)
where
completeNumber =
(digits <??> (pp dot <??.> pp digits)
-- try is used in case we read a dot
-- and it isn't part of a number
-- if there are any following digits, then we commit
-- to it being a number and not something else
<|> try ((<>) <$> dot <*> digits))
<??> pp expon
-- make sure we don't parse two adjacent dots in a number
-- special case for postgresql, we backtrack if we see two adjacent dots
-- to parse 1..2, but in other dialects we commit to the failure
dot = let p = string "." <* notFollowedBy (char '.')
in if diPostgresSymbols d
then try p
else p
expon = T.cons <$> oneOf "eE" <*> sInt
sInt = (<>) <$> option "" (T.singleton <$> oneOf "+-") <*> digits
pp = (<$$> (<>))
p <??> q = p <**> option id q
pa <$$> c = pa <**> pure (flip c)
pa <??.> pb =
let c = (<$>) . flip
in (.) `c` pa <*> option id pb
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 = takeWhile1P (Just "digit") isDigit
digits = label "digits" $ takeWhile1P Nothing isDigit
--------------------------------------
positionalArg :: Dialect -> Parser Token
positionalArg d =
guard (diPositionalArg d) >>
-- use try to avoid ambiguities with other syntax which starts with dollar
PositionalArg <$> try (char_ '$' *> (read . T.unpack <$> digits))
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
,guard (diAtIdentifier d) >>
PrefixedVariable <$> char '@' <*> identifierString
,guard (diHashIdentifier d) >>
PrefixedVariable <$> char '#' <*> identifierString
]
prefixedVariable d = try $ choice $
[PrefixedVariable <$> char ':' <*> identifierString]
++ [PrefixedVariable <$> char '@' <*> identifierString | diAtIdentifier d]
++ [PrefixedVariable <$> char '#' <*> identifierString | diHashIdentifier d]
--------------------------------------
@ -565,7 +618,7 @@ symbol d = Symbol <$> choice (concat
else basicAnsiOps
])
where
dots = [takeWhile1P (Just "dot") (=='.')]
dots = [takeWhile1P Nothing (=='.')]
odbcSymbol = [string "{", string "}"]
postgresExtraSymbols =
[try (string ":=")
@ -670,7 +723,7 @@ generalizedPostgresqlOperator = [singlePlusMinus,opMoreChars]
--------------------------------------
sqlWhitespace :: Dialect -> Parser Token
sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
sqlWhitespace _ = Whitespace <$> takeWhile1P Nothing isSpace
----------------------------------------------------------------------------
@ -679,6 +732,9 @@ sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
char_ :: Char -> Parser ()
char_ = void . char
hchar_ :: Char -> Parser ()
hchar_ = void . hidden . char
string_ :: Text -> Parser ()
string_ = void . string
@ -688,6 +744,39 @@ 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
----------------------------------------------------------------------------

403
Language/SQL/SimpleSQL/Parse.hs
View file

@ -195,8 +195,8 @@ import Text.Megaparsec
,ParseErrorBundle(..)
,errorBundlePretty
,hidden
,(<?>)
,(<|>)
,token
,choice
@ -212,6 +212,7 @@ import Text.Megaparsec
)
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
@ -235,6 +236,8 @@ 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)
------------------------------------------------------------------------------
@ -324,9 +327,9 @@ wrapParse :: Parser a
-> Text
-> Either ParseError a
wrapParse parser d f p src = do
lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d f p src
lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d True f p src
either (Left . ParseError) Right $
runReader (runParserT (parser <* (eof <?> "")) (T.unpack f)
runReader (runParserT (parser <* (hidden eof)) (T.unpack f)
$ L.SQLStream (T.unpack src) $ filter notSpace lx) d
where
notSpace = notSpace' . L.tokenVal
@ -379,20 +382,20 @@ u&"example quoted"
-}
name :: Parser Name
name = do
name = label "name" $ do
bl <- askDialect diKeywords
uncurry Name <$> identifierTok bl
-- todo: replace (:[]) with a named function all over
names :: Parser [Name]
names = reverse <$> (((:[]) <$> name) <??*> anotherName)
names = label "name" (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) <?> ""))
anotherName = try ((:) <$> (hidden (symbol "." *> name)))
{-
= Type Names
@ -501,36 +504,48 @@ 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 =
(rowTypeName <|> intervalTypeName <|> otherTypeName)
<??*> tnSuffix
typeName = typeName' False
typeName' :: Bool -> Parser TypeName
typeName' hideArg =
label "typename" (
(rowTypeName <|> intervalTypeName <|> otherTypeName)
<??*> tnSuffix)
where
rowTypeName =
RowTypeName <$> (keyword_ "row" *> parens (commaSep1 rowField))
RowTypeName <$> (hidden (keyword_ "row") *> parens (commaSep1 rowField))
rowField = (,) <$> name <*> typeName
----------------------------
intervalTypeName =
keyword_ "interval" *>
hidden (keyword_ "interval") *>
(uncurry IntervalTypeName <$> intervalQualifier)
----------------------------
otherTypeName =
nameOfType <**>
(typeNameWithParens
<|> pure Nothing <**> (timeTypeName <|> charTypeName)
<|> pure Nothing <**> (hidden timeTypeName <|> hidden charTypeName)
<|> pure TypeName)
nameOfType = reservedTypeNames <|> names
charTypeName = charSet <**> (option [] tcollate <$$$$> CharTypeName)
<|> pure [] <**> (tcollate <$$$$> CharTypeName)
typeNameWithParens =
(openParen *> unsignedInteger)
<**> (closeParen *> precMaybeSuffix
<|> (precScaleTypeName <|> precLengthTypeName) <* closeParen)
(hidden openParen *> (if hideArg then hidden unsignedInteger else unsignedInteger))
<**> (closeParen *> hidden precMaybeSuffix
<|> hidden (precScaleTypeName <|> precLengthTypeName) <* closeParen)
precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName)
<|> pure (flip PrecTypeName)
precScaleTypeName = (comma *> unsignedInteger) <$$$> PrecScaleTypeName
precScaleTypeName =
(hidden comma *> (if hideArg then hidden unsignedInteger else unsignedInteger))
<$$$> PrecScaleTypeName
precLengthTypeName =
Just <$> lobPrecSuffix
<**> (optional lobUnits <$$$$> PrecLengthTypeName)
@ -609,7 +624,7 @@ parameter = choice
[Parameter <$ questionMark
,HostParameter
<$> hostParamTok
<*> optional (keyword "indicator" *> hostParamTok)]
<*> hoptional (keyword "indicator" *> hostParamTok)]
-- == positional arg
@ -734,11 +749,12 @@ this. also fix the monad -> applicative
-}
intervalLit :: Parser ScalarExpr
intervalLit = try (keyword_ "interval" >> do
s <- optional $ choice [Plus <$ symbol_ "+"
,Minus <$ symbol_ "-"]
intervalLit =
label "interval literal" $ try (keyword_ "interval" >> do
s <- hoptional $ choice [Plus <$ symbol_ "+"
,Minus <$ symbol_ "-"]
lit <- singleQuotesOnlyStringTok
q <- optional intervalQualifier
q <- hoptional intervalQualifier
mkIt s lit q)
where
mkIt Nothing val Nothing = pure $ TypedLit (TypeName [Name Nothing "interval"]) val
@ -764,23 +780,41 @@ all the scalar expressions which start with an identifier
idenExpr :: Parser ScalarExpr
idenExpr =
-- todo: work out how to left factor this
try (TypedLit <$> typeName <*> singleQuotesOnlyStringTok)
<|> (names <**> option Iden app)
<|> keywordFunctionOrIden
-- 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
-- special cases for keywords that can be parsed as an iden or app
keywordFunctionOrIden = try $ do
x <- unquotedIdentifierTok [] Nothing
-- 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 <**> hoption Iden app))
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] <**> option Iden app
| i -> pure (Iden [Name Nothing x])
| a -> pure [Name Nothing x] <**> app
| otherwise -> fail ""
_ | i && a -> pure [Name Nothing x] <**> hoption Iden app
| i -> pure (Iden [Name Nothing x])
| a -> pure [Name Nothing x] <**> app
| otherwise -> -- shouldn't get here
fail $ "unexpected keyword: " <> T.unpack x
{-
=== special
@ -814,7 +848,7 @@ specialOpK opName firstArg kws =
case (e,kws) of
(Iden [Name Nothing i], (k,_):_)
| T.toLower i == k ->
fail $ "cannot use keyword here: " ++ T.unpack i
fail $ "unexpected " ++ T.unpack i
_ -> pure ()
pure e
fa <- case firstArg of
@ -921,24 +955,24 @@ together.
app :: Parser ([Name] -> ScalarExpr)
app =
openParen *> choice
[duplicates
hidden openParen *> choice
[hidden duplicates
<**> (commaSep1 scalarExpr
<**> ((option [] orderBy <* closeParen)
<**> (optional afilter <$$$$$> AggregateApp)))
<**> ((hoption [] orderBy <* closeParen)
<**> (hoptional afilter <$$$$$> AggregateApp)))
-- separate cases with no all or distinct which must have at
-- least one scalar expr
,commaSep1 scalarExpr
<**> choice
[closeParen *> choice
[closeParen *> hidden (choice
[window
,withinGroup
,(Just <$> afilter) <$$$> aggAppWithoutDupeOrd
,pure (flip App)]
,orderBy <* closeParen
<**> (optional afilter <$$$$> aggAppWithoutDupe)]
,pure (flip App)])
,hidden orderBy <* closeParen
<**> (hoptional afilter <$$$$> aggAppWithoutDupe)]
-- no scalarExprs: duplicates and order by not allowed
,([] <$ closeParen) <**> option (flip App) (window <|> withinGroup)
,([] <$ closeParen) <**> hoption (flip App) (window <|> withinGroup)
]
where
aggAppWithoutDupeOrd n es f = AggregateApp n SQDefault es [] f
@ -970,8 +1004,11 @@ window =
<**> (option [] orderBy
<**> ((optional frameClause <* closeParen) <$$$$$> WindowApp))
where
partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr
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)
@ -1128,8 +1165,8 @@ scalar expressions (the other is a variation on joins)
odbcExpr :: Parser ScalarExpr
odbcExpr = between (symbol "{") (symbol "}")
(odbcTimeLit <|> odbcFunc)
odbcExpr =
braces (odbcTimeLit <|> odbcFunc)
where
odbcTimeLit =
OdbcLiteral <$> choice [OLDate <$ keyword "d"
@ -1232,33 +1269,33 @@ opTable bExpr =
]
where
binarySymL nm = E.InfixL (mkBinOp nm <$ symbol_ nm)
binarySymR nm = E.InfixR (mkBinOp nm <$ symbol_ nm)
binarySymN nm = E.InfixN (mkBinOp nm <$ symbol_ nm)
binaryKeywordN nm = E.InfixN (mkBinOp nm <$ keyword_ nm)
binaryKeywordL nm = E.InfixL (mkBinOp nm <$ keyword_ nm)
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 (PrefixOp (mkNm nm) <$ symbol_ nm)
prefixKeyword nm = prefix (PrefixOp (mkNm nm) <$ keyword_ nm)
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 (do
E.InfixN (hidden $ do
o <- try p
pure (\a b -> BinOp a [Name Nothing $ T.unwords o] b))
multisetBinOp = E.InfixL (do
multisetBinOp = E.InfixL (hidden $ do
keyword_ "multiset"
o <- choice [Union <$ keyword_ "union"
,Intersect <$ keyword_ "intersect"
,Except <$ keyword_ "except"]
d <- option SQDefault duplicates
d <- hoption SQDefault duplicates
pure (\a b -> MultisetBinOp a o d b))
postfixKeywords p =
postfix $ do
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 p
prefix p = E.Prefix $ foldr1 (.) <$> some p
postfix p = E.Postfix $ foldr1 (flip (.)) <$> some (hidden p)
prefix p = E.Prefix $ foldr1 (.) <$> some (hidden p)
{-
== scalar expression top level
@ -1271,31 +1308,32 @@ documenting/fixing.
-}
scalarExpr :: Parser ScalarExpr
scalarExpr = E.makeExprParser term (opTable False)
scalarExpr = label "expression" $ E.makeExprParser term (opTable False)
term :: Parser ScalarExpr
term = choice [simpleLiteral
,parameter
,positionalArg
,star
,parensExpr
,caseExpr
,cast
,convertSqlServer
,arrayCtor
,multisetCtor
,nextValueFor
,subquery
,intervalLit
,specialOpKs
,idenExpr
,odbcExpr]
<?> "scalar expression"
term = label "expression" $
choice
[simpleLiteral
,parameter
,positionalArg
,star
,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 = E.makeExprParser term (opTable True)
scalarExprB = label "expression" $ E.makeExprParser term (opTable True)
{-
== helper parsers
@ -1321,9 +1359,10 @@ use a data type for the datetime field?
-}
datetimeField :: Parser Text
datetimeField = choice (map keyword ["year","month","day"
,"hour","minute","second"])
<?> "datetime field"
datetimeField =
choice (map keyword ["year","month","day"
,"hour","minute","second"])
<?> "datetime field"
{-
This is used in multiset operations (scalar expr), selects (query expr)
@ -1344,8 +1383,8 @@ duplicates =
-}
selectItem :: Parser (ScalarExpr,Maybe Name)
selectItem = (,) <$> scalarExpr <*> optional als
where als = optional (keyword_ "as") *> name
selectItem = label "select item" ((,) <$> scalarExpr <*> optional als)
where als = label "alias" $ optional (keyword_ "as") *> name
selectList :: Parser [(ScalarExpr,Maybe Name)]
selectList = commaSep1 selectItem
@ -1366,33 +1405,33 @@ aliases.
-}
from :: Parser [TableRef]
from = keyword_ "from" *> commaSep1 tref
from = label "from" (keyword_ "from" *> commaSep1 tref)
where
-- TODO: use P (a->) for the join tref suffix
-- chainl or buildexpressionparser
tref = (nonJoinTref <?> "table ref") >>= optionSuffix joinTrefSuffix
tref = (nonJoinTref <?> "table ref") >>= hoptionSuffix joinTrefSuffix
nonJoinTref = choice
[parens $ choice
[hidden $ parens $ choice
[TRQueryExpr <$> queryExpr
,TRParens <$> tref]
,TRLateral <$> (keyword_ "lateral"
,TRLateral <$> (hidden (keyword_ "lateral")
*> nonJoinTref)
,do
n <- names
choice [TRFunction n
<$> parens (commaSep scalarExpr)
<$> hidden (parens (commaSep scalarExpr))
,pure $ TRSimple n]
-- todo: I think you can only have outer joins inside the oj,
-- not sure.
,TROdbc <$> (symbol "{" *> keyword_ "oj" *> tref <* symbol "}")
,TROdbc <$> (hidden (braces (keyword_ "oj" *> tref)))
] <??> aliasSuffix
aliasSuffix = fromAlias <$$> TRAlias
aliasSuffix = hidden (fromAlias <$$> TRAlias)
joinTrefSuffix t =
((TRJoin t <$> option False (True <$ keyword_ "natural")
<*> joinType
<*> nonJoinTref
<*> optional joinCondition)
>>= optionSuffix joinTrefSuffix) <?> ""
<*> hoptional joinCondition)
>>= hoptionSuffix joinTrefSuffix)
{-
TODO: factor the join stuff to produce better error messages (and make
@ -1422,8 +1461,8 @@ joinCondition = choice
fromAlias :: Parser Alias
fromAlias = Alias <$> tableAlias <*> columnAliases
where
tableAlias = optional (keyword_ "as") *> name
columnAliases = optional $ parens $ commaSep1 name
tableAlias = hoptional (keyword_ "as") *> name
columnAliases = hoptional $ parens $ commaSep1 name
{-
== simple other parts
@ -1433,10 +1472,11 @@ pretty trivial.
-}
whereClause :: Parser ScalarExpr
whereClause = keyword_ "where" *> scalarExpr
whereClause = label "where" (keyword_ "where" *> scalarExpr)
groupByClause :: Parser [GroupingExpr]
groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
groupByClause =
label "group by" (keywords_ ["group","by"] *> commaSep1 groupingExpression)
where
groupingExpression = choice
[keyword_ "cube" >>
@ -1450,16 +1490,16 @@ groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
]
having :: Parser ScalarExpr
having = keyword_ "having" *> scalarExpr
having = label "having" (keyword_ "having" *> scalarExpr)
orderBy :: Parser [SortSpec]
orderBy = keywords_ ["order","by"] *> commaSep1 ob
orderBy = label "order by" (keywords_ ["order","by"] *> commaSep1 ob)
where
ob = SortSpec
<$> scalarExpr
<*> option DirDefault (choice [Asc <$ keyword_ "asc"
<*> hoption DirDefault (choice [Asc <$ keyword_ "asc"
,Desc <$ keyword_ "desc"])
<*> option NullsOrderDefault
<*> hoption NullsOrderDefault
-- todo: left factor better
(keyword_ "nulls" >>
choice [NullsFirst <$ keyword "first"
@ -1477,9 +1517,9 @@ offsetFetch =
maybePermutation p = P.toPermutationWithDefault Nothing (Just <$> p)
offset :: Parser ScalarExpr
offset = keyword_ "offset" *> scalarExpr
offset = label "offset" (keyword_ "offset" *> scalarExpr
<* option () (choice [keyword_ "rows"
,keyword_ "row"])
,keyword_ "row"]))
fetch :: Parser ScalarExpr
fetch = fetchFirst <|> limit
@ -1496,13 +1536,13 @@ fetch = fetchFirst <|> limit
with :: Parser QueryExpr
with = keyword_ "with" >>
With <$> option False (True <$ keyword_ "recursive")
With <$> hoption False (True <$ keyword_ "recursive")
<*> commaSep1 withQuery <*> queryExpr
where
withQuery = (,) <$> (withAlias <* keyword_ "as")
<*> parens queryExpr
withAlias = Alias <$> name <*> columnAliases
columnAliases = optional $ parens $ commaSep1 name
columnAliases = hoptional $ parens $ commaSep1 name
{-
@ -1513,15 +1553,15 @@ and union, etc..
-}
queryExpr :: Parser QueryExpr
queryExpr = E.makeExprParser qeterm qeOpTable
queryExpr = label "query expr" $ E.makeExprParser qeterm qeOpTable
where
qeterm = with <|> select <|> table <|> values
qeterm = label "query expr" (with <|> select <|> table <|> values)
select = keyword_ "select" >>
mkSelect
<$> option SQDefault duplicates
<$> hoption SQDefault duplicates
<*> selectList
<*> optional tableExpression <?> "table expression"
<*> optional tableExpression
mkSelect d sl Nothing =
toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl}
mkSelect d sl (Just (TableExpression f w g h od ofs fe)) =
@ -1535,12 +1575,12 @@ queryExpr = E.makeExprParser qeterm qeOpTable
,[E.InfixL $ setOp Except "except"
,E.InfixL $ setOp Union "union"]]
setOp :: SetOperatorName -> Text -> Parser (QueryExpr -> QueryExpr -> QueryExpr)
setOp ctor opName = (cq
setOp ctor opName = hidden (cq
<$> (ctor <$ keyword_ opName)
<*> option SQDefault duplicates
<*> corr) <?> ""
<*> hoption SQDefault duplicates
<*> corr)
cq o d c q0 q1 = QueryExprSetOp q0 o d c q1
corr = option Respectively (Corresponding <$ keyword_ "corresponding")
corr = hoption Respectively (Corresponding <$ keyword_ "corresponding")
{-
@ -1560,12 +1600,15 @@ data TableExpression
,_teFetchFirst :: Maybe ScalarExpr}
tableExpression :: Parser TableExpression
tableExpression = mkTe <$> (from <?> "from clause")
<*> (optional whereClause <?> "where clause")
<*> (option [] groupByClause <?> "group by clause")
<*> (optional having <?> "having clause")
<*> (option [] orderBy <?> "order by clause")
<*> (offsetFetch <?> "")
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
@ -1589,7 +1632,8 @@ topLevelStatement = statement
-}
statementWithoutSemicolon :: Parser Statement
statementWithoutSemicolon = choice
statementWithoutSemicolon =
label "statement" $ choice
[keyword_ "create" *> choice [createSchema
,createTable
,createIndex
@ -1623,7 +1667,7 @@ statementWithoutSemicolon = choice
]
statement :: Parser Statement
statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi
statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ hidden semi
createSchema :: Parser Statement
createSchema = keyword_ "schema" >>
@ -1638,7 +1682,7 @@ createTable = do
separator = if diNonCommaSeparatedConstraints d
then optional comma
else Just <$> comma
constraints = sepBy parseConstraintDef separator
constraints = sepBy parseConstraintDef (hidden separator)
entries = ((:) <$> parseColumnDef <*> ((comma >> entries) <|> pure [])) <|> constraints
keyword_ "table" >>
@ -1660,7 +1704,7 @@ columnDef = ColumnDef <$> name <*> typeName
<*> optional defaultClause
<*> option [] (some colConstraintDef)
where
defaultClause = choice [
defaultClause = label "column default clause" $ choice [
keyword_ "default" >>
DefaultClause <$> scalarExpr
-- todo: left factor
@ -1689,12 +1733,12 @@ tableConstraintDef =
(\cs ft ftcs m (u,d) -> TableReferencesConstraint cs ft ftcs m u d)
<$> parens (commaSep1 name)
<*> (keyword_ "references" *> names)
<*> optional (parens $ commaSep1 name)
<*> hoptional (parens $ commaSep1 name)
<*> refMatch
<*> refActions
refMatch :: Parser ReferenceMatch
refMatch = option DefaultReferenceMatch
refMatch = hoption DefaultReferenceMatch
(keyword_ "match" *>
choice [MatchFull <$ keyword_ "full"
,MatchPartial <$ keyword_ "partial"
@ -1833,11 +1877,11 @@ dropTable = keyword_ "table" >>
createView :: Parser Statement
createView =
CreateView
<$> (option False (True <$ keyword_ "recursive") <* keyword_ "view")
<$> (hoption False (True <$ keyword_ "recursive") <* keyword_ "view")
<*> names
<*> optional (parens (commaSep1 name))
<*> (keyword_ "as" *> queryExpr)
<*> optional (choice [
<*> hoptional (choice [
-- todo: left factor
DefaultCheckOption <$ try (keywords_ ["with", "check", "option"])
,CascadedCheckOption <$ try (keywords_ ["with", "cascaded", "check", "option"])
@ -1852,7 +1896,7 @@ createDomain :: Parser Statement
createDomain = keyword_ "domain" >>
CreateDomain
<$> names
<*> (optional (keyword_ "as") *> typeName)
<*> ((optional (keyword_ "as") *> typeName) <?> "alias")
<*> optional (keyword_ "default" *> scalarExpr)
<*> many con
where
@ -1930,7 +1974,7 @@ insert :: Parser Statement
insert = keywords_ ["insert", "into"] >>
Insert
<$> names
<*> optional (parens $ commaSep1 name)
<*> label "parens column names" (optional (parens $ commaSep1 name))
<*> (DefaultInsertValues <$ keywords_ ["default", "values"]
<|> InsertQuery <$> queryExpr)
@ -1938,7 +1982,7 @@ update :: Parser Statement
update = keywords_ ["update"] >>
Update
<$> names
<*> optional (optional (keyword_ "as") *> name)
<*> label "alias" (optional (optional (keyword_ "as") *> name))
<*> (keyword_ "set" *> commaSep1 setClause)
<*> optional (keyword_ "where" *> scalarExpr)
where
@ -1974,10 +2018,10 @@ releaseSavepoint = keywords_ ["release","savepoint"] >>
ReleaseSavepoint <$> name
commit :: Parser Statement
commit = Commit <$ keyword_ "commit" <* optional (keyword_ "work")
commit = Commit <$ keyword_ "commit" <* hoptional (keyword_ "work")
rollback :: Parser Statement
rollback = keyword_ "rollback" >> optional (keyword_ "work") >>
rollback = keyword_ "rollback" >> hoptional (keyword_ "work") >>
Rollback <$> optional (keywords_ ["to", "savepoint"] *> name)
@ -2091,6 +2135,7 @@ thick.
makeKeywordTree :: [Text] -> Parser [Text]
makeKeywordTree sets =
label (T.intercalate ", " sets) $
parseTrees (sort $ map T.words sets)
where
parseTrees :: [[Text]] -> Parser [Text]
@ -2116,24 +2161,20 @@ makeKeywordTree sets =
-- parser helpers
(<$$>) :: Applicative f =>
f b -> (a -> b -> c) -> f (a -> c)
(<$$>) :: Parser b -> (a -> b -> c) -> Parser (a -> c)
(<$$>) pa c = pa <**> pure (flip c)
(<$$$>) :: Applicative f =>
f c -> (a -> b -> c -> t) -> f (b -> a -> t)
(<$$$>) :: Parser c -> (a -> b -> c -> t) -> Parser (b -> a -> t)
p <$$$> c = p <**> pure (flip3 c)
(<$$$$>) :: Applicative f =>
f d -> (a -> b -> c -> d -> t) -> f (c -> b -> a -> t)
(<$$$$>) :: Parser d -> (a -> b -> c -> d -> t) -> Parser (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)
(<$$$$$>) :: Parser e -> (a -> b -> c -> d -> e -> t) -> Parser (d -> c -> b -> a -> t)
p <$$$$$> c = p <**> pure (flip5 c)
optionSuffix :: (a -> Parser a) -> a -> Parser a
optionSuffix p a = option a (p a)
hoptionSuffix :: (a -> Parser a) -> a -> Parser a
hoptionSuffix p a = hoption a (p a)
{-
parses an optional postfix element and applies its result to its left
@ -2144,12 +2185,12 @@ other operators so it can be used nicely
-}
(<??>) :: Parser a -> Parser (a -> a) -> Parser a
p <??> q = p <**> option id q
p <??> q = p <**> hoption id q
-- 0 to many repeated applications of suffix parser
(<??*>) :: Parser a -> Parser (a -> a) -> Parser a
p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)
p <??*> q = foldr ($) <$> p <*> (reverse <$> many (hidden q))
{-
These are to help with left factored parsers:
@ -2177,7 +2218,7 @@ unsignedInteger = read . T.unpack <$> sqlNumberTok True <?> "natural number"
-- todo: work out the symbol parsing better
symbol :: Text -> Parser Text
symbol s = symbolTok (Just s) <?> T.unpack s
symbol s = symbolTok (Just s) <?> s
singleCharSymbol :: Char -> Parser Char
singleCharSymbol c = c <$ symbol (T.singleton c)
@ -2185,44 +2226,39 @@ singleCharSymbol c = c <$ symbol (T.singleton c)
questionMark :: Parser Char
questionMark = singleCharSymbol '?' <?> "question mark"
openParen :: Parser Char
openParen = singleCharSymbol '('
closeParen :: Parser Char
closeParen = singleCharSymbol ')'
openBracket :: Parser Char
openBracket = singleCharSymbol '['
closeBracket :: Parser Char
closeBracket = singleCharSymbol ']'
openParen :: Parser ()
openParen = void $ singleCharSymbol '('
closeParen :: Parser ()
closeParen = void $ singleCharSymbol ')'
comma :: Parser Char
comma = singleCharSymbol ',' <?> ""
comma = singleCharSymbol ','
semi :: Parser Char
semi = singleCharSymbol ';' <?> ""
semi = singleCharSymbol ';'
-- = helper functions
keyword :: Text -> Parser Text
keyword k = unquotedIdentifierTok [] (Just k) <?> T.unpack k
keyword k = keywordTok [k] <?> k
-- helper function to improve error messages
keywords_ :: [Text] -> Parser ()
keywords_ ks = mapM_ keyword_ ks <?> T.unpack (T.unwords ks)
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 openBracket closeBracket
brackets = between (singleCharSymbol '[') (singleCharSymbol ']')
braces :: Parser a -> Parser a
braces = between (singleCharSymbol '{') (singleCharSymbol '}')
commaSep :: Parser a -> Parser [a]
commaSep = (`sepBy` comma)
commaSep = (`sepBy` hidden comma)
keyword_ :: Text -> Parser ()
keyword_ = void . keyword
@ -2231,7 +2267,19 @@ symbol_ :: Text -> Parser ()
symbol_ = void . symbol
commaSep1 :: Parser a -> Parser [a]
commaSep1 = (`sepBy1` comma)
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)
------------------------------------------------------------------------------
@ -2277,25 +2325,25 @@ stringTokExtend = do
]
hostParamTok :: Parser Text
hostParamTok = token test Set.empty <?> ""
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 <?> ""
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 <?> ""
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 <?> ""
symbolTok sym = token test Set.empty <?> lbl
where
test (L.WithPos _ _ _ (L.Symbol p)) =
case sym of
@ -2303,6 +2351,9 @@ symbolTok sym = token test Set.empty <?> ""
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
@ -2341,21 +2392,19 @@ will likely mean many things don't parse anymore.
-}
identifierTok :: [Text] -> Parser (Maybe (Text,Text), Text)
identifierTok blackList = token test Set.empty <?> ""
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 p))
test (L.WithPos _ _ _ (L.Identifier q@Nothing p))
| T.toLower p `notElem` blackList = Just (q,p)
test _ = Nothing
unquotedIdentifierTok :: [Text] -> Maybe Text -> Parser Text
unquotedIdentifierTok blackList kw = token test Set.empty <?> ""
where
test (L.WithPos _ _ _ (L.Identifier Nothing p)) =
case kw of
Nothing | T.toLower p `notElem` blackList -> Just p
Just k | k == T.toLower p -> Just p
_ -> 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
------------------------------------------------------------------------------

8
Makefile
View file

@ -11,7 +11,11 @@ build :
.PHONY : test
test :
cabal run test:Tests -- --hide-successes --ansi-tricks=false
cabal run test:Tests -- -f failed-examples +RTS -N
.PHONY : fast-test
fast-test :
cabal run test:Tests -- -f failed-examples --skip ansiLexerTests --skip postgresLexerTests +RTS -N
.PHONY : test-coverage
test-coverage :
@ -67,7 +71,9 @@ build/test_cases.html : website/RenderTestCases.hs website/template1.pandoc
# no idea why not using --disable-optimisation on cabal build, but putting -O0
# in the cabal file (and then cabal appears to say it's still using -O1
# is faster
echo Entering directory \`website/\'
cd website/ && cabal build RenderTestCases && cabal run RenderTestCases | pandoc -s -N --template template1.pandoc -V toc-title:"Simple SQL Parser test case examples" -c main1.css -f markdown -t html --toc=true --metadata title="Simple SQL Parse test case examples" > ../build/test_cases.html
echo Leaving directory \`website/\'
# works here, but not in a recipe. amazing
# GHC_VER="$(shell ghc --numeric-version)"

5
changelog
View file

@ -1,3 +1,8 @@
0.8.0 (not yet released)
lexer has new option to output an invalid token on some kinds of
parse errors
switch tests to hspec
improve parse error messages
0.7.1 fix error message source quoting
0.7.0 support autoincrement for sqlite
support table constraints without separating comma for sqlite

514
examples/ErrorMessagesTool.hs Normal file
View file

@ -0,0 +1,514 @@
{-
tool to compare before and after on error messages, suggested use:
add any extra parse error examples below
run it on baseline code
run it on the modified code
use meld on the two resulting csvs
bear in mind that " will appear as "" because of csv escaping
this is how to generate a csv of errors:
cabal -ftestexe build error-messages-tool && cabal -ftestexe run error-messages-tool -- generate | cabal -ftestexe run error-messages-tool -- test > res.csv
TODO:
think about making a regression test with this
can add some more tools:
there's a join mode to join two sets of results, could add a filter
to remove rows that are the same
but finding the different rows in meld seems to work well enough
figure out if you can display visual diffs between pairs of cells in localc
implement the tagging feature, one idea for working with it:
you generate a bunch of error messages
you eyeball the list, and mark some as good, some as bad
then when you update, you can do a compare which filters
to keep any errors that have changed, and any that haven't
changed but are not marked as good
etc.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE LambdaCase #-}
import Data.Text (Text)
import qualified Data.Text as T
import Text.Show.Pretty (ppShow)
import qualified Text.RawString.QQ as R
import Language.SQL.SimpleSQL.Parse
(prettyError
,parseQueryExpr
,parseScalarExpr
-- ,parseStatement
-- ,parseStatements
,ansi2011
-- ,ParseError(..)
)
--import qualified Language.SQL.SimpleSQL.Lex as L
import Language.SQL.SimpleSQL.Dialect
(postgres
,Dialect(..)
,sqlserver
,mysql
)
import System.Environment (getArgs)
import Data.Csv
(encode
,decode
,HasHeader(..))
import qualified Data.ByteString.Lazy as B hiding (pack)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B (putStrLn)
import qualified Data.Vector as V
import Data.Vector (Vector)
import Database.SQLite.Simple
(open
,execute_
,executeMany
,query_
)
main :: IO ()
main = do
as <- getArgs
case as of
["generate"] -> B.putStrLn generateData
["test"] -> do
txt <- B.getContents
B.putStrLn $ runTests txt
["compare", f1, f2] -> do
c1 <- B.readFile f1
c2 <- B.readFile f2
B.putStrLn =<< compareFiles c1 c2
_ -> error $ "unsupported arguments: " <> show as
------------------------------------------------------------------------------
-- compare two files
{-
take two inputs
assume they have (testrunid, parser, dialect, src, res,tags) lines
do a full outer join between them, on
parser,dialect,src
so you have
parser,dialect,src,res a, tags a, res b, tags b
then output this as the result
see what happens if you highlight the differences in localc, edit some
tags, then save as csv - does the highlighting just disappear leaving
the interesting data only?
-}
compareFiles :: ByteString -> ByteString -> IO ByteString
compareFiles csva csvb = do
let data1 :: [(Text,Text,Text,Text,Text,Text)]
data1 = either (error . show) V.toList $ decode NoHeader csva
data2 :: [(Text,Text,Text,Text,Text,Text)]
data2 = either (error . show) V.toList $ decode NoHeader csvb
conn <- open ":memory:"
execute_ conn [R.r|
create table data1 (
testrunida text,
parser text,
dialect text,
source text,
result_a text,
tags_a text)|]
execute_ conn [R.r|
create table data2 (
testrunidb text,
parser text,
dialect text,
source text,
result_b text,
tags_b text)|]
executeMany conn "insert into data1 values (?,?,?,?,?,?)" data1
executeMany conn "insert into data2 values (?,?,?,?,?,?)" data2
r <- query_ conn [R.r|
select
parser, dialect, source, result_a, tags_a, result_b, tags_b
from data1 natural full outer join data2|] :: IO [(Text,Text,Text,Text,Text,Text,Text)]
pure $ encode r
------------------------------------------------------------------------------
-- running tests
runTests :: ByteString -> ByteString
runTests csvsrc =
let csv :: Vector (Text,Text,Text)
csv = either (error . show) id $ decode NoHeader csvsrc
testrunid = ("0" :: Text)
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
_ -> 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 (testrunid, parser, dialect, src, resadj,"" :: Text)
allres = V.map testLine csv
in encode $ V.toList allres
------------------------------------------------------------------------------
-- generating data
generateData :: ByteString
generateData =
encode $ concat
[simpleExpressions1
,pgExprs
,sqlServerIden
,mysqliden
,paramvariations
,odbcexpr
,odbcqexpr
,otherParseErrorExamples]
--------------------------------------
-- example data
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
;
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[
;
|]
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
|]
otherParseErrorExamples :: [(Text,Text,Text)]
otherParseErrorExamples = 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
'
|]

2
examples/SimpleSQLParserTool.hs
View file

@ -89,7 +89,7 @@ lexCommand =
(f,src) <- getInput args
either (error . T.unpack . L.prettyError)
(putStrLn . intercalate ",\n" . map show)
$ L.lexSQL ansi2011 (T.pack f) Nothing (T.pack src)
$ L.lexSQL ansi2011 False (T.pack f) Nothing (T.pack src)
)

35
simple-sql-parser.cabal
View file

@ -1,7 +1,7 @@
cabal-version: 2.2
name: simple-sql-parser
version: 0.7.1
version: 0.8.0
synopsis: A parser for SQL.
description: A parser for SQL. Parses most SQL:2011
@ -29,6 +29,11 @@ Flag parserexe
Description: Build SimpleSQLParserTool exe
Default: False
Flag testexe
Description: Build Testing exe
Default: False
common shared-properties
default-language: Haskell2010
build-depends: base >=4 && <5,
@ -56,8 +61,10 @@ Test-Suite Tests
main-is: RunTests.hs
hs-source-dirs: tests
Build-Depends: simple-sql-parser,
tasty >= 1.1 && < 1.6,
tasty-hunit >= 0.9 && < 0.11
hspec,
hspec-megaparsec,
hspec-expectations,
raw-strings-qq,
Other-Modules: Language.SQL.SimpleSQL.ErrorMessages,
Language.SQL.SimpleSQL.FullQueries,
@ -82,6 +89,8 @@ Test-Suite Tests
Language.SQL.SimpleSQL.CustomDialect,
Language.SQL.SimpleSQL.EmptyStatement,
Language.SQL.SimpleSQL.CreateIndex
Language.SQL.SimpleSQL.Expectations
Language.SQL.SimpleSQL.TestRunners
ghc-options: -threaded
@ -95,3 +104,23 @@ executable SimpleSQLParserTool
buildable: True
else
buildable: False
executable error-messages-tool
import: shared-properties
main-is: ErrorMessagesTool.hs
hs-source-dirs: examples
Build-Depends: base,
text,
raw-strings-qq,
containers,
megaparsec,
simple-sql-parser,
pretty-show,
bytestring,
cassava,
vector,
sqlite-simple,
if flag(testexe)
buildable: True
else
buildable: False

10
tests/Language/SQL/SimpleSQL/CreateIndex.hs
View file

@ -4,15 +4,19 @@ 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"
[TestStatement ansi2011 "create index a on tbl(c1)"
[s "create index a on tbl(c1)"
$ CreateIndex False [nm "a"] [nm "tbl"] [nm "c1"]
,TestStatement ansi2011 "create index a.b on sc.tbl (c1, c2)"
,s "create index a.b on sc.tbl (c1, c2)"
$ CreateIndex False [nm "a", nm "b"] [nm "sc", nm "tbl"] [nm "c1", nm "c2"]
,TestStatement ansi2011 "create unique index a on tbl(c1)"
,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

38
tests/Language/SQL/SimpleSQL/CustomDialect.hs
View file

@ -3,26 +3,30 @@
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" (map (uncurry ParseQueryExpr) passTests
++ map (uncurry ParseScalarExprFails) failTests )
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
failTests = [(ansi2011,"SELECT DATE('2000-01-01')")
,(ansi2011,"SELECT DATE")
,(dateApp,"SELECT DATE")
,(dateIden,"SELECT DATE('2000-01-01')")
-- show this never being allowed as an alias
,(ansi2011,"SELECT a date")
,(dateApp,"SELECT a date")
,(dateIden,"SELECT a date")
]
passTests = [(ansi2011,"SELECT a b")
,(noDateKeyword,"SELECT DATE('2000-01-01')")
,(noDateKeyword,"SELECT DATE")
,(dateApp,"SELECT DATE('2000-01-01')")
,(dateIden,"SELECT DATE")
]
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

27
tests/Language/SQL/SimpleSQL/EmptyStatement.hs
View file

@ -3,19 +3,26 @@ 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"
[ TestStatement ansi2011 ";" EmptyStatement
, TestStatements ansi2011 ";" [EmptyStatement]
, TestStatements ansi2011 ";;" [EmptyStatement, EmptyStatement]
, TestStatements ansi2011 ";;;" [EmptyStatement, EmptyStatement, EmptyStatement]
, TestStatement ansi2011 "/* comment */ ;" EmptyStatement
, TestStatements ansi2011 "" []
, TestStatements ansi2011 "/* comment */" []
, TestStatements ansi2011 "/* comment */ ;" [EmptyStatement]
, TestStatements ansi2011 "/* comment */ ; /* comment */ ;"
[ 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]
, TestStatements ansi2011 "/* comment */ ; /* comment */ ; /* comment */ ;"
, 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

214
tests/Language/SQL/SimpleSQL/ErrorMessages.hs
View file

@ -1,156 +1,82 @@
{-
Want to work on the error messages. Ultimately, parsec won't give the
best error message for a parser combinator library in haskell. Should
check out the alternatives such as polyparse and uu-parsing.
See the file examples/ErrorMessagesTool.hs for some work on this
For now the plan is to try to get the best out of parsec. Skip heavy
work on this until the parser is more left factored?
Ideas:
1. generate large lists of invalid syntax
2. create table of the sql source and the error message
3. save these tables and compare from version to version. Want to
catch improvements and regressions and investigate. Have to do this
manually
= generating bad sql source
take good sql statements or expressions. Convert them into sequences
of tokens - want to preserve the whitespace and comments perfectly
here. Then modify these lists by either adding a token, removing a
token, or modifying a token (including creating bad tokens of raw
strings which don't represent anything than can be tokenized.
Now can see the error message for all of these bad strings. Probably
have to generate and prune this list manually in stages since there
will be too many.
Contexts:
another area to focus on is contexts: for instance, we have a set of
e.g. 1000 bad scalar expressions with error messages. Now can put
those bad scalar expressions into various contexts and see that the
error messages are still good.
plan:
1. create a list of all the value expression, with some variations for
each
2. manually create some error variations for each expression
3. create a renderer which will create a csv of the expressions and
the errors
this is to load as a spreadsheet to investigate more
4. create a renderer for the csv which will create a markdown file for
the website. this is to demonstrate the error messages in the
documentation
Then create some contexts for all of these: inside another value
expression, or inside a query expression. Do the same: render and
review the error messages.
Then, create some query expressions to focus on the non value
expression parts.
-}
module Language.SQL.SimpleSQL.ErrorMessages where
{-import Language.SQL.SimpleSQL.Parser
import Data.List
import Text.Groom
valueExpressions :: [String]
valueExpressions =
["10.."
,"..10"
,"10e1e2"
,"10e--3"
,"1a"
,"1%"
,"'b'ad'"
,"'bad"
,"bad'"
,"interval '5' ay"
,"interval '5' day (4.4)"
,"interval '5' day (a)"
,"intervala '5' day"
,"interval 'x' day (3"
,"interval 'x' day 3)"
,"1badiden"
,"$"
,"!"
,"*.a"
,"??"
,"3?"
,"?a"
,"row"
,"row 1,2"
,"row(1,2"
,"row 1,2)"
,"row(1 2)"
,"f("
,"f)"
,"f(a"
,"f a)"
,"f(a b)"
{-
TODO:
case
operators
-}
,"a + (b + c"
add simple test to check the error and quoting on later line in multi
line input for lexing and parsing; had a regression here that made it
to a release
{-
casts
subqueries: + whole set of parentheses use
in list
'keyword' functions
aggregates
window functions
-}
]
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Language.SQL.SimpleSQL.ErrorMessages
(errorMessageTests
) where
queryExpressions :: [String]
queryExpressions =
map sl1 valueExpressions
++ map sl2 valueExpressions
++ map sl3 valueExpressions
++
["select a from t inner jin u"]
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 Text.RawString.QQ as R
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 '$'
|]
]
where
sl1 x = "select " ++ x ++ " from t"
sl2 x = "select " ++ x ++ ", y from t"
sl3 x = "select " ++ x ++ " fom t"
valExprs :: [String] -> [(String,String)]
valExprs = map parseOne
where
parseOne x = let p = parseValueExpr "" Nothing x
in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p)
queryExprs :: [String] -> [(String,String)]
queryExprs = map parseOne
where
parseOne x = let p = parseQueryExpr "" Nothing x
in (x,either peFormattedError (\x -> "ERROR: parsed ok " ++ groom x) p)
pExprs :: [String] -> [String] -> String
pExprs x y =
let l = valExprs x ++ queryExprs y
in intercalate "\n\n\n\n" $ map (\(a,b) -> a ++ "\n" ++ b) l
-}
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)

61
tests/Language/SQL/SimpleSQL/Expectations.hs Normal file
View file

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

19
tests/Language/SQL/SimpleSQL/FullQueries.hs
View file

@ -6,24 +6,24 @@ 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" $ map (uncurry (TestQueryExpr ansi2011))
[("select count(*) from t"
,toQueryExpr $ makeSelect
fullQueriesTests = Group "queries" $
[q "select count(*) from t"
$ toQueryExpr $ makeSelect
{msSelectList = [(App [Name Nothing "count"] [Star], Nothing)]
,msFrom = [TRSimple [Name Nothing "t"]]
}
)
,("select a, sum(c+d) as s\n\
,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
$ toQueryExpr $ makeSelect
{msSelectList = [(Iden [Name Nothing "a"], Nothing)
,(App [Name Nothing "sum"]
[BinOp (Iden [Name Nothing "c"])
@ -36,5 +36,8 @@ fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr ansi2011))
[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

124
tests/Language/SQL/SimpleSQL/GroupBy.hs
View file

@ -6,6 +6,8 @@ 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
@ -15,23 +17,31 @@ groupByTests = Group "groupByTests"
,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" $ map (uncurry (TestQueryExpr ansi2011))
[("select a,sum(b) from t group by a"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
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"]]
})
}
,("select a,b,sum(c) from t group by a,b"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
,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"]]
})
}
]
{-
@ -40,15 +50,15 @@ sure which sql version they were introduced, 1999 or 2003 I think).
-}
newGroupBy :: TestItem
newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr ansi2011))
[("select * from t group by ()", ms [GroupingParens []])
,("select * from t group by grouping sets ((), (a))"
,ms [GroupingSets [GroupingParens []
,GroupingParens [SimpleGroup $ Iden [Name Nothing "a"]]]])
,("select * from t group by cube(a,b)"
,ms [Cube [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]])
,("select * from t group by rollup(a,b)"
,ms [Rollup [SimpleGroup $ Iden [Name Nothing "a"], SimpleGroup $ Iden [Name Nothing "b"]]])
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)]
@ -56,21 +66,21 @@ newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr ansi2011))
,msGroupBy = g}
randomGroupBy :: TestItem
randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
["select * from t GROUP BY a"
,"select * from t GROUP BY GROUPING SETS((a))"
,"select * from t GROUP BY a,b,c"
,"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\
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\
\() )"
,"select * from t GROUP BY ROLLUP(b,a)"
,"select * from t GROUP BY GROUPING SETS((b,a),\n\
,p "select * from t GROUP BY ROLLUP(b,a)"
,p "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\
,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\
@ -78,33 +88,33 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\(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\
,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\
\() )"
,"select * from t GROUP BY GROUPING SETS((Province, County, City),\n\
,p "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\
,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) )"
,"select * from t GROUP BY a, b, ROLLUP(c,d)"
,"select * from t GROUP BY GROUPING SETS((a,b,c,d),\n\
,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) )"
,"select * from t GROUP BY ROLLUP(a), ROLLUP(b,c)"
,"select * from t GROUP BY GROUPING SETS((a,b,c),\n\
,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\
\() )"
,"select * from t GROUP BY ROLLUP(a), CUBE(b,c)"
,"select * from t GROUP BY GROUPING SETS((a,b,c),\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\
@ -112,8 +122,8 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\(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\
,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\
@ -125,16 +135,16 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\(c,d),\n\
\(c),\n\
\() )"
,"select * from t GROUP BY a, ROLLUP(a,b)"
,"select * from t GROUP BY GROUPING SETS((a,b),\n\
,p "select * from t GROUP BY a, ROLLUP(a,b)"
,p "select * from t GROUP BY GROUPING SETS((a,b),\n\
\(a) )"
,"select * from t GROUP BY Region,\n\
,p "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\
,p "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\
,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\
@ -142,7 +152,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\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\
,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\
@ -151,7 +161,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\(DAYOFWEEK(SALES_DATE), SALES_PERSON))\n\
\ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
,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\
@ -159,7 +169,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\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\
,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\
@ -167,7 +177,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\GROUP BY CUBE ( WEEK(SALES_DATE), DAYOFWEEK(SALES_DATE), SALES_PERSON )\n\
\ORDER BY WEEK, DAY_WEEK, SALES_PERSON"
,"SELECT SALES_PERSON,\n\
,p "SELECT SALES_PERSON,\n\
\MONTH(SALES_DATE) AS MONTH,\n\
\SUM(SALES) AS UNITS_SOLD\n\
\FROM SALES\n\
@ -176,21 +186,21 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\)\n\
\ORDER BY SALES_PERSON, MONTH"
,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
,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"
,"SELECT MONTH(SALES_DATE) AS MONTH,\n\
,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"
,"SELECT WEEK(SALES_DATE) AS WEEK,\n\
,p "SELECT WEEK(SALES_DATE) AS WEEK,\n\
\DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
\MONTH(SALES_DATE) AS MONTH,\n\
\REGION,\n\
@ -200,7 +210,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\ROLLUP( MONTH(SALES_DATE), REGION ) )\n\
\ORDER BY WEEK, DAY_WEEK, MONTH, REGION"
,"SELECT R1, R2,\n\
,p "SELECT R1, R2,\n\
\WEEK(SALES_DATE) AS WEEK,\n\
\DAYOFWEEK(SALES_DATE) AS DAY_WEEK,\n\
\MONTH(SALES_DATE) AS MONTH,\n\
@ -211,7 +221,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
\(R2,ROLLUP( MONTH(SALES_DATE), REGION ) ))\n\
\ORDER BY WEEK, DAY_WEEK, MONTH, REGION"
{-,"SELECT COALESCE(R1,R2) AS GROUP,\n\
{-,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\
@ -226,7 +236,7 @@ randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr ansi2011)
-- 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\
,p "SELECT MONTH(SALES_DATE) AS MONTH,\n\
\REGION,\n\
\SUM(SALES) AS UNITS_SOLD,\n\
\MAX(SALES) AS BEST_SALE,\n\

206
tests/Language/SQL/SimpleSQL/LexerTests.hs
View file

@ -23,6 +23,7 @@ import Language.SQL.SimpleSQL.Lex
(Token(..)
,tokenListWillPrintAndLex
)
import Language.SQL.SimpleSQL.TestRunners
import qualified Data.Text as T
import Data.Text (Text)
@ -39,50 +40,57 @@ lexerTests = Group "lexerTests" $
,sqlServerLexerTests
,oracleLexerTests
,mySqlLexerTests
,odbcLexerTests]
,odbcLexerTests
]
-- quick sanity tests to see something working
bootstrapTests :: TestItem
bootstrapTests = Group "bootstrap tests" [Group "bootstrap tests" $
map (uncurry (LexTest ansi2011)) (
[("iden", [Identifier Nothing "iden"])
,("'string'", [SqlString "'" "'" "string"])
bootstrapTests = Group "bootstrap tests" $
[t "iden" [Identifier Nothing "iden"]
,(" ", [Whitespace " "])
,("\t ", [Whitespace "\t "])
,(" \n ", [Whitespace " \n "])
,t "\"a1normal \"\" iden\"" [Identifier (Just ("\"","\"")) "a1normal \"\" iden"]
,("--", [LineComment "--"])
,("--\n", [LineComment "--\n"])
,("--stuff", [LineComment "--stuff"])
,("-- stuff", [LineComment "-- stuff"])
,("-- stuff\n", [LineComment "-- stuff\n"])
,("--\nstuff", [LineComment "--\n", Identifier Nothing "stuff"])
,("-- com \nstuff", [LineComment "-- com \n", Identifier Nothing "stuff"])
,t "'string'" [SqlString "'" "'" "string"]
,("/*test1*/", [BlockComment "/*test1*/"])
,("/**/", [BlockComment "/**/"])
,("/***/", [BlockComment "/***/"])
,("/* * */", [BlockComment "/* * */"])
,("/*test*/", [BlockComment "/*test*/"])
,("/*te/*st*/", [BlockComment "/*te/*st*/"])
,("/*te*st*/", [BlockComment "/*te*st*/"])
,("/*lines\nmore lines*/", [BlockComment "/*lines\nmore lines*/"])
,("/*test1*/\n", [BlockComment "/*test1*/", Whitespace "\n"])
,("/*test1*/stuff", [BlockComment "/*test1*/", Identifier Nothing "stuff"])
,t " " [Whitespace " "]
,t "\t " [Whitespace "\t "]
,t " \n " [Whitespace " \n "]
,("1", [SqlNumber "1"])
,("42", [SqlNumber "42"])
,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"]
-- have to fix the dialect handling in the tests
--,("$1", [PositionalArg 1])
--,("$200", [PositionalArg 200])
,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"]
,(":test", [PrefixedVariable ':' "test"])
,t "1" [SqlNumber "1"]
,t "42" [SqlNumber "42"]
] ++ map (\a -> (a, [Symbol a])) (
,tp "$1" [PositionalArg 1]
,tp "$200" [PositionalArg 200]
,t ":test" [PrefixedVariable ':' "test"]
] ++ map (\a -> t a [Symbol a]) (
["!=", "<>", ">=", "<=", "||"]
++ map T.singleton ("(),-+*/<>=." :: [Char])))]
++ 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])]
@ -103,7 +111,7 @@ ansiLexerTable =
)
-- quoted identifiers with embedded double quotes
-- the lexer doesn't unescape the quotes
++ [("\"normal \"\" iden\"", [Identifier (Just ("\"","\"")) "normal \"\" iden"])]
++ [("\"anormal \"\" iden\"", [Identifier (Just ("\"","\"")) "anormal \"\" iden"])]
-- strings
-- the lexer doesn't apply escapes at all
++ [("'string'", [SqlString "'" "'" "string"])
@ -137,39 +145,44 @@ ansiLexerTable =
ansiLexerTests :: TestItem
ansiLexerTests = Group "ansiLexerTests" $
[Group "ansi lexer token tests" $ [LexTest ansi2011 s t | (s,t) <- ansiLexerTable]
[Group "ansi lexer token tests" $ [l s t | (s,t) <- ansiLexerTable]
,Group "ansi generated combination lexer tests" $
[ LexTest ansi2011 (s <> s1) (t <> t1)
| (s,t) <- ansiLexerTable
, (s1,t1) <- ansiLexerTable
, tokenListWillPrintAndLex ansi2011 $ t <> t1
[ l (s <> s1) (t <> t1)
| (s,t) <- ansiLexerTable
, (s1,t1) <- ansiLexerTable
, tokenListWillPrintAndLex ansi2011 $ t <> t1
]
]
,Group "ansiadhoclexertests" $
map (uncurry $ LexTest ansi2011)
[("", [])
,("-- line com\nstuff", [LineComment "-- line com\n",Identifier Nothing "stuff"])
] ++
[-- want to make sure this gives a parse error
LexFails ansi2011 "*/"
-- combinations of pipes: make sure they fail because they could be
-- ambiguous and it is really unclear when they are or not, and
-- what the result is even when they are not ambiguous
,LexFails ansi2011 "|||"
,LexFails ansi2011 "||||"
,LexFails ansi2011 "|||||"
-- another user experience thing: make sure extra trailing
-- number chars are rejected rather than attempting to parse
-- if the user means to write something that is rejected by this code,
-- then they can use whitespace to make it clear and then it will parse
,LexFails ansi2011 "12e3e4"
,LexFails ansi2011 "12e3e4"
,LexFails ansi2011 "12e3e4"
,LexFails ansi2011 "12e3.4"
,LexFails ansi2011 "12.4.5"
,LexFails ansi2011 "12.4e5.6"
,LexFails ansi2011 "12.4e5e7"]
]
[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
@ -303,22 +316,21 @@ somePostgresOpsWhichWontAddTrailingPlusMinus l =
, not (T.last x `T.elem` "+-")
]
postgresLexerTests :: TestItem
postgresLexerTests = Group "postgresLexerTests" $
[Group "postgres lexer token tests" $
[LexTest postgres s t | (s,t) <- postgresLexerTable]
[l s t | (s,t) <- postgresLexerTable]
,Group "postgres generated lexer token tests" $
[LexTest postgres s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable]
[l s t | (s,t) <- postgresShortOperatorTable ++ postgresExtraOperatorTable]
,Group "postgres generated combination lexer tests" $
[ LexTest postgres (s <> s1) (t <> t1)
[ l (s <> s1) (t <> t1)
| (s,t) <- postgresLexerTable ++ postgresShortOperatorTable
, (s1,t1) <- postgresLexerTable ++ postgresShortOperatorTable
, tokenListWillPrintAndLex postgres $ t ++ t1
]
,Group "generated postgres edgecase lexertests" $
[LexTest postgres s t
[l s t
| (s,t) <- edgeCaseCommentOps
++ edgeCasePlusMinusOps
++ edgeCasePlusMinusComments]
@ -326,22 +338,23 @@ postgresLexerTests = Group "postgresLexerTests" $
,Group "adhoc postgres lexertests" $
-- need more tests for */ to make sure it is caught if it is in the middle of a
-- sequence of symbol letters
[LexFails postgres "*/"
,LexFails postgres ":::"
,LexFails postgres "::::"
,LexFails postgres ":::::"
,LexFails postgres "@*/"
,LexFails postgres "-*/"
,LexFails postgres "12e3e4"
,LexFails postgres "12e3e4"
,LexFails postgres "12e3e4"
,LexFails postgres "12e3.4"
,LexFails postgres "12.4.5"
,LexFails postgres "12.4e5.6"
,LexFails postgres "12.4e5e7"
[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
,LexTest postgres "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"]]
,l "1..2" [SqlNumber "1", Symbol "..", SqlNumber "2"]
]
]
where
edgeCaseCommentOps =
@ -365,14 +378,21 @@ postgresLexerTests = Group "postgresLexerTests" $
,("-/**/", [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" $
[ LexTest sqlserver s t | (s,t) <-
[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" $
@ -380,19 +400,29 @@ oracleLexerTests = Group "oracleLexTests" $
mySqlLexerTests :: TestItem
mySqlLexerTests = Group "mySqlLexerTests" $
[ LexTest mysql s t | (s,t) <-
[ 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" $
[ LexTest sqlserver {diOdbc = True} s t | (s,t) <-
[ lo s t | (s,t) <-
[("{}", [Symbol "{", Symbol "}"])
]]
++ [LexFails sqlserver {diOdbc = False} "{"
,LexFails sqlserver {diOdbc = False} "}"]
++ [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) ]

22
tests/Language/SQL/SimpleSQL/MySQL.hs
View file

@ -6,6 +6,7 @@ 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"
@ -21,21 +22,16 @@ limit syntax
-}
backtickQuotes :: TestItem
backtickQuotes = Group "backtickQuotes" (map (uncurry (TestScalarExpr mysql))
[("`test`", Iden [Name (Just ("`","`")) "test"])
]
++ [ParseScalarExprFails ansi2011 "`test`"]
)
backtickQuotes = Group "backtickQuotes"
[testScalarExpr mysql "`test`" $ Iden [Name (Just ("`","`")) "test"]
,testParseScalarExprFails ansi2011 "`test`"]
limit :: TestItem
limit = Group "queries" ( map (uncurry (TestQueryExpr mysql))
[("select * from t limit 5"
,toQueryExpr $ sel {msFetchFirst = Just (NumLit "5")}
)
]
++ [ParseQueryExprFails mysql "select a from t fetch next 10 rows only;"
,ParseQueryExprFails ansi2011 "select * from t limit 5"]
)
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)]

13
tests/Language/SQL/SimpleSQL/Odbc.hs
View file

@ -4,6 +4,8 @@ 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" [
@ -30,14 +32,14 @@ odbcTests = Group "odbc" [
,iden "SQL_DATE"])
]
,Group "outer join" [
TestQueryExpr ansi2011 {diOdbc=True}
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" [
TestQueryExpr ansi2011 {diOdbc=True}
q
"select {fn CONVERT(cint,SQL_BIGINT)} from t;"
$ toQueryExpr $ makeSelect
{msSelectList = [(OdbcFunc (ap "CONVERT"
@ -46,7 +48,12 @@ odbcTests = Group "odbc" [
,msFrom = [TRSimple [Name Nothing "t"]]}]
]
where
e = TestScalarExpr ansi2011 {diOdbc = True}
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]

23
tests/Language/SQL/SimpleSQL/Oracle.hs
View file

@ -6,6 +6,7 @@ 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"
@ -13,18 +14,18 @@ oracleTests = Group "oracle dialect"
oracleLobUnits :: TestItem
oracleLobUnits = Group "oracleLobUnits" (map (uncurry (TestScalarExpr oracle))
[("cast (a as varchar2(3 char))"
,Cast (Iden [Name Nothing "a"]) (
PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecCharacters)))
,("cast (a as varchar2(3 byte))"
,Cast (Iden [Name Nothing "a"]) (
PrecLengthTypeName [Name Nothing "varchar2"] 3 Nothing (Just PrecOctets)))
]
++ [TestStatement oracle
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")
(PrecLengthTypeName [Name Nothing "varchar2"] 55 Nothing (Just PrecOctets))
Nothing []]]
)
Nothing []]
]

151
tests/Language/SQL/SimpleSQL/Postgres.hs
View file

@ -9,9 +9,11 @@ revisited when the dialect support is added.
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" $ map (ParseQueryExpr ansi2011)
postgresTests = Group "postgresTests"
{-
lexical syntax section
@ -22,129 +24,129 @@ 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\
t "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');"
,t "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));"
,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));"
,"SELECT ROW(1,2.5,'this is a test') = ROW(1, 3, 'not the same');"
,t "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;"
--,t "SELECT ROW(table.*) IS NULL FROM table;"
,t "SELECT ROW(tablex.*) IS NULL FROM tablex;"
,"SELECT true OR somefunc();"
,t "SELECT true OR somefunc();"
,"SELECT somefunc() OR true;"
,t "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';"
,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';"
,"SELECT * FROM some_very_long_table_name s\n\
,t "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\
,t "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\
,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\
\ );"
{-,"SELECT *\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??
,"SELECT * FROM foo, LATERAL (SELECT * FROM bar WHERE bar.id = foo.bar_id) ss;"
,"SELECT * FROM foo, bar WHERE bar.id = foo.bar_id;"
,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;"
{-,"SELECT p1.id, p2.id, v1, v2\n\
{-,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?
{-,"SELECT p1.id, p2.id, v1, v2\n\
{-,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;"-}
,"SELECT m.name\n\
,t "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"
,t "SELECT * FROM fdt WHERE c1 > 5"
,"SELECT * FROM fdt WHERE c1 IN (1, 2, 3)"
,t "SELECT * FROM fdt WHERE c1 IN (1, 2, 3)"
,"SELECT * FROM fdt WHERE c1 IN (SELECT c1 FROM t2)"
,t "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)"
,t "SELECT * FROM fdt WHERE c1 IN (SELECT c3 FROM t2 WHERE c2 = fdt.c1 + 10)"
,"SELECT * FROM fdt WHERE c1 BETWEEN \n\
,t "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)"
,t "SELECT * FROM fdt WHERE EXISTS (SELECT c1 FROM t2 WHERE c2 > fdt.c1)"
,"SELECT * FROM test1;"
,t "SELECT * FROM test1;"
,"SELECT x FROM test1 GROUP BY x;"
,"SELECT x, sum(y) FROM test1 GROUP BY x;"
,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
,"SELECT product_id, p.name, (sum(s.units) * p.price) AS sales\n\
,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;"
,"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\
,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;"
,"SELECT a, b, c FROM t"
,t "SELECT a, b, c FROM t"
,"SELECT tbl1.a, tbl2.a, tbl1.b FROM t"
,t "SELECT tbl1.a, tbl2.a, tbl1.b FROM t"
,"SELECT tbl1.*, tbl2.a FROM t"
,t "SELECT tbl1.*, tbl2.a FROM t"
,"SELECT a AS value, b + c AS sum FROM t"
,t "SELECT a AS value, b + c AS sum FROM t"
,"SELECT a \"value\", b + c AS sum FROM t"
,t "SELECT a \"value\", b + c AS sum FROM t"
,"SELECT DISTINCT select_list t"
,t "SELECT DISTINCT select_list t"
,"VALUES (1, 'one'), (2, 'two'), (3, 'three');"
,t "VALUES (1, 'one'), (2, 'two'), (3, 'three');"
,"SELECT 1 AS column1, 'one' AS column2\n\
,t "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);"
,t "SELECT * FROM (VALUES (1, 'one'), (2, 'two'), (3, 'three')) AS t (num,letter);"
,"WITH regional_sales AS (\n\
,t "WITH regional_sales AS (\n\
\ SELECT region, SUM(amount) AS total_sales\n\
\ FROM orders\n\
\ GROUP BY region\n\
@ -161,14 +163,14 @@ TODO: get all the commented out tests working
\WHERE region IN (SELECT region FROM top_regions)\n\
\GROUP BY region, product;"
,"WITH RECURSIVE t(n) AS (\n\
,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"
,"WITH RECURSIVE included_parts(sub_part, part, quantity) AS (\n\
,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\
@ -179,7 +181,7 @@ TODO: get all the commented out tests working
\FROM included_parts\n\
\GROUP BY sub_part"
,"WITH RECURSIVE search_graph(id, link, data, depth) AS (\n\
,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\
@ -189,7 +191,7 @@ TODO: get all the commented out tests working
\)\n\
\SELECT * FROM search_graph;"
{-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
{-,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\
@ -203,7 +205,7 @@ TODO: get all the commented out tests working
\)\n\
\SELECT * FROM search_graph;"-} -- ARRAY
{-,"WITH RECURSIVE search_graph(id, link, data, depth, path, cycle) AS (\n\
{-,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\
@ -217,7 +219,7 @@ TODO: get all the commented out tests working
\)\n\
\SELECT * FROM search_graph;"-} -- ARRAY
,"WITH RECURSIVE t(n) AS (\n\
,t "WITH RECURSIVE t(n) AS (\n\
\ SELECT 1\n\
\ UNION ALL\n\
\ SELECT n+1 FROM t\n\
@ -226,19 +228,19 @@ TODO: get all the commented out tests working
-- select page reference
,"SELECT f.title, f.did, d.name, f.date_prod, f.kind\n\
,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"
,"SELECT kind, sum(len) AS total\n\
,t "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;"
,t "SELECT * FROM distributors ORDER BY name;"
,t "SELECT * FROM distributors ORDER BY 2;"
,"SELECT distributors.name\n\
,t "SELECT distributors.name\n\
\ FROM distributors\n\
\ WHERE distributors.name LIKE 'W%'\n\
\UNION\n\
@ -246,14 +248,14 @@ TODO: get all the commented out tests working
\ FROM actors\n\
\ WHERE actors.name LIKE 'W%';"
,"WITH t AS (\n\
,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"
,"WITH RECURSIVE employee_recursive(distance, employee_name, manager_name) AS (\n\
,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\
@ -264,16 +266,19 @@ TODO: get all the commented out tests working
\ )\n\
\SELECT distance, employee_name FROM employee_recursive;"
,"SELECT m.name AS mname, pname\n\
,t "SELECT m.name AS mname, pname\n\
\FROM manufacturers m, LATERAL get_product_names(m.id) pname;"
,"SELECT m.name AS mname, pname\n\
,t "SELECT m.name AS mname, pname\n\
\FROM manufacturers m LEFT JOIN LATERAL get_product_names(m.id) pname ON true;"
,"SELECT 2+2;"
,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
--,"SELECT distributors.* WHERE distributors.name = 'Westward';"
--,t "SELECT distributors.* WHERE distributors.name = 'Westward';"
]
where
t :: HasCallStack => Text -> TestItem
t src = testParseQueryExpr postgres src

174
tests/Language/SQL/SimpleSQL/QueryExprComponents.hs
View file

@ -12,7 +12,8 @@ module Language.SQL.SimpleSQL.QueryExprComponents (queryExprComponentTests) wher
import Language.SQL.SimpleSQL.TestTypes
import Language.SQL.SimpleSQL.Syntax
import Language.SQL.SimpleSQL.TestRunners
import Data.Text (Text)
queryExprComponentTests :: TestItem
queryExprComponentTests = Group "queryExprComponentTests"
@ -31,10 +32,10 @@ queryExprComponentTests = Group "queryExprComponentTests"
duplicates :: TestItem
duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t" ,ms SQDefault)
,("select all a from t" ,ms All)
,("select distinct a from t", ms Distinct)
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
@ -43,77 +44,77 @@ duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr ansi2011))
,msFrom = [TRSimple [Name Nothing "t"]]}
selectLists :: TestItem
selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr ansi2011))
[("select 1",
toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]})
selectLists = Group "selectLists"
[q "select 1"
$ toQueryExpr $ makeSelect {msSelectList = [(NumLit "1",Nothing)]}
,("select a"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]})
,q "select a"
$ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]}
,("select a,b"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
,(Iden [Name Nothing "b"],Nothing)]})
,q "select a,b"
$ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
,(Iden [Name Nothing "b"],Nothing)]}
,("select 1+2,3+4"
,toQueryExpr $ makeSelect {msSelectList =
,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)]})
,(BinOp (NumLit "3") [Name Nothing "+"] (NumLit "4"),Nothing)]}
,("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 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")]}
,("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 a, b b"
$ toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"], Just $ Name Nothing "a")
,(Iden [Name Nothing "b"], Just $ Name Nothing "b")]}
,("select a + b * c"
,toQueryExpr $ makeSelect {msSelectList =
,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)]})
,Nothing)]}
]
whereClause :: TestItem
whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t where a = 5"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)]
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")})
,msWhere = Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing "="] (NumLit "5")}
]
having :: TestItem
having = Group "having" $ map (uncurry (TestQueryExpr ansi2011))
[("select a,sum(b) from t group by a having sum(b) > 5"
,toQueryExpr $ makeSelect {msSelectList = [(Iden [Name Nothing "a"],Nothing)
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" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t order by a"
,ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault])
orderBy = Group "orderBy"
[q "select a from t order by a"
$ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault]
,("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, b"
$ ms [SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault
,SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault]
,("select a from t order by a asc"
,ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault])
,q "select a from t order by a asc"
$ ms [SortSpec (Iden [Name Nothing "a"]) Asc NullsOrderDefault]
,("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, b desc"
$ ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsOrderDefault
,SortSpec (Iden [Name Nothing "b"]) Desc NullsOrderDefault]
,("select a from t order by a desc nulls first, b desc nulls last"
,ms [SortSpec (Iden [Name Nothing "a"]) Desc NullsFirst
,SortSpec (Iden [Name Nothing "b"]) Desc NullsLast])
,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
@ -122,20 +123,20 @@ orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr ansi2011))
,msOrderBy = o}
offsetFetch :: TestItem
offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011))
offsetFetch = Group "offsetFetch"
[-- 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"))
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
--,("select a from t limit 10 offset 5"
-- ,ms (Just $ NumLit "5") (Just $ NumLit "10"))
--,q "select a from t limit 10 offset 5"
-- $ ms (Just $ NumLit "5") (Just $ NumLit "10"))
]
where
ms o l = toQueryExpr $ makeSelect
@ -145,23 +146,23 @@ offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011))
,msFetchFirst = l}
combos :: TestItem
combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t union select b from u"
,QueryExprSetOp mst Union SQDefault Respectively msu)
combos = Group "combos"
[q "select a from t union select b from u"
$ QueryExprSetOp mst Union SQDefault Respectively msu
,("select a from t intersect select b from u"
,QueryExprSetOp mst Intersect SQDefault Respectively msu)
,q "select a from t intersect select b from u"
$ QueryExprSetOp mst Intersect SQDefault Respectively msu
,("select a from t except all select b from u"
,QueryExprSetOp mst Except All Respectively msu)
,q "select a from t except all select b from u"
$ QueryExprSetOp mst Except All Respectively msu
,("select a from t union distinct corresponding \
,q "select a from t union distinct corresponding \
\select b from u"
,QueryExprSetOp mst Union Distinct Corresponding msu)
$ QueryExprSetOp mst Union Distinct Corresponding msu
,("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)
,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
@ -173,20 +174,20 @@ combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011))
withQueries :: TestItem
withQueries = Group "with queries" $ map (uncurry (TestQueryExpr ansi2011))
[("with u as (select a from t) select a from u"
,With False [(Alias (Name Nothing "u") Nothing, ms1)] ms2)
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
,("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 u(b) as (select a from t) select a from u"
$ With False [(Alias (Name Nothing "u") (Just [Name Nothing "b"]), ms1)] ms2
,("with x as (select a from t),\n\
,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)
$ With False [(Alias (Name Nothing "x") Nothing, ms1), (Alias (Name Nothing "u") Nothing,ms3)] ms2
,("with recursive u as (select a from t) select a from u"
,With True [(Alias (Name Nothing "u") Nothing, ms1)] 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
@ -197,13 +198,16 @@ withQueries = Group "with queries" $ map (uncurry (TestQueryExpr ansi2011))
ms3 = ms "a" "x"
values :: TestItem
values = Group "values" $ map (uncurry (TestQueryExpr ansi2011))
[("values (1,2),(3,4)"
,Values [[NumLit "1", NumLit "2"]
,[NumLit "3", NumLit "4"]])
values = Group "values"
[q "values (1,2),(3,4)"
$ Values [[NumLit "1", NumLit "2"]
,[NumLit "3", NumLit "4"]]
]
tables :: TestItem
tables = Group "tables" $ map (uncurry (TestQueryExpr ansi2011))
[("table tbl", Table [Name Nothing "tbl"])
tables = Group "tables"
[q "table tbl" $ Table [Name Nothing "tbl"]
]
q :: HasCallStack => Text -> QueryExpr -> TestItem
q src ast = testQueryExpr ansi2011 src ast

26
tests/Language/SQL/SimpleSQL/QueryExprs.hs
View file

@ -9,19 +9,23 @@ 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" $ map (uncurry (TestStatements ansi2011))
[("select 1",[ms])
,("select 1;",[ms])
,("select 1;select 1",[ms,ms])
,(" select 1;select 1; ",[ms,ms])
,("SELECT CURRENT_TIMESTAMP;"
,[SelectStatement $ toQueryExpr $ makeSelect
{msSelectList = [(Iden [Name Nothing "CURRENT_TIMESTAMP"],Nothing)]}])
,("SELECT \"CURRENT_TIMESTAMP\";"
,[SelectStatement $ toQueryExpr $ makeSelect
{msSelectList = [(Iden [Name (Just ("\"","\"")) "CURRENT_TIMESTAMP"],Nothing)]}])
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

156
tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs
View file

@ -11,6 +11,8 @@ module Language.SQL.SimpleSQL.SQL2011AccessControl (sql2011AccessControlTests) w
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" [
@ -78,128 +80,107 @@ sql2011AccessControlTests = Group "sql 2011 access control tests" [
| CURRENT_ROLE
-}
(TestStatement ansi2011
"grant all privileges on tbl1 to role1"
s "grant all privileges on tbl1 to role1"
$ GrantPrivilege [PrivAll]
(PrivTable [Name Nothing "tbl1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant all privileges on tbl1 to role1,role2"
,s "grant all privileges on tbl1 to role1,role2"
$ GrantPrivilege [PrivAll]
(PrivTable [Name Nothing "tbl1"])
[Name Nothing "role1",Name Nothing "role2"] WithoutGrantOption)
[Name Nothing "role1",Name Nothing "role2"] WithoutGrantOption
,(TestStatement ansi2011
"grant all privileges on tbl1 to role1 with grant option"
,s "grant all privileges on tbl1 to role1 with grant option"
$ GrantPrivilege [PrivAll]
(PrivTable [Name Nothing "tbl1"])
[Name Nothing "role1"] WithGrantOption)
[Name Nothing "role1"] WithGrantOption
,(TestStatement ansi2011
"grant all privileges on table tbl1 to role1"
,s "grant all privileges on table tbl1 to role1"
$ GrantPrivilege [PrivAll]
(PrivTable [Name Nothing "tbl1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant all privileges on domain mydom to role1"
,s "grant all privileges on domain mydom to role1"
$ GrantPrivilege [PrivAll]
(PrivDomain [Name Nothing "mydom"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant all privileges on type t1 to role1"
,s "grant all privileges on type t1 to role1"
$ GrantPrivilege [PrivAll]
(PrivType [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant all privileges on sequence s1 to role1"
,s "grant all privileges on sequence s1 to role1"
$ GrantPrivilege [PrivAll]
(PrivSequence [Name Nothing "s1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant select on table t1 to role1"
,s "grant select on table t1 to role1"
$ GrantPrivilege [PrivSelect []]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant select(a,b) on table t1 to role1"
,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)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant delete on table t1 to role1"
,s "grant delete on table t1 to role1"
$ GrantPrivilege [PrivDelete]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant insert on table t1 to role1"
,s "grant insert on table t1 to role1"
$ GrantPrivilege [PrivInsert []]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant insert(a,b) on table t1 to role1"
,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)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant update on table t1 to role1"
,s "grant update on table t1 to role1"
$ GrantPrivilege [PrivUpdate []]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant update(a,b) on table t1 to role1"
,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)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant references on table t1 to role1"
,s "grant references on table t1 to role1"
$ GrantPrivilege [PrivReferences []]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant references(a,b) on table t1 to role1"
,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)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant usage on table t1 to role1"
,s "grant usage on table t1 to role1"
$ GrantPrivilege [PrivUsage]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant trigger on table t1 to role1"
,s "grant trigger on table t1 to role1"
$ GrantPrivilege [PrivTrigger]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant execute on specific function f to role1"
,s "grant execute on specific function f to role1"
$ GrantPrivilege [PrivExecute]
(PrivFunction [Name Nothing "f"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
,(TestStatement ansi2011
"grant select,delete on table t1 to role1"
,s "grant select,delete on table t1 to role1"
$ GrantPrivilege [PrivSelect [], PrivDelete]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] WithoutGrantOption)
[Name Nothing "role1"] WithoutGrantOption
{-
skipping for now:
@ -224,9 +205,8 @@ functions, etc., by argument types since they can be overloaded
CREATE ROLE <role name> [ WITH ADMIN <grantor> ]
-}
,(TestStatement ansi2011
"create role rolee"
$ CreateRole (Name Nothing "rolee"))
,s "create role rolee"
$ CreateRole (Name Nothing "rolee")
{-
@ -242,18 +222,15 @@ functions, etc., by argument types since they can be overloaded
<role name>
-}
,(TestStatement ansi2011
"grant role1 to public"
$ GrantRole [Name Nothing "role1"] [Name Nothing "public"] WithoutAdminOption)
,s "grant role1 to public"
$ GrantRole [Name Nothing "role1"] [Name Nothing "public"] WithoutAdminOption
,(TestStatement ansi2011
"grant role1,role2 to role3,role4"
,s "grant role1,role2 to role3,role4"
$ GrantRole [Name Nothing "role1",Name Nothing "role2"]
[Name Nothing "role3", Name Nothing "role4"] WithoutAdminOption)
[Name Nothing "role3", Name Nothing "role4"] WithoutAdminOption
,(TestStatement ansi2011
"grant role1 to role3 with admin option"
$ GrantRole [Name Nothing "role1"] [Name Nothing "role3"] WithAdminOption)
,s "grant role1 to role3 with admin option"
$ GrantRole [Name Nothing "role1"] [Name Nothing "role3"] WithAdminOption
{-
@ -263,9 +240,8 @@ functions, etc., by argument types since they can be overloaded
DROP ROLE <role name>
-}
,(TestStatement ansi2011
"drop role rolee"
$ DropRole (Name Nothing "rolee"))
,s "drop role rolee"
$ DropRole (Name Nothing "rolee")
{-
@ -287,17 +263,16 @@ functions, etc., by argument types since they can be overloaded
-}
,(TestStatement ansi2011
"revoke select on t1 from role1"
,s "revoke select on t1 from role1"
$ RevokePrivilege NoGrantOptionFor [PrivSelect []]
(PrivTable [Name Nothing "t1"])
[Name Nothing "role1"] DefaultDropBehaviour)
[Name Nothing "role1"] DefaultDropBehaviour
,(TestStatement ansi2011
,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)
[Name Nothing "role1",Name Nothing "role2"] Cascade
{-
@ -311,20 +286,19 @@ functions, etc., by argument types since they can be overloaded
<role name>
-}
,(TestStatement ansi2011
"revoke role1 from role2"
,s "revoke role1 from role2"
$ RevokeRole NoAdminOptionFor [Name Nothing "role1"]
[Name Nothing "role2"] DefaultDropBehaviour)
[Name Nothing "role2"] DefaultDropBehaviour
,(TestStatement ansi2011
"revoke role1,role2 from role3,role4"
,s "revoke role1,role2 from role3,role4"
$ RevokeRole NoAdminOptionFor [Name Nothing "role1",Name Nothing "role2"]
[Name Nothing "role3",Name Nothing "role4"] DefaultDropBehaviour)
[Name Nothing "role3",Name Nothing "role4"] DefaultDropBehaviour
,(TestStatement ansi2011
"revoke admin option for role1 from role2 cascade"
$ RevokeRole AdminOptionFor [Name Nothing "role1"] [Name Nothing "role2"] Cascade)
,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

40
tests/Language/SQL/SimpleSQL/SQL2011Bits.hs
View file

@ -12,6 +12,8 @@ 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" [
@ -27,9 +29,7 @@ sql2011BitsTests = Group "sql 2011 bits tests" [
BEGIN is not in the standard!
-}
(TestStatement ansi2011
"start transaction"
$ StartTransaction)
s "start transaction" StartTransaction
{-
17.2 <set transaction statement>
@ -84,9 +84,8 @@ BEGIN is not in the standard!
<savepoint name>
-}
,(TestStatement ansi2011
"savepoint difficult_bit"
$ Savepoint $ Name Nothing "difficult_bit")
,s "savepoint difficult_bit"
$ Savepoint $ Name Nothing "difficult_bit"
{-
@ -96,9 +95,8 @@ BEGIN is not in the standard!
RELEASE SAVEPOINT <savepoint specifier>
-}
,(TestStatement ansi2011
"release savepoint difficult_bit"
$ ReleaseSavepoint $ Name Nothing "difficult_bit")
,s "release savepoint difficult_bit"
$ ReleaseSavepoint $ Name Nothing "difficult_bit"
{-
@ -108,13 +106,9 @@ BEGIN is not in the standard!
COMMIT [ WORK ] [ AND [ NO ] CHAIN ]
-}
,(TestStatement ansi2011
"commit"
$ Commit)
,s "commit" Commit
,(TestStatement ansi2011
"commit work"
$ Commit)
,s "commit work" Commit
{-
@ -127,17 +121,12 @@ BEGIN is not in the standard!
TO SAVEPOINT <savepoint specifier>
-}
,(TestStatement ansi2011
"rollback"
$ Rollback Nothing)
,s "rollback" $ Rollback Nothing
,(TestStatement ansi2011
"rollback work"
$ Rollback Nothing)
,s "rollback work" $ Rollback Nothing
,(TestStatement ansi2011
"rollback to savepoint difficult_bit"
$ Rollback $ Just $ Name Nothing "difficult_bit")
,s "rollback to savepoint difficult_bit"
$ Rollback $ Just $ Name Nothing "difficult_bit"
{-
@ -232,3 +221,6 @@ BEGIN is not in the standard!
-}
]
s :: HasCallStack => Text -> Statement -> TestItem
s src ast = testStatement ansi2011 src ast

77
tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs
View file

@ -7,6 +7,8 @@ module Language.SQL.SimpleSQL.SQL2011DataManipulation (sql2011DataManipulationTe
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"
@ -111,20 +113,20 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
[ WHERE <search condition> ]
-}
(TestStatement ansi2011 "delete from t"
$ Delete [Name Nothing "t"] Nothing Nothing)
s "delete from t"
$ Delete [Name Nothing "t"] Nothing Nothing
,(TestStatement ansi2011 "delete from t as u"
$ Delete [Name Nothing "t"] (Just (Name Nothing "u")) Nothing)
,s "delete from t as u"
$ Delete [Name Nothing "t"] (Just (Name Nothing "u")) Nothing
,(TestStatement ansi2011 "delete from t where x = 5"
,s "delete from t where x = 5"
$ Delete [Name Nothing "t"] Nothing
(Just $ BinOp (Iden [Name Nothing "x"]) [Name Nothing "="] (NumLit "5")))
(Just $ BinOp (Iden [Name Nothing "x"]) [Name Nothing "="] (NumLit "5"))
,(TestStatement ansi2011 "delete from t as u where u.x = 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")))
(Just $ BinOp (Iden [Name Nothing "u", Name Nothing "x"]) [Name Nothing "="] (NumLit "5"))
{-
14.10 <truncate table statement>
@ -137,14 +139,14 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
| RESTART IDENTITY
-}
,(TestStatement ansi2011 "truncate table t"
$ Truncate [Name Nothing "t"] DefaultIdentityRestart)
,s "truncate table t"
$ Truncate [Name Nothing "t"] DefaultIdentityRestart
,(TestStatement ansi2011 "truncate table t continue identity"
$ Truncate [Name Nothing "t"] ContinueIdentity)
,s "truncate table t continue identity"
$ Truncate [Name Nothing "t"] ContinueIdentity
,(TestStatement ansi2011 "truncate table t restart identity"
$ Truncate [Name Nothing "t"] RestartIdentity)
,s "truncate table t restart identity"
$ Truncate [Name Nothing "t"] RestartIdentity
{-
@ -182,37 +184,37 @@ sql2011DataManipulationTests = Group "sql 2011 data manipulation tests"
<column name list>
-}
,(TestStatement ansi2011 "insert into t select * from u"
,s "insert into t select * from u"
$ Insert [Name Nothing "t"] Nothing
$ InsertQuery $ toQueryExpr $ makeSelect
{msSelectList = [(Star, Nothing)]
,msFrom = [TRSimple [Name Nothing "u"]]})
,msFrom = [TRSimple [Name Nothing "u"]]}
,(TestStatement ansi2011 "insert into t(a,b,c) select * from 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"]]})
,msFrom = [TRSimple [Name Nothing "u"]]}
,(TestStatement ansi2011 "insert into t default values"
$ Insert [Name Nothing "t"] Nothing DefaultInsertValues)
,s "insert into t default values"
$ Insert [Name Nothing "t"] Nothing DefaultInsertValues
,(TestStatement ansi2011 "insert into t values(1,2)"
,s "insert into t values(1,2)"
$ Insert [Name Nothing "t"] Nothing
$ InsertQuery $ Values [[NumLit "1", NumLit "2"]])
$ InsertQuery $ Values [[NumLit "1", NumLit "2"]]
,(TestStatement ansi2011 "insert into t values (1,2),(3,4)"
,s "insert into t values (1,2),(3,4)"
$ Insert [Name Nothing "t"] Nothing
$ InsertQuery $ Values [[NumLit "1", NumLit "2"]
,[NumLit "3", NumLit "4"]])
,[NumLit "3", NumLit "4"]]
,(TestStatement ansi2011
,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 []]])
,MultisetCtor []]]
{-
@ -456,32 +458,32 @@ FROM CentralOfficeAccounts;
-}
,(TestStatement ansi2011 "update t set a=b"
,s "update t set a=b"
$ Update [Name Nothing "t"] Nothing
[Set [Name Nothing "a"] (Iden [Name Nothing "b"])] Nothing)
[Set [Name Nothing "a"] (Iden [Name Nothing "b"])] Nothing
,(TestStatement ansi2011 "update t set a=b, c=5"
,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)
,Set [Name Nothing "c"] (NumLit "5")] Nothing
,(TestStatement ansi2011 "update t set a=b where a>5"
,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"))
$ Just $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5")
,(TestStatement ansi2011 "update t as u set a=b where u.a>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"))
[Name Nothing ">"] (NumLit "5")
,(TestStatement ansi2011 "update t set (a,b)=(3,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)
[NumLit "3", NumLit "5"]] Nothing
@ -553,3 +555,6 @@ declare local temporary table t (a int) [on commit {preserve | delete} rows]
]
s :: HasCallStack => Text -> Statement -> TestItem
s src ast = testStatement ansi2011 src ast

353
tests/Language/SQL/SimpleSQL/SQL2011Queries.hs
View file

@ -37,6 +37,7 @@ 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"
@ -515,19 +516,19 @@ generalLiterals = Group "general literals"
characterStringLiterals :: TestItem
characterStringLiterals = Group "character string literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("'a regular string literal'"
,StringLit "'" "'" "a regular string literal")
,("'something' ' some more' 'and more'"
,StringLit "'" "'" "something some moreand more")
,("'something' \n ' some more' \t 'and more'"
,StringLit "'" "'" "something some moreand more")
,("'something' -- a comment\n ' some more' /*another comment*/ 'and more'"
,StringLit "'" "'" "something some moreand more")
,("'a quote: '', stuff'"
,StringLit "'" "'" "a quote: '', stuff")
,("''"
,StringLit "'" "'" "")
$
[e "'a regular string literal'"
$ StringLit "'" "'" "a regular string literal"
,e "'something' ' some more' 'and more'"
$ StringLit "'" "'" "something some moreand more"
,e "'something' \n ' some more' \t 'and more'"
$ StringLit "'" "'" "something some moreand more"
,e "'something' -- a comment\n ' some more' /*another comment*/ 'and more'"
$ StringLit "'" "'" "something some moreand more"
,e "'a quote: '', stuff'"
$ StringLit "'" "'" "a quote: '', stuff"
,e "''"
$ StringLit "'" "'" ""
{-
I'm not sure how this should work. Maybe the parser should reject non
@ -535,8 +536,8 @@ ascii characters in strings and identifiers unless the current SQL
character set allows them.
-}
,("_francais 'français'"
,TypedLit (TypeName [Name Nothing "_francais"]) "français")
,e "_francais 'français'"
$ TypedLit (TypeName [Name Nothing "_francais"]) "français"
]
{-
@ -547,9 +548,9 @@ character set allows them.
nationalCharacterStringLiterals :: TestItem
nationalCharacterStringLiterals = Group "national character string literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("N'something'", StringLit "N'" "'" "something")
,("n'something'", StringLit "n'" "'" "something")
$
[e "N'something'" $ StringLit "N'" "'" "something"
,e "n'something'" $ StringLit "n'" "'" "something"
]
{-
@ -566,8 +567,8 @@ nationalCharacterStringLiterals = Group "national character string literals"
unicodeCharacterStringLiterals :: TestItem
unicodeCharacterStringLiterals = Group "unicode character string literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("U&'something'", StringLit "U&'" "'" "something")
$
[e "U&'something'" $ StringLit "U&'" "'" "something"
{-,("u&'something' escape ="
,Escape (StringLit "u&'" "'" "something") '=')
,("u&'something' uescape ="
@ -587,9 +588,9 @@ TODO: unicode escape
binaryStringLiterals :: TestItem
binaryStringLiterals = Group "binary string literals"
$ map (uncurry (TestScalarExpr ansi2011))
$
[--("B'101010'", CSStringLit "B" "101010")
("X'7f7f7f'", StringLit "X'" "'" "7f7f7f")
e "X'7f7f7f'" $ StringLit "X'" "'" "7f7f7f"
--,("X'7f7f7f' escape z", Escape (StringLit "X'" "'" "7f7f7f") 'z')
]
@ -619,33 +620,32 @@ binaryStringLiterals = Group "binary string literals"
numericLiterals :: TestItem
numericLiterals = Group "numeric literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("11", NumLit "11")
,("11.11", NumLit "11.11")
[e "11" $ NumLit "11"
,e "11.11" $ NumLit "11.11"
,("11E23", NumLit "11E23")
,("11E+23", NumLit "11E+23")
,("11E-23", NumLit "11E-23")
,e "11E23" $ NumLit "11E23"
,e "11E+23" $ NumLit "11E+23"
,e "11E-23" $ NumLit "11E-23"
,("11.11E23", NumLit "11.11E23")
,("11.11E+23", NumLit "11.11E+23")
,("11.11E-23", NumLit "11.11E-23")
,e "11.11E23" $ NumLit "11.11E23"
,e "11.11E+23" $ NumLit "11.11E+23"
,e "11.11E-23" $ NumLit "11.11E-23"
,("+11E23", PrefixOp [Name Nothing "+"] $ NumLit "11E23")
,("+11E+23", PrefixOp [Name Nothing "+"] $ NumLit "11E+23")
,("+11E-23", PrefixOp [Name Nothing "+"] $ NumLit "11E-23")
,("+11.11E23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E23")
,("+11.11E+23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E+23")
,("+11.11E-23", PrefixOp [Name Nothing "+"] $ NumLit "11.11E-23")
,e "+11E23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E23"
,e "+11E+23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E+23"
,e "+11E-23" $ PrefixOp [Name Nothing "+"] $ NumLit "11E-23"
,e "+11.11E23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E23"
,e "+11.11E+23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E+23"
,e "+11.11E-23" $ PrefixOp [Name Nothing "+"] $ NumLit "11.11E-23"
,("-11E23", PrefixOp [Name Nothing "-"] $ NumLit "11E23")
,("-11E+23", PrefixOp [Name Nothing "-"] $ NumLit "11E+23")
,("-11E-23", PrefixOp [Name Nothing "-"] $ NumLit "11E-23")
,("-11.11E23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E23")
,("-11.11E+23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E+23")
,("-11.11E-23", PrefixOp [Name Nothing "-"] $ NumLit "11.11E-23")
,e "-11E23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E23"
,e "-11E+23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E+23"
,e "-11E-23" $ PrefixOp [Name Nothing "-"] $ NumLit "11E-23"
,e "-11.11E23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E23"
,e "-11.11E+23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E+23"
,e "-11.11E-23" $ PrefixOp [Name Nothing "-"] $ NumLit "11.11E-23"
,("11.11e23", NumLit "11.11e23")
,e "11.11e23" $ NumLit "11.11e23"
]
@ -729,33 +729,30 @@ dateTimeLiterals = Group "datetime literals"
intervalLiterals :: TestItem
intervalLiterals = Group "intervalLiterals literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("interval '1'", TypedLit (TypeName [Name Nothing "interval"]) "1")
,("interval '1' day"
,IntervalLit Nothing "1" (Itf "day" Nothing) Nothing)
,("interval '1' day(3)"
,IntervalLit Nothing "1" (Itf "day" $ Just (3,Nothing)) Nothing)
,("interval + '1' day(3)"
,IntervalLit (Just Plus) "1" (Itf "day" $ Just (3,Nothing)) Nothing)
,("interval - '1' second(2,2)"
,IntervalLit (Just Minus) "1" (Itf "second" $ Just (2,Just 2)) Nothing)
,("interval '1' year to month"
,IntervalLit Nothing "1" (Itf "year" Nothing)
(Just $ Itf "month" Nothing))
,("interval '1' year(4) to second(2,3) "
,IntervalLit Nothing "1" (Itf "year" $ Just (4,Nothing))
(Just $ Itf "second" $ Just (2, Just 3)))
[e "interval '1'" $ TypedLit (TypeName [Name Nothing "interval"]) "1"
,e "interval '1' day"
$ IntervalLit Nothing "1" (Itf "day" Nothing) Nothing
,e "interval '1' day(3)"
$ IntervalLit Nothing "1" (Itf "day" $ Just (3,Nothing)) Nothing
,e "interval + '1' day(3)"
$ IntervalLit (Just Plus) "1" (Itf "day" $ Just (3,Nothing)) Nothing
,e "interval - '1' second(2,2)"
$ IntervalLit (Just Minus) "1" (Itf "second" $ Just (2,Just 2)) Nothing
,e "interval '1' year to month"
$ IntervalLit Nothing "1" (Itf "year" Nothing)
(Just $ Itf "month" Nothing)
,e "interval '1' year(4) to second(2,3) "
$ IntervalLit Nothing "1" (Itf "year" $ Just (4,Nothing))
(Just $ Itf "second" $ Just (2, Just 3))
]
-- <boolean literal> ::= TRUE | FALSE | UNKNOWN
booleanLiterals :: TestItem
booleanLiterals = Group "boolean literals"
$ map (uncurry (TestScalarExpr ansi2011))
[("true", Iden [Name Nothing "true"])
,("false", Iden [Name Nothing "false"])
,("unknown", Iden [Name Nothing "unknown"])
[e "true" $ Iden [Name Nothing "true"]
,e "false" $ Iden [Name Nothing "false"]
,e "unknown" $ Iden [Name Nothing "unknown"]
]
{-
@ -774,16 +771,15 @@ Specify names.
identifiers :: TestItem
identifiers = Group "identifiers"
$ map (uncurry (TestScalarExpr ansi2011))
[("test",Iden [Name Nothing "test"])
,("_test",Iden [Name Nothing "_test"])
,("t1",Iden [Name Nothing "t1"])
,("a.b",Iden [Name Nothing "a", Name Nothing "b"])
,("a.b.c",Iden [Name Nothing "a", Name Nothing "b", Name Nothing "c"])
,("\"quoted iden\"", Iden [Name (Just ("\"","\"")) "quoted iden"])
,("\"quoted \"\" iden\"", Iden [Name (Just ("\"","\"")) "quoted \"\" iden"])
,("U&\"quoted iden\"", Iden [Name (Just ("U&\"","\"")) "quoted iden"])
,("U&\"quoted \"\" iden\"", Iden [Name (Just ("U&\"","\"")) "quoted \"\" iden"])
[e "test" $ Iden [Name Nothing "test"]
,e "_test" $ Iden [Name Nothing "_test"]
,e "t1" $ Iden [Name Nothing "t1"]
,e "a.b" $ Iden [Name Nothing "a", Name Nothing "b"]
,e "a.b.c" $ Iden [Name Nothing "a", Name Nothing "b", Name Nothing "c"]
,e "\"quoted iden\"" $ Iden [Name (Just ("\"", "\"")) "quoted iden"]
,e "\"quoted \"\" iden\"" $ Iden [Name (Just ("\"", "\"")) "quoted \"\" iden"]
,e "U&\"quoted iden\"" $ Iden [Name (Just ("U&\"", "\"")) "quoted iden"]
,e "U&\"quoted \"\" iden\"" $ Iden [Name (Just ("U&\"", "\"")) "quoted \"\" iden"]
]
{-
@ -1220,11 +1216,11 @@ expression
typeNameTests :: TestItem
typeNameTests = Group "type names"
[Group "type names" $ map (uncurry (TestScalarExpr ansi2011))
[Group "type names" $ map (uncurry (testScalarExpr ansi2011))
$ concatMap makeSimpleTests $ fst typeNames
,Group "generated casts" $ map (uncurry (TestScalarExpr ansi2011))
,Group "generated casts" $ map (uncurry (testScalarExpr ansi2011))
$ concatMap makeCastTests $ fst typeNames
,Group "generated typename" $ map (uncurry (TestScalarExpr ansi2011))
,Group "generated typename" $ map (uncurry (testScalarExpr ansi2011))
$ concatMap makeTests $ snd typeNames]
where
makeSimpleTests (ctn, stn) =
@ -1247,12 +1243,10 @@ Define a field of a row type.
fieldDefinition :: TestItem
fieldDefinition = Group "field definition"
$ map (uncurry (TestScalarExpr ansi2011))
[("cast('(1,2)' as row(a int,b char))"
,Cast (StringLit "'" "'" "(1,2)")
[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"])])]
,(Name Nothing "b", TypeName [Name Nothing "char"])]]
{-
== 6.3 <value expression primary>
@ -1329,9 +1323,8 @@ valueExpressions = Group "value expressions"
parenthesizedScalarExpression :: TestItem
parenthesizedScalarExpression = Group "parenthesized value expression"
$ map (uncurry (TestScalarExpr ansi2011))
[("(3)", Parens (NumLit "3"))
,("((3))", Parens $ Parens (NumLit "3"))
[e "(3)" $ Parens (NumLit "3")
,e "((3))" $ Parens $ Parens (NumLit "3")
]
{-
@ -1367,8 +1360,7 @@ Specify one or more values, host parameters, SQL parameters, dynamic parameters,
generalValueSpecification :: TestItem
generalValueSpecification = Group "general value specification"
$ map (uncurry (TestScalarExpr ansi2011)) $
map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP"
$ map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP"
,"CURRENT_PATH"
,"CURRENT_ROLE"
,"CURRENT_USER"
@ -1377,7 +1369,7 @@ generalValueSpecification = Group "general value specification"
,"USER"
,"VALUE"]
where
mkIden nm = (nm,Iden [Name Nothing nm])
mkIden nm = e nm $ Iden [Name Nothing nm]
{-
TODO: add the missing bits
@ -1423,12 +1415,11 @@ TODO: add the missing bits
parameterSpecification :: TestItem
parameterSpecification = Group "parameter specification"
$ map (uncurry (TestScalarExpr ansi2011))
[(":hostparam", HostParameter ":hostparam" Nothing)
,(":hostparam indicator :another_host_param"
,HostParameter ":hostparam" $ Just ":another_host_param")
,("?", Parameter)
,(":h[3]", Array (HostParameter ":h" Nothing) [NumLit "3"])
[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"]
]
{-
@ -1462,11 +1453,10 @@ Specify a value whose data type is to be inferred from its context.
contextuallyTypedValueSpecification :: TestItem
contextuallyTypedValueSpecification =
Group "contextually typed value specification"
$ map (uncurry (TestScalarExpr ansi2011))
[("null", Iden [Name Nothing "null"])
,("array[]", Array (Iden [Name Nothing "array"]) [])
,("multiset[]", MultisetCtor [])
,("default", Iden [Name Nothing "default"])
[e "null" $ Iden [Name Nothing "null"]
,e "array[]" $ Array (Iden [Name Nothing "array"]) []
,e "multiset[]" $ MultisetCtor []
,e "default" $ Iden [Name Nothing "default"]
]
{-
@ -1482,8 +1472,7 @@ Disambiguate a <period>-separated chain of identifiers.
identifierChain :: TestItem
identifierChain = Group "identifier chain"
$ map (uncurry (TestScalarExpr ansi2011))
[("a.b", Iden [Name Nothing "a",Name Nothing "b"])]
[e "a.b" $ Iden [Name Nothing "a",Name Nothing "b"]]
{-
== 6.7 <column reference>
@ -1498,8 +1487,7 @@ Reference a column.
columnReference :: TestItem
columnReference = Group "column reference"
$ map (uncurry (TestScalarExpr ansi2011))
[("module.a.b", Iden [Name Nothing "module",Name Nothing "a",Name Nothing "b"])]
[e "module.a.b" $ Iden [Name Nothing "module",Name Nothing "a",Name Nothing "b"]]
{-
== 6.8 <SQL parameter reference>
@ -1523,19 +1511,19 @@ Specify a value derived by the application of a function to an argument.
setFunctionSpecification :: TestItem
setFunctionSpecification = Group "set function specification"
$ map (uncurry (TestQueryExpr ansi2011))
[("SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\
$
[q "SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\
\ GROUPING(SalesQuota) AS Grouping\n\
\FROM Sales.SalesPerson\n\
\GROUP BY ROLLUP(SalesQuota);"
,toQueryExpr $ makeSelect
$ 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"])]]})
,msGroupBy = [Rollup [SimpleGroup (Iden [Name Nothing "SalesQuota"])]]}
]
{-
@ -1732,9 +1720,8 @@ Specify a data conversion.
castSpecification :: TestItem
castSpecification = Group "cast specification"
$ map (uncurry (TestScalarExpr ansi2011))
[("cast(a as int)"
,Cast (Iden [Name Nothing "a"]) (TypeName [Name Nothing "int"]))
[e "cast(a as int)"
$ Cast (Iden [Name Nothing "a"]) (TypeName [Name Nothing "int"])
]
{-
@ -1748,8 +1735,7 @@ Return the next value of a sequence generator.
nextScalarExpression :: TestItem
nextScalarExpression = Group "next value expression"
$ map (uncurry (TestScalarExpr ansi2011))
[("next value for a.b", NextValueFor [Name Nothing "a", Name Nothing "b"])
[e "next value for a.b" $ NextValueFor [Name Nothing "a", Name Nothing "b"]
]
{-
@ -1763,11 +1749,10 @@ Reference a field of a row value.
fieldReference :: TestItem
fieldReference = Group "field reference"
$ map (uncurry (TestScalarExpr ansi2011))
[("f(something).a"
,BinOp (App [Name Nothing "f"] [Iden [Name Nothing "something"]])
[e "f(something).a"
$ BinOp (App [Name Nothing "f"] [Iden [Name Nothing "something"]])
[Name Nothing "."]
(Iden [Name Nothing "a"]))
(Iden [Name Nothing "a"])
]
{-
@ -1889,17 +1874,16 @@ Return an element of an array.
arrayElementReference :: TestItem
arrayElementReference = Group "array element reference"
$ map (uncurry (TestScalarExpr ansi2011))
[("something[3]"
,Array (Iden [Name Nothing "something"]) [NumLit "3"])
,("(something(a))[x]"
,Array (Parens (App [Name Nothing "something"] [Iden [Name Nothing "a"]]))
[Iden [Name Nothing "x"]])
,("(something(a))[x][y] "
,Array (
[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"]])
[Iden [Name Nothing "y"]]
]
{-
@ -1914,9 +1898,8 @@ Return the sole element of a multiset of one element.
multisetElementReference :: TestItem
multisetElementReference = Group "multisetElementReference"
$ map (uncurry (TestScalarExpr ansi2011))
[("element(something)"
,App [Name Nothing "element"] [Iden [Name Nothing "something"]])
[e "element(something)"
$ App [Name Nothing "element"] [Iden [Name Nothing "something"]]
]
{-
@ -1966,13 +1949,12 @@ Specify a numeric value.
numericScalarExpression :: TestItem
numericScalarExpression = Group "numeric value expression"
$ map (uncurry (TestScalarExpr ansi2011))
[("a + b", binOp "+")
,("a - b", binOp "-")
,("a * b", binOp "*")
,("a / b", binOp "/")
,("+a", prefOp "+")
,("-a", prefOp "-")
[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"])
@ -2439,17 +2421,16 @@ Specify a boolean value.
booleanScalarExpression :: TestItem
booleanScalarExpression = Group "booleab value expression"
$ map (uncurry (TestScalarExpr ansi2011))
[("a or b", BinOp a [Name Nothing "or"] b)
,("a and b", BinOp a [Name Nothing "and"] b)
,("not a", PrefixOp [Name Nothing "not"] a)
,("a is true", postfixOp "is true")
,("a is false", postfixOp "is false")
,("a is unknown", postfixOp "is unknown")
,("a is not true", postfixOp "is not true")
,("a is not false", postfixOp "is not false")
,("a is not unknown", postfixOp "is not unknown")
,("(a or b)", Parens $ BinOp a [Name Nothing "or"] b)
[e "a or b" $ BinOp a [Name Nothing "or"] b
,e "a and b" $ BinOp a [Name Nothing "and"] b
,e "not a" $ PrefixOp [Name Nothing "not"] a
,e "a is true" $ postfixOp "is true"
,e "a is false" $ postfixOp "is false"
,e "a is unknown" $ postfixOp "is unknown"
,e "a is not true" $ postfixOp "is not true"
,e "a is not false" $ postfixOp "is not false"
,e "a is not unknown" $ postfixOp "is not unknown"
,e "(a or b)" $ Parens $ BinOp a [Name Nothing "or"] b
]
where
a = Iden [Name Nothing "a"]
@ -2520,23 +2501,22 @@ Specify construction of an array.
arrayValueConstructor :: TestItem
arrayValueConstructor = Group "array value constructor"
$ map (uncurry (TestScalarExpr ansi2011))
[("array[1,2,3]"
,Array (Iden [Name Nothing "array"])
[NumLit "1", NumLit "2", NumLit "3"])
,("array[a,b,c]"
,Array (Iden [Name Nothing "array"])
[Iden [Name Nothing "a"], Iden [Name Nothing "b"], Iden [Name Nothing "c"]])
,("array(select * from t)"
,ArrayCtor (toQueryExpr $ makeSelect
[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"]]}))
,("array(select * from t order by a)"
,ArrayCtor (toQueryExpr $ makeSelect
,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]}))
DirDefault NullsOrderDefault]})
]
@ -2560,7 +2540,7 @@ Specify a multiset value.
multisetScalarExpression :: TestItem
multisetScalarExpression = Group "multiset value expression"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("a multiset union b"
,MultisetBinOp (Iden [Name Nothing "a"]) Union SQDefault (Iden [Name Nothing "b"]))
,("a multiset union all b"
@ -2592,7 +2572,7 @@ special case term.
multisetValueFunction :: TestItem
multisetValueFunction = Group "multiset value function"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("set(a)", App [Name Nothing "set"] [Iden [Name Nothing "a"]])
]
@ -2622,7 +2602,7 @@ Specify construction of a multiset.
multisetValueConstructor :: TestItem
multisetValueConstructor = Group "multiset value constructor"
$ map (uncurry (TestScalarExpr ansi2011))
$ 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)
@ -2702,7 +2682,7 @@ Specify a value or list of values to be constructed into a row.
rowValueConstructor :: TestItem
rowValueConstructor = Group "row value constructor"
$ map (uncurry (TestScalarExpr ansi2011))
$ 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"])
@ -2755,7 +2735,7 @@ Specify a set of <row value expression>s to be constructed into a table.
tableValueConstructor :: TestItem
tableValueConstructor = Group "table value constructor"
$ map (uncurry (TestQueryExpr ansi2011))
$ 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 "+"]
@ -2792,7 +2772,7 @@ Specify a table derived from one or more tables.
fromClause :: TestItem
fromClause = Group "fromClause"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("select * from tbl1,tbl2"
,toQueryExpr $ makeSelect
{msSelectList = [(Star, Nothing)]
@ -2809,7 +2789,7 @@ Reference a table.
tableReference :: TestItem
tableReference = Group "table reference"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("select * from t", toQueryExpr sel)
{-
@ -2994,7 +2974,7 @@ Specify a table derived from a Cartesian product, inner join, or outer join.
joinedTable :: TestItem
joinedTable = Group "joined table"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("select * from a cross join b"
,sel $ TRJoin a False JCross b Nothing)
,("select * from a join b on true"
@ -3053,7 +3033,7 @@ the result of the preceding <from clause>.
whereClause :: TestItem
whereClause = Group "where clause"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("select * from t where a = 5"
,toQueryExpr $ makeSelect
{msSelectList = [(Star,Nothing)]
@ -3115,7 +3095,7 @@ clause> to the result of the previously specified clause.
groupByClause :: TestItem
groupByClause = Group "group by clause"
$ map (uncurry (TestQueryExpr ansi2011))
$ 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"
@ -3170,7 +3150,7 @@ not satisfy a <search condition>.
havingClause :: TestItem
havingClause = Group "having clause"
$ map (uncurry (TestQueryExpr ansi2011))
$ 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)
@ -3297,7 +3277,7 @@ Specify a table derived from the result of a <table expression>.
querySpecification :: TestItem
querySpecification = Group "query specification"
$ map (uncurry (TestQueryExpr ansi2011))
$ 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})
@ -3369,7 +3349,7 @@ withQueryExpression= Group "with query expression"
setOpQueryExpression :: TestItem
setOpQueryExpression= Group "set operation query expression"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
-- todo: complete setop query expression tests
[{-("select * from t union select * from t"
,undefined)
@ -3408,7 +3388,7 @@ everywhere
explicitTableQueryExpression :: TestItem
explicitTableQueryExpression= Group "explicit table query expression"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("table t", Table [Name Nothing "t"])
]
@ -3432,7 +3412,7 @@ explicitTableQueryExpression= Group "explicit table query expression"
orderOffsetFetchQueryExpression :: TestItem
orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression"
$ map (uncurry (TestQueryExpr ansi2011))
$ 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"])
@ -3597,7 +3577,7 @@ Specify a comparison of two row values.
comparisonPredicates :: TestItem
comparisonPredicates = Group "comparison predicates"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
$ map mkOp ["=", "<>", "<", ">", "<=", ">="]
<> [("ROW(a) = ROW(b)"
,BinOp (App [Name Nothing "ROW"] [a])
@ -3815,7 +3795,7 @@ Specify a quantified comparison.
quantifiedComparisonPredicate :: TestItem
quantifiedComparisonPredicate = Group "quantified comparison predicate"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("a = any (select * from t)"
,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPAny ms)
@ -3844,7 +3824,7 @@ Specify a test for a non-empty set.
existsPredicate :: TestItem
existsPredicate = Group "exists predicate"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("exists(select * from t where a = 4)"
,SubQueryExpr SqExists
$ toQueryExpr $ makeSelect
@ -3865,7 +3845,7 @@ Specify a test for the absence of duplicate rows.
uniquePredicate :: TestItem
uniquePredicate = Group "unique predicate"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("unique(select * from t where a = 4)"
,SubQueryExpr SqUnique
$ toQueryExpr $ makeSelect
@ -3905,7 +3885,7 @@ Specify a test for matching rows.
matchPredicate :: TestItem
matchPredicate = Group "match predicate"
$ map (uncurry (TestScalarExpr ansi2011))
$ 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)"
@ -4273,7 +4253,7 @@ Specify a default collation.
collateClause :: TestItem
collateClause = Group "collate clause"
$ map (uncurry (TestScalarExpr ansi2011))
$ map (uncurry (testScalarExpr ansi2011))
[("a collate my_collation"
,Collate (Iden [Name Nothing "a"]) [Name Nothing "my_collation"])]
@ -4386,7 +4366,7 @@ Specify a value computed from a collection of rows.
aggregateFunction :: TestItem
aggregateFunction = Group "aggregate function"
$ map (uncurry (TestScalarExpr ansi2011)) $
$ map (uncurry (testScalarExpr ansi2011)) $
[("count(*)",App [Name Nothing "count"] [Star])
,("count(*) filter (where something > 5)"
,AggregateApp [Name Nothing "count"] SQDefault [Star] [] fil)
@ -4483,7 +4463,7 @@ Specify a sort order.
sortSpecificationList :: TestItem
sortSpecificationList = Group "sort specification list"
$ map (uncurry (TestQueryExpr ansi2011))
$ map (uncurry (testQueryExpr ansi2011))
[("select * from t order by a"
,toQueryExpr $ ms {msOrderBy = [SortSpec (Iden [Name Nothing "a"])
DirDefault NullsOrderDefault]})
@ -4518,3 +4498,10 @@ sortSpecificationList = Group "sort specification list"
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

340
tests/Language/SQL/SimpleSQL/SQL2011Schema.hs
View file

@ -10,6 +10,8 @@ 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"
@ -25,8 +27,8 @@ sql2011SchemaTests = Group "sql 2011 schema tests"
[ <schema element>... ]
-}
(TestStatement ansi2011 "create schema my_schema"
$ CreateSchema [Name Nothing "my_schema"])
s "create schema my_schema"
$ CreateSchema [Name Nothing "my_schema"]
{-
todo: schema name can have .
@ -86,12 +88,12 @@ add schema element support:
-}
,(TestStatement ansi2011 "drop schema my_schema"
$ DropSchema [Name Nothing "my_schema"] DefaultDropBehaviour)
,(TestStatement ansi2011 "drop schema my_schema cascade"
$ DropSchema [Name Nothing "my_schema"] Cascade)
,(TestStatement ansi2011 "drop schema my_schema restrict"
$ DropSchema [Name Nothing "my_schema"] 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 <table definition>
@ -103,10 +105,10 @@ add schema element support:
[ ON COMMIT <table commit action> ROWS ]
-}
,(TestStatement ansi2011 "create table t (a int, b int);"
,s "create table t (a int, b int);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []])
,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []]
{-
@ -321,35 +323,35 @@ todo: constraint characteristics
-}
,(TestStatement ansi2011
,s
"create table t (a int not null);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing ColNotNullConstraint]])
[ColConstraintDef Nothing ColNotNullConstraint]]
,(TestStatement ansi2011
,s
"create table t (a int constraint a_not_null not null);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef (Just [Name Nothing "a_not_null"]) ColNotNullConstraint]])
[ColConstraintDef (Just [Name Nothing "a_not_null"]) ColNotNullConstraint]]
,(TestStatement ansi2011
,s
"create table t (a int unique);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing ColUniqueConstraint]])
[ColConstraintDef Nothing ColUniqueConstraint]]
,(TestStatement ansi2011
,s
"create table t (a int primary key);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing (ColPrimaryKeyConstraint False)]])
[ColConstraintDef Nothing (ColPrimaryKeyConstraint False)]]
,(TestStatement ansi2011 { diAutoincrement = True }
,testStatement ansi2011{ diAutoincrement = True }
"create table t (a int primary key autoincrement);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing (ColPrimaryKeyConstraint True)]])
[ColConstraintDef Nothing (ColPrimaryKeyConstraint True)]]
{-
references t(a,b)
@ -358,102 +360,102 @@ references t(a,b)
on delete ""
-}
,(TestStatement ansi2011
,s
"create table t (a int references u);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
DefaultReferentialAction DefaultReferentialAction]])
DefaultReferentialAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u(a));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] (Just $ Name Nothing "a") DefaultReferenceMatch
DefaultReferentialAction DefaultReferentialAction]])
DefaultReferentialAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u match full);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing MatchFull
DefaultReferentialAction DefaultReferentialAction]])
DefaultReferentialAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u match partial);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing MatchPartial
DefaultReferentialAction DefaultReferentialAction]])
DefaultReferentialAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u match simple);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing MatchSimple
DefaultReferentialAction DefaultReferentialAction]])
DefaultReferentialAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u on update cascade );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefCascade DefaultReferentialAction]])
RefCascade DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u on update set null );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefSetNull DefaultReferentialAction]])
RefSetNull DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u on update set default );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefSetDefault DefaultReferentialAction]])
RefSetDefault DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u on update no action );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefNoAction DefaultReferentialAction]])
RefNoAction DefaultReferentialAction]]
,(TestStatement ansi2011
,s
"create table t (a int references u on delete cascade );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
DefaultReferentialAction RefCascade]])
DefaultReferentialAction RefCascade]]
,(TestStatement ansi2011
,s
"create table t (a int references u on update cascade on delete restrict );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefCascade RefRestrict]])
RefCascade RefRestrict]]
,(TestStatement ansi2011
,s
"create table t (a int references u on delete restrict on update cascade );"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing $ ColReferencesConstraint
[Name Nothing "u"] Nothing DefaultReferenceMatch
RefCascade RefRestrict]])
RefCascade RefRestrict]]
{-
TODO: try combinations and permutations of column constraints and
@ -461,12 +463,12 @@ options
-}
,(TestStatement ansi2011
,s
"create table t (a int check (a>5));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing
[ColConstraintDef Nothing
(ColCheckConstraint $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))]])
(ColCheckConstraint $ BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (NumLit "5"))]]
@ -478,18 +480,18 @@ options
[ <left paren> <common sequence generator options> <right paren> ]
-}
,(TestStatement ansi2011 "create table t (a int generated always as identity);"
,s "create table t (a int generated always as identity);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
(Just $ IdentityColumnSpec GeneratedAlways []) []])
(Just $ IdentityColumnSpec GeneratedAlways []) []]
,(TestStatement ansi2011 "create table t (a int generated by default as identity);"
,s "create table t (a int generated by default as identity);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
(Just $ IdentityColumnSpec GeneratedByDefault []) []])
(Just $ IdentityColumnSpec GeneratedByDefault []) []]
,(TestStatement ansi2011
,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"]
@ -499,9 +501,9 @@ options
,SGOIncrementBy 5
,SGOMaxValue 500
,SGOMinValue 5
,SGOCycle]) []])
,SGOCycle]) []]
,(TestStatement ansi2011
,s
"create table t (a int generated always as identity\n\
\ ( start with -4 no maxvalue no minvalue no cycle ));"
$ CreateTable [Name Nothing "t"]
@ -510,7 +512,7 @@ options
[SGOStartWith (-4)
,SGONoMaxValue
,SGONoMinValue
,SGONoCycle]) []])
,SGONoCycle]) []]
{-
I think <common sequence generator options> is supposed to just
@ -531,14 +533,14 @@ generated always (valueexpr)
<left paren> <value expression> <right paren>
-}
,(TestStatement ansi2011
,s
"create table t (a int, \n\
\ a2 int generated always as (a * 2));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableColumnDef $ ColumnDef (Name Nothing "a2") (TypeName [Name Nothing "int"])
(Just $ GenerationClause
(BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (NumLit "2"))) []])
(BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (NumLit "2"))) []]
@ -563,10 +565,10 @@ generated always (valueexpr)
-}
,(TestStatement ansi2011 "create table t (a int default 0);"
,s "create table t (a int default 0);"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"])
(Just $ DefaultClause $ NumLit "0") []])
(Just $ DefaultClause $ NumLit "0") []]
@ -597,40 +599,40 @@ generated always (valueexpr)
<column name list>
-}
,(TestStatement ansi2011
,s
"create table t (a int, unique (a));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableConstraintDef Nothing $ TableUniqueConstraint [Name Nothing "a"]
])
]
,(TestStatement ansi2011
,s
"create table t (a int, constraint a_unique unique (a));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableConstraintDef (Just [Name Nothing "a_unique"]) $
TableUniqueConstraint [Name Nothing "a"]
])
]
-- todo: test permutations of column defs and table constraints
,(TestStatement ansi2011
,s
"create table t (a int, b int, unique (a,b));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []
,TableConstraintDef Nothing $
TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
])
]
,(TestStatement ansi2011
,s
"create table t (a int, b int, primary key (a,b));"
$ CreateTable [Name Nothing "t"]
[TableColumnDef $ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
,TableColumnDef $ ColumnDef (Name Nothing "b") (TypeName [Name Nothing "int"]) Nothing []
,TableConstraintDef Nothing $
TablePrimaryKeyConstraint [Name Nothing "a", Name Nothing "b"]
])
]
{-
@ -649,7 +651,7 @@ defintely skip
-}
,(TestStatement ansi2011
,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"]
@ -661,9 +663,9 @@ defintely skip
[Name Nothing "u"]
(Just [Name Nothing "c", Name Nothing "d"])
MatchFull RefCascade RefRestrict
])
]
,(TestStatement ansi2011
,s
"create table t (a int,\n\
\ constraint tfku1 foreign key (a) references u);"
$ CreateTable [Name Nothing "t"]
@ -674,9 +676,9 @@ defintely skip
[Name Nothing "u"]
Nothing DefaultReferenceMatch
DefaultReferentialAction DefaultReferentialAction
])
]
,(TestStatement ansi2011 { diNonCommaSeparatedConstraints = True }
,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));"
@ -697,7 +699,7 @@ defintely skip
(Just [Name Nothing "d"])
DefaultReferenceMatch
DefaultReferentialAction DefaultReferentialAction
])
]
{-
@ -755,7 +757,7 @@ defintely skip
CHECK <left paren> <search condition> <right paren>
-}
,(TestStatement ansi2011
,s
"create table t (a int, b int, \n\
\ check (a > b));"
$ CreateTable [Name Nothing "t"]
@ -764,10 +766,10 @@ defintely skip
,TableConstraintDef Nothing $
TableCheckConstraint
(BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"]))
])
]
,(TestStatement ansi2011
,s
"create table t (a int, b int, \n\
\ constraint agtb check (a > b));"
$ CreateTable [Name Nothing "t"]
@ -776,7 +778,7 @@ defintely skip
,TableConstraintDef (Just [Name Nothing "agtb"]) $
TableCheckConstraint
(BinOp (Iden [Name Nothing "a"]) [Name Nothing ">"] (Iden [Name Nothing "b"]))
])
]
{-
@ -810,11 +812,10 @@ alter table t add a int
alter table t add a int unique not null check (a>0)
-}
,(TestStatement ansi2011
,s
"alter table t add column a int"
$ AlterTable [Name Nothing "t"] $ AddColumnDef
$ ColumnDef (Name Nothing "a") (TypeName [Name Nothing "int"]) Nothing []
)
{-
todo: more add column
@ -844,10 +845,10 @@ todo: more add column
-}
,(TestStatement ansi2011
,s
"alter table t alter column c set default 0"
$ AlterTable [Name Nothing "t"] $ AlterColumnSetDefault (Name Nothing "c")
$ NumLit "0")
$ NumLit "0"
{-
11.14 <drop column default clause>
@ -856,9 +857,9 @@ todo: more add column
DROP DEFAULT
-}
,(TestStatement ansi2011
,s
"alter table t alter column c drop default"
$ AlterTable [Name Nothing "t"] $ AlterColumnDropDefault (Name Nothing "c"))
$ AlterTable [Name Nothing "t"] $ AlterColumnDropDefault (Name Nothing "c")
{-
@ -868,9 +869,9 @@ todo: more add column
SET NOT NULL
-}
,(TestStatement ansi2011
,s
"alter table t alter column c set not null"
$ AlterTable [Name Nothing "t"] $ AlterColumnSetNotNull (Name Nothing "c"))
$ AlterTable [Name Nothing "t"] $ AlterColumnSetNotNull (Name Nothing "c")
{-
11.16 <drop column not null clause>
@ -879,9 +880,9 @@ todo: more add column
DROP NOT NULL
-}
,(TestStatement ansi2011
,s
"alter table t alter column c drop not null"
$ AlterTable [Name Nothing "t"] $ AlterColumnDropNotNull (Name Nothing "c"))
$ AlterTable [Name Nothing "t"] $ AlterColumnDropNotNull (Name Nothing "c")
{-
11.17 <add column scope clause>
@ -900,10 +901,10 @@ todo: more add column
SET DATA TYPE <data type>
-}
,(TestStatement ansi2011
,s
"alter table t alter column c set data type int;"
$ AlterTable [Name Nothing "t"] $
AlterColumnSetDataType (Name Nothing "c") (TypeName [Name Nothing "int"]))
AlterColumnSetDataType (Name Nothing "c") (TypeName [Name Nothing "int"])
@ -1001,20 +1002,20 @@ included in the generated plan above
DROP [ COLUMN ] <column name> <drop behavior>
-}
,(TestStatement ansi2011
,s
"alter table t drop column c"
$ AlterTable [Name Nothing "t"] $
DropColumn (Name Nothing "c") DefaultDropBehaviour)
DropColumn (Name Nothing "c") DefaultDropBehaviour
,(TestStatement ansi2011
,s
"alter table t drop c cascade"
$ AlterTable [Name Nothing "t"] $
DropColumn (Name Nothing "c") Cascade)
DropColumn (Name Nothing "c") Cascade
,(TestStatement ansi2011
,s
"alter table t drop c restrict"
$ AlterTable [Name Nothing "t"] $
DropColumn (Name Nothing "c") Restrict)
DropColumn (Name Nothing "c") Restrict
@ -1025,17 +1026,17 @@ included in the generated plan above
ADD <table constraint definition>
-}
,(TestStatement ansi2011
,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"])
$ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
,(TestStatement ansi2011
,s
"alter table t add unique (a,b)"
$ AlterTable [Name Nothing "t"] $
AddTableConstraintDef Nothing
$ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"])
$ TableUniqueConstraint [Name Nothing "a", Name Nothing "b"]
{-
@ -1051,15 +1052,15 @@ todo
DROP CONSTRAINT <constraint name> <drop behavior>
-}
,(TestStatement ansi2011
,s
"alter table t drop constraint c"
$ AlterTable [Name Nothing "t"] $
DropTableConstraintDef [Name Nothing "c"] DefaultDropBehaviour)
DropTableConstraintDef [Name Nothing "c"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"alter table t drop constraint c restrict"
$ AlterTable [Name Nothing "t"] $
DropTableConstraintDef [Name Nothing "c"] Restrict)
DropTableConstraintDef [Name Nothing "c"] Restrict
{-
11.27 <add table period definition>
@ -1111,13 +1112,13 @@ defintely skip
DROP TABLE <table name> <drop behavior>
-}
,(TestStatement ansi2011
,s
"drop table t"
$ DropTable [Name Nothing "t"] DefaultDropBehaviour)
$ DropTable [Name Nothing "t"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"drop table t restrict"
$ DropTable [Name Nothing "t"] Restrict)
$ DropTable [Name Nothing "t"] Restrict
{-
@ -1159,51 +1160,51 @@ defintely skip
<column name list>
-}
,(TestStatement ansi2011
,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)
}) Nothing
,(TestStatement ansi2011
,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)
}) Nothing
,(TestStatement ansi2011
,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)
}) Nothing
,(TestStatement ansi2011
,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))
}) (Just DefaultCheckOption)
,(TestStatement ansi2011
,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))
}) (Just CascadedCheckOption)
,(TestStatement ansi2011
,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))
}) (Just LocalCheckOption)
{-
@ -1214,13 +1215,13 @@ defintely skip
-}
,(TestStatement ansi2011
,s
"drop view v"
$ DropView [Name Nothing "v"] DefaultDropBehaviour)
$ DropView [Name Nothing "v"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"drop view v cascade"
$ DropView [Name Nothing "v"] Cascade)
$ DropView [Name Nothing "v"] Cascade
{-
@ -1237,37 +1238,37 @@ defintely skip
<constraint characteristics> ]
-}
,(TestStatement ansi2011
,s
"create domain my_int int"
$ CreateDomain [Name Nothing "my_int"]
(TypeName [Name Nothing "int"])
Nothing [])
Nothing []
,(TestStatement ansi2011
,s
"create domain my_int as int"
$ CreateDomain [Name Nothing "my_int"]
(TypeName [Name Nothing "int"])
Nothing [])
Nothing []
,(TestStatement ansi2011
,s
"create domain my_int int default 0"
$ CreateDomain [Name Nothing "my_int"]
(TypeName [Name Nothing "int"])
(Just (NumLit "0")) [])
(Just (NumLit "0")) []
,(TestStatement ansi2011
,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"))])
,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))]
,(TestStatement ansi2011
,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"))])
,BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "5"))]
@ -1289,10 +1290,10 @@ defintely skip
SET <default clause>
-}
,(TestStatement ansi2011
,s
"alter domain my_int set default 0"
$ AlterDomain [Name Nothing "my_int"]
$ ADSetDefault $ NumLit "0")
$ ADSetDefault $ NumLit "0"
{-
@ -1302,10 +1303,10 @@ defintely skip
DROP DEFAULT
-}
,(TestStatement ansi2011
,s
"alter domain my_int drop default"
$ AlterDomain [Name Nothing "my_int"]
$ ADDropDefault)
$ ADDropDefault
{-
@ -1315,17 +1316,17 @@ defintely skip
ADD <domain constraint>
-}
,(TestStatement ansi2011
,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"))
$ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6")
,(TestStatement ansi2011
,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"))
$ BinOp (Iden [Name Nothing "value"]) [Name Nothing ">"] (NumLit "6")
{-
@ -1335,10 +1336,10 @@ defintely skip
DROP CONSTRAINT <constraint name>
-}
,(TestStatement ansi2011
,s
"alter domain my_int drop constraint gt6"
$ AlterDomain [Name Nothing "my_int"]
$ ADDropConstraint [Name Nothing "gt6"])
$ ADDropConstraint [Name Nothing "gt6"]
{-
11.40 <drop domain statement>
@ -1347,13 +1348,13 @@ defintely skip
DROP DOMAIN <domain name> <drop behavior>
-}
,(TestStatement ansi2011
,s
"drop domain my_int"
$ DropDomain [Name Nothing "my_int"] DefaultDropBehaviour)
$ DropDomain [Name Nothing "my_int"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"drop domain my_int cascade"
$ DropDomain [Name Nothing "my_int"] Cascade)
$ DropDomain [Name Nothing "my_int"] Cascade
@ -1425,7 +1426,7 @@ defintely skip
[ <constraint characteristics> ]
-}
,(TestStatement ansi2011
,s
"create assertion t1_not_empty CHECK ((select count(*) from t1) > 0);"
$ CreateAssertion [Name Nothing "t1_not_empty"]
$ BinOp (SubQueryExpr SqSq $
@ -1433,7 +1434,7 @@ defintely skip
{msSelectList = [(App [Name Nothing "count"] [Star],Nothing)]
,msFrom = [TRSimple [Name Nothing "t1"]]
})
[Name Nothing ">"] (NumLit "0"))
[Name Nothing ">"] (NumLit "0")
{-
11.48 <drop assertion statement>
@ -1442,13 +1443,13 @@ defintely skip
DROP ASSERTION <constraint name> [ <drop behavior> ]
-}
,(TestStatement ansi2011
,s
"drop assertion t1_not_empty;"
$ DropAssertion [Name Nothing "t1_not_empty"] DefaultDropBehaviour)
$ DropAssertion [Name Nothing "t1_not_empty"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"drop assertion t1_not_empty cascade;"
$ DropAssertion [Name Nothing "t1_not_empty"] Cascade)
$ DropAssertion [Name Nothing "t1_not_empty"] Cascade
{-
@ -2085,21 +2086,21 @@ defintely skip
| NO CYCLE
-}
,(TestStatement ansi2011
,s
"create sequence seq"
$ CreateSequence [Name Nothing "seq"] [])
$ CreateSequence [Name Nothing "seq"] []
,(TestStatement ansi2011
,s
"create sequence seq as bigint"
$ CreateSequence [Name Nothing "seq"]
[SGODataType $ TypeName [Name Nothing "bigint"]])
[SGODataType $ TypeName [Name Nothing "bigint"]]
,(TestStatement ansi2011
,s
"create sequence seq as bigint start with 5"
$ CreateSequence [Name Nothing "seq"]
[SGOStartWith 5
,SGODataType $ TypeName [Name Nothing "bigint"]
])
]
{-
@ -2122,21 +2123,21 @@ defintely skip
<signed numeric literal>
-}
,(TestStatement ansi2011
,s
"alter sequence seq restart"
$ AlterSequence [Name Nothing "seq"]
[SGORestart Nothing])
[SGORestart Nothing]
,(TestStatement ansi2011
,s
"alter sequence seq restart with 5"
$ AlterSequence [Name Nothing "seq"]
[SGORestart $ Just 5])
[SGORestart $ Just 5]
,(TestStatement ansi2011
,s
"alter sequence seq restart with 5 increment by 5"
$ AlterSequence [Name Nothing "seq"]
[SGORestart $ Just 5
,SGOIncrementBy 5])
,SGOIncrementBy 5]
{-
@ -2146,13 +2147,16 @@ defintely skip
DROP SEQUENCE <sequence generator name> <drop behavior>
-}
,(TestStatement ansi2011
,s
"drop sequence seq"
$ DropSequence [Name Nothing "seq"] DefaultDropBehaviour)
$ DropSequence [Name Nothing "seq"] DefaultDropBehaviour
,(TestStatement ansi2011
,s
"drop sequence seq restrict"
$ DropSequence [Name Nothing "seq"] Restrict)
$ DropSequence [Name Nothing "seq"] Restrict
]
s :: HasCallStack => Text -> Statement -> TestItem
s src ast = testStatement ansi2011 src ast

462
tests/Language/SQL/SimpleSQL/ScalarExprs.hs
View file

@ -6,6 +6,9 @@ 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"
@ -25,101 +28,108 @@ scalarExprTests = Group "scalarExprTests"
,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" $ map (uncurry (TestScalarExpr ansi2011))
[("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 Nothing "interval"]) "3 weeks")
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" $ map (uncurry (TestScalarExpr ansi2011))
[("iden1", Iden [Name Nothing "iden1"])
identifiers = Group "identifiers"
[t "iden1" $ Iden [Name Nothing "iden1"]
--,("t.a", Iden2 "t" "a")
,("\"quoted identifier\"", Iden [Name (Just ("\"","\"")) "quoted identifier"])
,("\"from\"", Iden [Name (Just ("\"","\"")) "from"])
,t "\"quoted identifier\"" $ Iden [Name (Just ("\"","\"")) "quoted identifier"]
,t "\"from\"" $ Iden [Name (Just ("\"","\"")) "from"]
]
star :: TestItem
star = Group "star" $ map (uncurry (TestScalarExpr ansi2011))
[("*", Star)
star = Group "star"
[t "*" Star
--,("t.*", Star2 "t")
--,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"])
]
parameter :: TestItem
parameter = Group "parameter"
[TestScalarExpr ansi2011 "?" Parameter
,TestScalarExpr postgres "$13" $ PositionalArg 13]
[td ansi2011 "?" Parameter
,td postgres "$13" $ PositionalArg 13]
dots :: TestItem
dots = Group "dot" $ map (uncurry (TestScalarExpr ansi2011))
[("t.a", Iden [Name Nothing "t",Name Nothing "a"])
,("t.*", BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star)
,("a.b.c", Iden [Name Nothing "a",Name Nothing "b",Name Nothing "c"])
,("ROW(t.*,42)", App [Name Nothing "ROW"] [BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star, NumLit "42"])
dots = Group "dot"
[t "t.a" $ Iden [Name Nothing "t",Name Nothing "a"]
,t "t.*" $ BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star
,t "a.b.c" $ Iden [Name Nothing "a",Name Nothing "b",Name Nothing "c"]
,t "ROW(t.*,42)"
$ App [Name Nothing "ROW"] [BinOp (Iden [Name Nothing "t"]) [Name Nothing "."] Star, NumLit "42"]
]
app :: TestItem
app = Group "app" $ map (uncurry (TestScalarExpr ansi2011))
[("f()", App [Name Nothing "f"] [])
,("f(a)", App [Name Nothing "f"] [Iden [Name Nothing "a"]])
,("f(a,b)", App [Name Nothing "f"] [Iden [Name Nothing "a"], Iden [Name Nothing "b"]])
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" $ map (uncurry (TestScalarExpr ansi2011))
[("case a when 1 then 2 end"
,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"]
,NumLit "2")] Nothing)
caseexp = Group "caseexp"
[t "case a when 1 then 2 end"
$ Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1"]
,NumLit "2")] Nothing
,("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 end"
$ Case (Just $ Iden [Name Nothing "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 Nothing "a"]) [([NumLit "1"], NumLit "2")
,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"))
(Just $ NumLit "5")
,("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")
,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"))
(Just $ NumLit "5")
,("case a when 1,2 then 10 when 3,4 then 20 end"
,Case (Just $ Iden [Name Nothing "a"]) [([NumLit "1",NumLit "2"]
,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)
Nothing
]
convertfun :: TestItem
convertfun = Group "convert" $ map (uncurry (TestScalarExpr sqlserver))
[("CONVERT(varchar, 25.65)"
,Convert (TypeName [Name Nothing "varchar"]) (NumLit "25.65") Nothing)
,("CONVERT(datetime, '2017-08-25')"
,Convert (TypeName [Name Nothing "datetime"]) (StringLit "'" "'" "2017-08-25") Nothing)
,("CONVERT(varchar, '2017-08-25', 101)"
,Convert (TypeName [Name Nothing "varchar"]) (StringLit "'" "'" "2017-08-25") (Just 101))
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
@ -130,70 +140,69 @@ operators = Group "operators"
,miscOps]
binaryOperators :: TestItem
binaryOperators = Group "binaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
[("a + b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"]))
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
,("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 (Iden [Name Nothing "a"]) [Name Nothing "+"]
(BinOp (Iden [Name Nothing "b"]) [Name Nothing "*"] (Iden [Name Nothing "c"]))
,("a * b + c"
,BinOp (BinOp (Iden [Name Nothing "a"]) [Name Nothing "*"] (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" $ map (uncurry (TestScalarExpr ansi2011))
[("not a", PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"])
,("not not a", PrefixOp [Name Nothing "not"] $ PrefixOp [Name Nothing "not"] $ Iden [Name Nothing "a"])
,("+a", PrefixOp [Name Nothing "+"] $ Iden [Name Nothing "a"])
,("-a", PrefixOp [Name Nothing "-"] $ Iden [Name Nothing "a"])
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" $ map (uncurry (TestScalarExpr ansi2011))
[("cast('1' as int)"
,Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "int"])
casts = Group "operators"
[t "cast('1' as int)"
$ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "int"]
,("int '3'"
,TypedLit (TypeName [Name Nothing "int"]) "3")
,t "int '3'"
$ TypedLit (TypeName [Name Nothing "int"]) "3"
,("cast('1' as double precision)"
,Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "double precision"])
,t "cast('1' as double precision)"
$ Cast (StringLit "'" "'" "1") $ TypeName [Name Nothing "double precision"]
,("cast('1' as float(8))"
,Cast (StringLit "'" "'" "1") $ PrecTypeName [Name Nothing "float"] 8)
,t "cast('1' as float(8))"
$ Cast (StringLit "'" "'" "1") $ PrecTypeName [Name Nothing "float"] 8
,("cast('1' as decimal(15,2))"
,Cast (StringLit "'" "'" "1") $ PrecScaleTypeName [Name Nothing "decimal"] 15 2)
,t "cast('1' as decimal(15,2))"
$ Cast (StringLit "'" "'" "1") $ PrecScaleTypeName [Name Nothing "decimal"] 15 2
,("double precision '3'"
,TypedLit (TypeName [Name Nothing "double precision"]) "3")
,t "double precision '3'"
$ TypedLit (TypeName [Name Nothing "double precision"]) "3"
]
subqueries :: TestItem
subqueries = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
[("exists (select a from t)", SubQueryExpr SqExists ms)
,("(select a from t)", SubQueryExpr SqSq ms)
subqueries = Group "unaryOperators"
[t "exists (select a from t)" $ SubQueryExpr SqExists ms
,t "(select a from t)" $ SubQueryExpr SqSq ms
,("a in (select a from t)"
,In True (Iden [Name Nothing "a"]) (InQueryExpr ms))
,t "a in (select a from t)"
$ In True (Iden [Name Nothing "a"]) (InQueryExpr ms)
,("a not in (select a from t)"
,In False (Iden [Name Nothing "a"]) (InQueryExpr ms))
,t "a not in (select a from t)"
$ In False (Iden [Name Nothing "a"]) (InQueryExpr ms)
,("a > all (select a from t)"
,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms)
,t "a > all (select a from t)"
$ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing ">"] CPAll ms
,("a = some (select a from t)"
,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPSome ms)
,t "a = some (select a from t)"
$ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "="] CPSome ms
,("a <= any (select a from t)"
,QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPAny ms)
,t "a <= any (select a from t)"
$ QuantifiedComparison (Iden [Name Nothing "a"]) [Name Nothing "<="] CPAny ms
]
where
ms = toQueryExpr $ makeSelect
@ -202,94 +211,93 @@ subqueries = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
}
miscOps :: TestItem
miscOps = Group "unaryOperators" $ map (uncurry (TestScalarExpr ansi2011))
[("a in (1,2,3)"
,In True (Iden [Name Nothing "a"]) $ InList $ map NumLit ["1","2","3"])
miscOps = Group "unaryOperators"
[t "a in (1,2,3)"
$ In True (Iden [Name Nothing "a"]) $ InList $ map NumLit ["1","2","3"]
,("a is null", PostfixOp [Name Nothing "is null"] (Iden [Name Nothing "a"]))
,("a is not null", PostfixOp [Name Nothing "is not null"] (Iden [Name Nothing "a"]))
,("a is true", PostfixOp [Name Nothing "is true"] (Iden [Name Nothing "a"]))
,("a is not true", PostfixOp [Name Nothing "is not true"] (Iden [Name Nothing "a"]))
,("a is false", PostfixOp [Name Nothing "is false"] (Iden [Name Nothing "a"]))
,("a is not false", PostfixOp [Name Nothing "is not false"] (Iden [Name Nothing "a"]))
,("a is unknown", PostfixOp [Name Nothing "is unknown"] (Iden [Name Nothing "a"]))
,("a is not unknown", PostfixOp [Name Nothing "is not unknown"] (Iden [Name Nothing "a"]))
,("a is distinct from b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "is distinct from"] (Iden [Name Nothing "b"]))
,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"])
,("a is not distinct from b"
,BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not 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"])
,("a like b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "like"] (Iden [Name Nothing "b"]))
,("a not like b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "not like"] (Iden [Name Nothing "b"]))
,("a is similar to b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "is similar to"] (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"])
,("a is not similar to b"
,BinOp (Iden [Name Nothing "a"]) [Name Nothing "is not similar to"] (Iden [Name Nothing "b"]))
,("a overlaps b", BinOp (Iden [Name Nothing "a"]) [Name Nothing "overlaps"] (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
,("a between b and c", SpecialOp [Name Nothing "between"] [Iden [Name Nothing "a"]
,t "a between b and c" $ SpecialOp [Name Nothing "between"] [Iden [Name Nothing "a"]
,Iden [Name Nothing "b"]
,Iden [Name Nothing "c"]])
,Iden [Name Nothing "c"]]
,("a not between b and c", SpecialOp [Name Nothing "not between"] [Iden [Name Nothing "a"]
,t "a not between b and c" $ SpecialOp [Name Nothing "not between"] [Iden [Name Nothing "a"]
,Iden [Name Nothing "b"]
,Iden [Name Nothing "c"]])
,("(1,2)"
,SpecialOp [Name Nothing "rowctor"] [NumLit "1", NumLit "2"])
,Iden [Name Nothing "c"]]
,t "(1,2)"
$ SpecialOp [Name Nothing "rowctor"] [NumLit "1", NumLit "2"]
-- keyword special operators
,("extract(day from t)"
, SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "t"])])
,t "extract(day from t)"
$ SpecialOpK [Name Nothing "extract"] (Just $ Iden [Name Nothing "day"]) [("from", Iden [Name Nothing "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 for 2)"
$ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")
,("for", NumLit "2")]
,("substring(x from 1)"
,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")])
,t "substring(x from 1)"
$ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("from", NumLit "1")]
,("substring(x for 2)"
,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("for", NumLit "2")])
,t "substring(x for 2)"
$ SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"]) [("for", NumLit "2")]
,("substring(x from 1 for 2 collate C)"
,SpecialOpK [Name Nothing "substring"] (Just $ Iden [Name Nothing "x"])
,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"])])
,("for", Collate (NumLit "2") [Name Nothing "C"])]
-- this doesn't work because of a overlap in the 'in' parser
,("POSITION( string1 IN string2 )"
,SpecialOpK [Name Nothing "position"] (Just $ Iden [Name Nothing "string1"]) [("in", Iden [Name Nothing "string2"])])
,t "POSITION( string1 IN string2 )"
$ SpecialOpK [Name Nothing "position"] (Just $ Iden [Name Nothing "string1"]) [("in", Iden [Name Nothing "string2"])]
,("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 "CONVERT(char_value USING conversion_char_name)"
$ SpecialOpK [Name Nothing "convert"] (Just $ Iden [Name Nothing "char_value"])
[("using", Iden [Name Nothing "conversion_char_name"])]
,("TRANSLATE(char_value USING translation_name)"
,SpecialOpK [Name Nothing "translate"] (Just $ Iden [Name Nothing "char_value"])
[("using", Iden [Name Nothing "translation_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])
-}
,("OVERLAY(string PLACING embedded_string FROM start)"
,SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
,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"])])
,("from", Iden [Name Nothing "start"])]
,("OVERLAY(string PLACING embedded_string FROM start FOR length)"
,SpecialOpK [Name Nothing "overlay"] (Just $ Iden [Name Nothing "string"])
,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"])])
,("for", Iden [Name Nothing "length"])]
{-
TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ]
@ -299,135 +307,133 @@ target_string
,("trim(from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("both", StringLit "'" "'" " ")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(leading from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(leading from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("leading", StringLit "'" "'" " ")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(trailing from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(trailing from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("trailing", StringLit "'" "'" " ")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(both from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(both from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("both", StringLit "'" "'" " ")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(leading 'x' from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(leading 'x' from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("leading", StringLit "'" "'" "x")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(trailing 'y' from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(trailing 'y' from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("trailing", StringLit "'" "'" "y")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
,("trim(both 'z' from target_string collate C)"
,SpecialOpK [Name Nothing "trim"] Nothing
,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"])])
,("from", Collate (Iden [Name Nothing "target_string"]) [Name Nothing "C"])]
,("trim(leading from target_string)"
,SpecialOpK [Name Nothing "trim"] Nothing
,t "trim(leading from target_string)"
$ SpecialOpK [Name Nothing "trim"] Nothing
[("leading", StringLit "'" "'" " ")
,("from", Iden [Name Nothing "target_string"])])
,("from", Iden [Name Nothing "target_string"])]
]
aggregates :: TestItem
aggregates = Group "aggregates" $ map (uncurry (TestScalarExpr ansi2011))
[("count(*)",App [Name Nothing "count"] [Star])
aggregates = Group "aggregates"
[t "count(*)" $ App [Name Nothing "count"] [Star]
,("sum(a order by a)"
,AggregateApp [Name Nothing "sum"] SQDefault [Iden [Name Nothing "a"]]
[SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] Nothing)
,t "sum(a order by a)"
$ AggregateApp [Name Nothing "sum"] SQDefault [Iden [Name Nothing "a"]]
[SortSpec (Iden [Name Nothing "a"]) DirDefault NullsOrderDefault] Nothing
,("sum(all a)"
,AggregateApp [Name Nothing "sum"] All [Iden [Name Nothing "a"]] [] Nothing)
,t "sum(all a)"
$ AggregateApp [Name Nothing "sum"] All [Iden [Name Nothing "a"]] [] Nothing
,("count(distinct a)"
,AggregateApp [Name Nothing "count"] Distinct [Iden [Name Nothing "a"]] [] Nothing)
,t "count(distinct a)"
$ AggregateApp [Name Nothing "count"] Distinct [Iden [Name Nothing "a"]] [] Nothing
]
windowFunctions :: TestItem
windowFunctions = Group "windowFunctions" $ map (uncurry (TestScalarExpr ansi2011))
[("max(a) over ()", WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [] [] Nothing)
,("count(*) over ()", WindowApp [Name Nothing "count"] [Star] [] [] Nothing)
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
,("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)"
$ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]] [] Nothing
,("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 "max(a) over (partition by b,c)"
$ WindowApp [Name Nothing "max"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"],Iden [Name Nothing "c"]] [] Nothing
,("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)"
$ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
[SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault] Nothing
,("sum(a) over (order by b desc,c)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] []
,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)
,SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing
,("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)"
$ WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
[SortSpec (Iden [Name Nothing "c"]) DirDefault NullsOrderDefault] Nothing
,("sum(a) over (partition by b order by c range unbounded preceding)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
,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)
$ Just $ FrameFrom FrameRange UnboundedPreceding
,("sum(a) over (partition by b order by c range 5 preceding)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
,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"))
$ Just $ FrameFrom FrameRange $ Preceding (NumLit "5")
,("sum(a) over (partition by b order by c range current row)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
,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)
$ Just $ FrameFrom FrameRange Current
,("sum(a) over (partition by b order by c rows 5 following)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
,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"))
$ Just $ FrameFrom FrameRows $ Following (NumLit "5")
,("sum(a) over (partition by b order by c range unbounded following)"
,WindowApp [Name Nothing "sum"] [Iden [Name Nothing "a"]] [Iden [Name Nothing "b"]]
,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)
$ Just $ FrameFrom FrameRange UnboundedFollowing
,("sum(a) over (partition by b order by c \n\
,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"]]
$ 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")))
(Following (NumLit "5"))
]
parens :: TestItem
parens = Group "parens" $ map (uncurry (TestScalarExpr ansi2011))
[("(a)", Parens (Iden [Name Nothing "a"]))
,("(a + b)", Parens (BinOp (Iden [Name Nothing "a"]) [Name Nothing "+"] (Iden [Name Nothing "b"])))
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 t
functionsWithReservedNames = Group "functionsWithReservedNames" $ map f
["abs"
,"char_length"
]
where
t fn = TestScalarExpr ansi2011 (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]
f fn = t (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]

123
tests/Language/SQL/SimpleSQL/TableRefs.hs
View file

@ -9,100 +9,103 @@ 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" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t"
,ms [TRSimple [Name Nothing "t"]])
tableRefTests = Group "tableRefTests"
[q "select a from t"
$ ms [TRSimple [Name Nothing "t"]]
,("select a from f(a)"
,ms [TRFunction [Name Nothing "f"] [Iden [Name Nothing "a"]]])
,q "select a from f(a)"
$ ms [TRFunction [Name Nothing "f"] [Iden [Name Nothing "a"]]]
,("select a from t,u"
,ms [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]])
,q "select a from t,u"
$ ms [TRSimple [Name Nothing "t"], TRSimple [Name Nothing "u"]]
,("select a from s.t"
,ms [TRSimple [Name Nothing "s", Name Nothing "t"]])
,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
,("select a from lateral a"
,ms [TRLateral $ TRSimple [Name Nothing "a"]])
,q "select a from lateral a"
$ ms [TRLateral $ TRSimple [Name Nothing "a"]]
,("select a from lateral a,b"
,ms [TRLateral $ TRSimple [Name Nothing "a"], TRSimple [Name Nothing "b"]])
,q "select a from lateral a,b"
$ ms [TRLateral $ TRSimple [Name Nothing "a"], TRSimple [Name Nothing "b"]]
,("select a from a, lateral b"
,ms [TRSimple [Name Nothing "a"], TRLateral $ TRSimple [Name Nothing "b"]])
,q "select a from a, lateral b"
$ ms [TRSimple [Name Nothing "a"], TRLateral $ TRSimple [Name Nothing "b"]]
,("select a from a natural join lateral b"
,ms [TRJoin (TRSimple [Name Nothing "a"]) True JInner
,q "select a from a natural join lateral b"
$ ms [TRJoin (TRSimple [Name Nothing "a"]) True JInner
(TRLateral $ TRSimple [Name Nothing "b"])
Nothing])
Nothing]
,("select a from lateral a natural join lateral b"
,ms [TRJoin (TRLateral $ TRSimple [Name Nothing "a"]) True JInner
,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])
Nothing]
,("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 inner join u on expr"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
(Just $ JoinOn $ Iden [Name Nothing "expr"])]
,("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 join u on expr"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False JInner (TRSimple [Name Nothing "u"])
(Just $ JoinOn $ Iden [Name Nothing "expr"])]
,("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 left join u on expr"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False JLeft (TRSimple [Name Nothing "u"])
(Just $ JoinOn $ Iden [Name Nothing "expr"])]
,("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 right join u on expr"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False JRight (TRSimple [Name Nothing "u"])
(Just $ JoinOn $ Iden [Name Nothing "expr"])]
,("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 full join u on expr"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False JFull (TRSimple [Name Nothing "u"])
(Just $ JoinOn $ Iden [Name Nothing "expr"])]
,("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 cross join u"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) False
JCross (TRSimple [Name Nothing "u"]) Nothing]
,("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 natural inner join u"
$ ms [TRJoin (TRSimple [Name Nothing "t"]) True JInner (TRSimple [Name Nothing "u"])
Nothing]
,("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 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"])]
,("select a from (select a from t)"
,ms [TRQueryExpr $ ms [TRSimple [Name Nothing "t"]]])
,q "select a from (select a from t)"
$ ms [TRQueryExpr $ ms [TRSimple [Name Nothing "t"]]]
,("select a from t as u"
,ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)])
,q "select a from t as u"
$ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") Nothing)]
,("select a from t 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)]
,("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 u(b)"
$ ms [TRAlias (TRSimple [Name Nothing "t"]) (Alias (Name Nothing "u") $ Just [Name Nothing "b"])]
,("select a from (t cross join u) as u"
,ms [TRAlias (TRParens $
,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)])
(Alias (Name Nothing "u") Nothing)]
-- todo: not sure if the associativity is correct
,("select a from t cross join u cross join v",
ms [TRJoin
,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])
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

92
tests/Language/SQL/SimpleSQL/TestRunners.hs Normal file
View file

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

30
tests/Language/SQL/SimpleSQL/TestTypes.hs
View file

@ -13,6 +13,9 @@ import Language.SQL.SimpleSQL.Syntax
import Language.SQL.SimpleSQL.Lex (Token)
import Language.SQL.SimpleSQL.Dialect
import Test.Hspec (SpecWith)
import Data.Text (Text)
{-
@ -20,13 +23,19 @@ 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
| TestQueryExpr Dialect Text QueryExpr
| TestStatement Dialect Text Statement
| TestStatements Dialect Text [Statement]
| 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
@ -34,12 +43,13 @@ 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
| ParseQueryExpr Dialect Text (SpecWith ())
-- check that the string given fails to parse
| ParseQueryExprFails Dialect Text
| ParseScalarExprFails Dialect Text
| LexTest Dialect Text [Token]
| LexFails Dialect Text
deriving (Eq,Show)
| ParseQueryExprFails Dialect Text (SpecWith ())
| ParseScalarExprFails Dialect Text (SpecWith ())
| LexTest Dialect Text [Token] (SpecWith ())
| LexFails Dialect Text (SpecWith ())
| GeneralParseFailTest Text Text (SpecWith ())

127
tests/Language/SQL/SimpleSQL/Tests.hs
View file

@ -12,13 +12,11 @@ module Language.SQL.SimpleSQL.Tests
,TestItem(..)
) where
import qualified Test.Tasty as T
import qualified Test.Tasty.HUnit as H
--import Language.SQL.SimpleSQL.Syntax
import Language.SQL.SimpleSQL.Pretty
import Language.SQL.SimpleSQL.Parse
import qualified Language.SQL.SimpleSQL.Lex as Lex
import Test.Hspec
(SpecWith
,describe
,parallel
)
import Language.SQL.SimpleSQL.TestTypes
@ -44,11 +42,10 @@ 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 Data.Text (Text)
import qualified Data.Text as T
{-
Order the tests to start from the simplest first. This is also the
order on the generated documentation.
@ -77,104 +74,22 @@ testData =
,customDialectTests
,emptyStatementTests
,createIndexTests
,errorMessageTests
]
tests :: T.TestTree
tests = itemToTest testData
tests :: SpecWith ()
tests = parallel $ itemToTest testData
--runTests :: IO ()
--runTests = void $ H.runTestTT $ itemToTest testData
itemToTest :: TestItem -> T.TestTree
itemToTest :: TestItem -> SpecWith ()
itemToTest (Group nm ts) =
T.testGroup (T.unpack nm) $ map itemToTest ts
itemToTest (TestScalarExpr d str expected) =
toTest parseScalarExpr prettyScalarExpr d str expected
itemToTest (TestQueryExpr d str expected) =
toTest parseQueryExpr prettyQueryExpr d str expected
itemToTest (TestStatement d str expected) =
toTest parseStatement prettyStatement d str expected
itemToTest (TestStatements d str expected) =
toTest parseStatements prettyStatements d str expected
itemToTest (ParseQueryExpr d str) =
toPTest parseQueryExpr prettyQueryExpr d str
itemToTest (ParseQueryExprFails d str) =
toFTest parseQueryExpr prettyQueryExpr d str
itemToTest (ParseScalarExprFails d str) =
toFTest parseScalarExpr prettyScalarExpr d str
itemToTest (LexTest d s ts) = makeLexerTest d s ts
itemToTest (LexFails d s) = makeLexingFailsTest d s
makeLexerTest :: Dialect -> Text -> [Lex.Token] -> T.TestTree
makeLexerTest d s ts = H.testCase (T.unpack s) $ do
let ts1 = either (error . T.unpack . Lex.prettyError) id $ Lex.lexSQL d "" Nothing s
H.assertEqual "" ts ts1
let s' = Lex.prettyTokens d $ ts1
H.assertEqual "pretty print" s s'
makeLexingFailsTest :: Dialect -> Text -> T.TestTree
makeLexingFailsTest d s = H.testCase (T.unpack s) $ do
case Lex.lexSQL d "" Nothing s of
Right x -> H.assertFailure $ "lexing should have failed: " ++ T.unpack s ++ "\ngot: " ++ show x
Left _ -> pure ()
toTest :: (Eq a, Show a) =>
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> Text
-> a
-> T.TestTree
toTest parser pp d str expected = H.testCase (T.unpack str) $ do
let egot = parser d "" Nothing str
case egot of
Left e -> H.assertFailure $ T.unpack $ prettyError e
Right got -> H.assertEqual "" expected got
let str' = pp d expected
egot' = parser d "" Nothing str'
case egot' of
Left e' ->
H.assertFailure $ "pp roundtrip"
++ "\n" ++ (T.unpack str')
++ (T.unpack $ prettyError e')
Right got' ->
H.assertEqual
("pp roundtrip" ++ "\n" ++ T.unpack str')
expected got'
toPTest :: (Eq a, Show a) =>
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> Text
-> T.TestTree
toPTest parser pp d str = H.testCase (T.unpack str) $ do
let egot = parser d "" Nothing str
case egot of
Left e -> H.assertFailure $ T.unpack $ prettyError 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" ++ T.unpack str' ++ "\n"
++ T.unpack (prettyError e')
Right _got' -> return ()
toFTest :: (Eq a, Show a) =>
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> Text
-> T.TestTree
toFTest parser _pp d str = H.testCase (T.unpack 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" ++ T.unpack str
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

98
tests/Language/SQL/SimpleSQL/Tpch.hs
View file

@ -14,15 +14,14 @@ 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"
$ map (ParseQueryExpr ansi2011 . snd) tpchQueries
tpchTests = Group "parse tpch" tpchQueries
tpchQueries :: [(String,Text)]
tpchQueries :: [TestItem]
tpchQueries =
[("Q1","\n\
[q "Q1" "\n\
\select\n\
\ l_returnflag,\n\
\ l_linestatus,\n\
@ -43,8 +42,8 @@ tpchQueries =
\ l_linestatus\n\
\order by\n\
\ l_returnflag,\n\
\ l_linestatus")
,("Q2","\n\
\ l_linestatus"
,q "Q2" "\n\
\select\n\
\ s_acctbal,\n\
\ s_name,\n\
@ -88,8 +87,8 @@ tpchQueries =
\ n_name,\n\
\ s_name,\n\
\ p_partkey\n\
\fetch first 100 rows only")
,("Q3","\n\
\fetch first 100 rows only"
,q "Q3" "\n\
\ select\n\
\ l_orderkey,\n\
\ sum(l_extendedprice * (1 - l_discount)) as revenue,\n\
@ -112,8 +111,8 @@ tpchQueries =
\ order by\n\
\ revenue desc,\n\
\ o_orderdate\n\
\ fetch first 10 rows only")
,("Q4","\n\
\ fetch first 10 rows only"
,q "Q4" "\n\
\ select\n\
\ o_orderpriority,\n\
\ count(*) as order_count\n\
@ -134,8 +133,8 @@ tpchQueries =
\ group by\n\
\ o_orderpriority\n\
\ order by\n\
\ o_orderpriority")
,("Q5","\n\
\ o_orderpriority"
,q "Q5" "\n\
\ select\n\
\ n_name,\n\
\ sum(l_extendedprice * (1 - l_discount)) as revenue\n\
@ -159,8 +158,8 @@ tpchQueries =
\ group by\n\
\ n_name\n\
\ order by\n\
\ revenue desc")
,("Q6","\n\
\ revenue desc"
,q "Q6" "\n\
\ select\n\
\ sum(l_extendedprice * l_discount) as revenue\n\
\ from\n\
@ -169,8 +168,8 @@ tpchQueries =
\ 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\
\ and l_quantity < 24"
,q "Q7" "\n\
\ select\n\
\ supp_nation,\n\
\ cust_nation,\n\
@ -209,8 +208,8 @@ tpchQueries =
\ order by\n\
\ supp_nation,\n\
\ cust_nation,\n\
\ l_year")
,("Q8","\n\
\ l_year"
,q "Q8" "\n\
\ select\n\
\ o_year,\n\
\ sum(case\n\
@ -247,8 +246,8 @@ tpchQueries =
\ group by\n\
\ o_year\n\
\ order by\n\
\ o_year")
,("Q9","\n\
\ o_year"
,q "Q9" "\n\
\ select\n\
\ nation,\n\
\ o_year,\n\
@ -280,8 +279,8 @@ tpchQueries =
\ o_year\n\
\ order by\n\
\ nation,\n\
\ o_year desc")
,("Q10","\n\
\ o_year desc"
,q "Q10" "\n\
\ select\n\
\ c_custkey,\n\
\ c_name,\n\
@ -313,8 +312,8 @@ tpchQueries =
\ c_comment\n\
\ order by\n\
\ revenue desc\n\
\ fetch first 20 rows only")
,("Q11","\n\
\ fetch first 20 rows only"
,q "Q11" "\n\
\ select\n\
\ ps_partkey,\n\
\ sum(ps_supplycost * ps_availqty) as value\n\
@ -341,8 +340,8 @@ tpchQueries =
\ and n_name = 'CHINA'\n\
\ )\n\
\ order by\n\
\ value desc")
,("Q12","\n\
\ value desc"
,q "Q12" "\n\
\ select\n\
\ l_shipmode,\n\
\ sum(case\n\
@ -370,8 +369,8 @@ tpchQueries =
\ group by\n\
\ l_shipmode\n\
\ order by\n\
\ l_shipmode")
,("Q13","\n\
\ l_shipmode"
,q "Q13" "\n\
\ select\n\
\ c_count,\n\
\ count(*) as custdist\n\
@ -391,8 +390,8 @@ tpchQueries =
\ c_count\n\
\ order by\n\
\ custdist desc,\n\
\ c_count desc")
,("Q14","\n\
\ c_count desc"
,q "Q14" "\n\
\ select\n\
\ 100.00 * sum(case\n\
\ when p_type like 'PROMO%'\n\
@ -405,8 +404,8 @@ tpchQueries =
\ 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\
\ 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\
@ -448,8 +447,8 @@ tpchQueries =
\ revenue0\n\
\ )\n\
\ order by\n\
\ s_suppkey")
,("Q16","\n\
\ s_suppkey"
,q "Q16" "\n\
\ select\n\
\ p_brand,\n\
\ p_type,\n\
@ -479,8 +478,8 @@ tpchQueries =
\ supplier_cnt desc,\n\
\ p_brand,\n\
\ p_type,\n\
\ p_size")
,("Q17","\n\
\ p_size"
,q "Q17" "\n\
\ select\n\
\ sum(l_extendedprice) / 7.0 as avg_yearly\n\
\ from\n\
@ -497,8 +496,8 @@ tpchQueries =
\ lineitem\n\
\ where\n\
\ l_partkey = p_partkey\n\
\ )")
,("Q18","\n\
\ )"
,q "Q18" "\n\
\ select\n\
\ c_name,\n\
\ c_custkey,\n\
@ -531,8 +530,8 @@ tpchQueries =
\ order by\n\
\ o_totalprice desc,\n\
\ o_orderdate\n\
\ fetch first 100 rows only")
,("Q19","\n\
\ fetch first 100 rows only"
,q "Q19" "\n\
\ select\n\
\ sum(l_extendedprice* (1 - l_discount)) as revenue\n\
\ from\n\
@ -567,8 +566,8 @@ tpchQueries =
\ 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\
\ )"
,q "Q20" "\n\
\ select\n\
\ s_name,\n\
\ s_address\n\
@ -605,8 +604,8 @@ tpchQueries =
\ and s_nationkey = n_nationkey\n\
\ and n_name = 'VIETNAM'\n\
\ order by\n\
\ s_name")
,("Q21","\n\
\ s_name"
,q "Q21" "\n\
\ select\n\
\ s_name,\n\
\ count(*) as numwait\n\
@ -646,8 +645,8 @@ tpchQueries =
\ order by\n\
\ numwait desc,\n\
\ s_name\n\
\ fetch first 100 rows only")
,("Q22","\n\
\ fetch first 100 rows only"
,q "Q22" "\n\
\ select\n\
\ cntrycode,\n\
\ count(*) as numcust,\n\
@ -684,5 +683,8 @@ tpchQueries =
\ group by\n\
\ cntrycode\n\
\ order by\n\
\ cntrycode")
\ cntrycode"
]
where
q :: HasCallStack => Text -> Text -> TestItem
q _ src = testParseQueryExpr ansi2011 src

5
tests/RunTests.hs
View file

@ -1,8 +1,9 @@
import Test.Tasty
import Test.Hspec (hspec)
import Language.SQL.SimpleSQL.Tests
main :: IO ()
main = defaultMain tests
main = hspec tests

24
website/RenderTestCases.hs
View file

@ -20,26 +20,28 @@ doc _ (Group nm _) | "generated" `T.isInfixOf` nm = []
doc n (Group nm is) =
Heading n (L.fromStrict nm)
: concatMap (doc (n + 1)) is
doc _ (TestScalarExpr _ str e) =
doc _ (TestScalarExpr _ str e _) =
[Row (L.fromStrict str) (L.pack $ ppShow e)]
doc _ (TestQueryExpr _ str e) =
doc _ (TestQueryExpr _ str e _) =
[Row (L.fromStrict str) (L.pack $ ppShow e)]
doc _ (TestStatement _ str e) =
doc _ (TestStatement _ str e _) =
[Row (L.fromStrict str) (L.pack $ ppShow e)]
doc _ (TestStatements _ str e) =
doc _ (TestStatements _ str e _) =
[Row (L.fromStrict str) (L.pack $ ppShow e)]
doc _ (ParseQueryExpr d str) =
doc _ (ParseQueryExpr d str _) =
[Row (L.fromStrict str) (showResult $ P.parseQueryExpr d "" Nothing str)]
doc _ (ParseQueryExprFails d str) =
doc _ (ParseQueryExprFails d str _) =
[Row (L.fromStrict str) (showResult $ P.parseQueryExpr d "" Nothing str)]
doc _ (ParseScalarExprFails d str) =
doc _ (ParseScalarExprFails d str _) =
[Row (L.fromStrict str) (showResult $ P.parseScalarExpr d "" Nothing str)]
doc _ (LexTest d str _) =
[Row (L.fromStrict str) (showResultL $ L.lexSQL d "" Nothing str)]
doc _ (LexTest d str _ _) =
[Row (L.fromStrict str) (showResultL $ L.lexSQL d False "" Nothing str)]
doc _ (LexFails d str _) =
[Row (L.fromStrict str) (showResultL $ L.lexSQL d False "" Nothing str)]
doc _ (GeneralParseFailTest {}) = []
doc _ (LexFails d str) =
[Row (L.fromStrict str) (showResultL $ L.lexSQL d "" Nothing str)]
showResult :: Show a => Either P.ParseError a -> L.Text
showResult = either (("Left\n" <>) . L.fromStrict . P.prettyError) (L.pack . ppShow)

9
website/index.md
View file

@ -184,6 +184,8 @@ generally available to work on these, so you should either make a pull
request, or find someone willing to implement the features and make a
pull request.
Bug reports of confusing or poor parse errors are also encouraged.
There is a related tutorial on implementing a SQL parser here:
<http://jakewheat.github.io/intro_to_parsing/> (TODO: this is out of
date, in the process of being updated)
@ -210,6 +212,13 @@ Or use the makefile target
make test
~~~~
To skip some of the slow lexer tests, which you usually only need to
run before each commit, use:
~~~~
make fast-test
~~~~
When you add support for new syntax: add some tests. If you modify or
fix something, and it doesn't have tests, add some. If the syntax
isn't in ANSI SQL, guard it behind a dialect flag. If you add

11
website/render-test-cases.cabal
View file

@ -1,7 +1,7 @@
cabal-version: 2.2
name: simple-sql-parser
version: 0.7.1
version: 0.8.0
executable RenderTestCases
main-is: RenderTestCases.hs
@ -13,9 +13,11 @@ executable RenderTestCases
parser-combinators,
mtl,
containers,
tasty,
tasty-hunit,
hspec,
hspec-megaparsec,
pretty-show,
hspec-expectations,
raw-strings-qq,
default-language: Haskell2010
ghc-options: -Wall -O0
@ -47,3 +49,6 @@ executable RenderTestCases
Language.SQL.SimpleSQL.TestTypes
Language.SQL.SimpleSQL.Tests
Language.SQL.SimpleSQL.Tpch
Language.SQL.SimpleSQL.Expectations
Language.SQL.SimpleSQL.TestRunners
Language.SQL.SimpleSQL.ErrorMessages