diff --git a/Language/SQL/SimpleSQL/Lex.hs b/Language/SQL/SimpleSQL/Lex.hs
index 6af2a35..5b6c015 100644
--- a/Language/SQL/SimpleSQL/Lex.hs
+++ b/Language/SQL/SimpleSQL/Lex.hs
@@ -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
+
----------------------------------------------------------------------------
diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs
index b568e86..d9f1ee5 100644
--- a/Language/SQL/SimpleSQL/Parse.hs
+++ b/Language/SQL/SimpleSQL/Parse.hs
@@ -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
------------------------------------------------------------------------------
diff --git a/Makefile b/Makefile
index c637ab7..9043d35 100644
--- a/Makefile
+++ b/Makefile
@@ -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)"
diff --git a/changelog b/changelog
index 5847169..6abd50c 100644
--- a/changelog
+++ b/changelog
@@ -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
diff --git a/examples/ErrorMessagesTool.hs b/examples/ErrorMessagesTool.hs
new file mode 100644
index 0000000..76f612c
--- /dev/null
+++ b/examples/ErrorMessagesTool.hs
@@ -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
+'
+
+|]
diff --git a/examples/SimpleSQLParserTool.hs b/examples/SimpleSQLParserTool.hs
index f00e94d..d403593 100644
--- a/examples/SimpleSQLParserTool.hs
+++ b/examples/SimpleSQLParserTool.hs
@@ -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)
)
diff --git a/simple-sql-parser.cabal b/simple-sql-parser.cabal
index 3432b8f..99430ce 100644
--- a/simple-sql-parser.cabal
+++ b/simple-sql-parser.cabal
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/CreateIndex.hs b/tests/Language/SQL/SimpleSQL/CreateIndex.hs
index c8a2e82..593d9b7 100644
--- a/tests/Language/SQL/SimpleSQL/CreateIndex.hs
+++ b/tests/Language/SQL/SimpleSQL/CreateIndex.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/CustomDialect.hs b/tests/Language/SQL/SimpleSQL/CustomDialect.hs
index 073794d..159ced1 100644
--- a/tests/Language/SQL/SimpleSQL/CustomDialect.hs
+++ b/tests/Language/SQL/SimpleSQL/CustomDialect.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/EmptyStatement.hs b/tests/Language/SQL/SimpleSQL/EmptyStatement.hs
index 72fd2be..aac10ce 100644
--- a/tests/Language/SQL/SimpleSQL/EmptyStatement.hs
+++ b/tests/Language/SQL/SimpleSQL/EmptyStatement.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/ErrorMessages.hs b/tests/Language/SQL/SimpleSQL/ErrorMessages.hs
index 031c576..c18e88f 100644
--- a/tests/Language/SQL/SimpleSQL/ErrorMessages.hs
+++ b/tests/Language/SQL/SimpleSQL/ErrorMessages.hs
@@ -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)
diff --git a/tests/Language/SQL/SimpleSQL/Expectations.hs b/tests/Language/SQL/SimpleSQL/Expectations.hs
new file mode 100644
index 0000000..ce154e7
--- /dev/null
+++ b/tests/Language/SQL/SimpleSQL/Expectations.hs
@@ -0,0 +1,61 @@
+
+module Language.SQL.SimpleSQL.Expectations
+ (shouldParseA
+ ,shouldParseL
+ ,shouldParse1
+ ,shouldFail
+ ,shouldSucceed
+ ,shouldFailWith
+ ) where
+
+
+import Language.SQL.SimpleSQL.Parse
+import qualified Language.SQL.SimpleSQL.Lex as Lex
+
+import qualified Data.Text as T
+import Data.Text (Text)
+
+import Test.Hspec.Expectations
+ (Expectation
+ ,HasCallStack
+ ,expectationFailure
+ )
+
+import Test.Hspec
+ (shouldBe
+ )
+
+shouldParseA :: (HasCallStack,Eq a, Show a) => Either ParseError a -> a -> Expectation
+shouldParseA = shouldParse1 (T.unpack . prettyError)
+
+shouldParseL :: (HasCallStack,Eq a, Show a) => Either Lex.ParseError a -> a -> Expectation
+shouldParseL = shouldParse1 (T.unpack . Lex.prettyError)
+
+shouldParse1 :: (HasCallStack, Show a, Eq a) =>
+ (e -> String)
+ -> Either e a
+ -> a
+ -> Expectation
+shouldParse1 prettyErr r v = case r of
+ Left e ->
+ expectationFailure $
+ "expected: "
+ ++ show v
+ ++ "\nbut parsing failed with error:\n"
+ ++ prettyErr e
+ Right x -> x `shouldBe` v
+
+shouldFail :: (HasCallStack, Show a) => Either e a -> Expectation
+shouldFail r = case r of
+ Left _ -> (1 :: Int) `shouldBe` 1
+ Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a
+
+shouldFailWith :: (HasCallStack, Show a) => (e -> Text) -> Either e a -> Text -> Expectation
+shouldFailWith p r e = case r of
+ Left e1 -> p e1 `shouldBe` e
+ Right a -> expectationFailure $ "expected parse failure, but succeeded with " <> show a
+
+shouldSucceed :: (HasCallStack) => (e -> String) -> Either e a -> Expectation
+shouldSucceed pe r = case r of
+ Left e -> expectationFailure $ "expected parse success, but got: " <> pe e
+ Right _ -> (1 :: Int) `shouldBe` 1
diff --git a/tests/Language/SQL/SimpleSQL/FullQueries.hs b/tests/Language/SQL/SimpleSQL/FullQueries.hs
index 19b9bf2..29b180e 100644
--- a/tests/Language/SQL/SimpleSQL/FullQueries.hs
+++ b/tests/Language/SQL/SimpleSQL/FullQueries.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/GroupBy.hs b/tests/Language/SQL/SimpleSQL/GroupBy.hs
index e77c91a..be8907c 100644
--- a/tests/Language/SQL/SimpleSQL/GroupBy.hs
+++ b/tests/Language/SQL/SimpleSQL/GroupBy.hs
@@ -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\
diff --git a/tests/Language/SQL/SimpleSQL/LexerTests.hs b/tests/Language/SQL/SimpleSQL/LexerTests.hs
index 22c9b12..41634be 100644
--- a/tests/Language/SQL/SimpleSQL/LexerTests.hs
+++ b/tests/Language/SQL/SimpleSQL/LexerTests.hs
@@ -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 "]
+
+ ,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"]
- ,("1", [SqlNumber "1"])
- ,("42", [SqlNumber "42"])
+ ,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"]
- -- have to fix the dialect handling in the tests
- --,("$1", [PositionalArg 1])
- --,("$200", [PositionalArg 200])
+ ,t "1" [SqlNumber "1"]
+ ,t "42" [SqlNumber "42"]
- ,(":test", [PrefixedVariable ':' "test"])
+ ,tp "$1" [PositionalArg 1]
+ ,tp "$200" [PositionalArg 200]
- ] ++ map (\a -> (a, [Symbol a])) (
+ ,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) ]
+
diff --git a/tests/Language/SQL/SimpleSQL/MySQL.hs b/tests/Language/SQL/SimpleSQL/MySQL.hs
index 28581c9..76c2ca7 100644
--- a/tests/Language/SQL/SimpleSQL/MySQL.hs
+++ b/tests/Language/SQL/SimpleSQL/MySQL.hs
@@ -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)]
diff --git a/tests/Language/SQL/SimpleSQL/Odbc.hs b/tests/Language/SQL/SimpleSQL/Odbc.hs
index 3d3f4b5..fb03e3c 100644
--- a/tests/Language/SQL/SimpleSQL/Odbc.hs
+++ b/tests/Language/SQL/SimpleSQL/Odbc.hs
@@ -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]
diff --git a/tests/Language/SQL/SimpleSQL/Oracle.hs b/tests/Language/SQL/SimpleSQL/Oracle.hs
index eea2be8..c3eefba 100644
--- a/tests/Language/SQL/SimpleSQL/Oracle.hs
+++ b/tests/Language/SQL/SimpleSQL/Oracle.hs
@@ -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 []]
+ ]
+
diff --git a/tests/Language/SQL/SimpleSQL/Postgres.hs b/tests/Language/SQL/SimpleSQL/Postgres.hs
index 65d7d01..81d7fa8 100644
--- a/tests/Language/SQL/SimpleSQL/Postgres.hs
+++ b/tests/Language/SQL/SimpleSQL/Postgres.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs b/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs
index 31e1648..77a922b 100644
--- a/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs
+++ b/tests/Language/SQL/SimpleSQL/QueryExprComponents.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/QueryExprs.hs b/tests/Language/SQL/SimpleSQL/QueryExprs.hs
index d1ff7b3..aa52812 100644
--- a/tests/Language/SQL/SimpleSQL/QueryExprs.hs
+++ b/tests/Language/SQL/SimpleSQL/QueryExprs.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs b/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs
index 9ca9d88..72c0488 100644
--- a/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs
+++ b/tests/Language/SQL/SimpleSQL/SQL2011AccessControl.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs b/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs
index cf794de..145f631 100644
--- a/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs
+++ b/tests/Language/SQL/SimpleSQL/SQL2011Bits.hs
@@ -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,10 +29,8 @@ 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
diff --git a/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs b/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs
index 89b15ba..44709d8 100644
--- a/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs
+++ b/tests/Language/SQL/SimpleSQL/SQL2011DataManipulation.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs b/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs
index a00f775..047bd2f 100644
--- a/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs
+++ b/tests/Language/SQL/SimpleSQL/SQL2011Queries.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs b/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs
index e1eedc0..a1e1da2 100644
--- a/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs
+++ b/tests/Language/SQL/SimpleSQL/SQL2011Schema.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/ScalarExprs.hs b/tests/Language/SQL/SimpleSQL/ScalarExprs.hs
index 0ff3fed..6aa075a 100644
--- a/tests/Language/SQL/SimpleSQL/ScalarExprs.hs
+++ b/tests/Language/SQL/SimpleSQL/ScalarExprs.hs
@@ -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
]
-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")
- ]
+t :: HasCallStack => Text -> ScalarExpr -> TestItem
+t src ast = testScalarExpr ansi2011 src ast
+td :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem
+td d src ast = testScalarExpr d src ast
+
+
+
+literals :: TestItem
+literals = Group "literals"
+ [t "3" $ NumLit "3"
+ ,t "3." $ NumLit "3."
+ ,t "3.3" $ NumLit "3.3"
+ ,t ".3" $ NumLit ".3"
+ ,t "3.e3" $ NumLit "3.e3"
+ ,t "3.3e3" $ NumLit "3.3e3"
+ ,t ".3e3" $ NumLit ".3e3"
+ ,t "3e3" $ NumLit "3e3"
+ ,t "3e+3" $ NumLit "3e+3"
+ ,t "3e-3" $ NumLit "3e-3"
+ ,t "'string'" $ StringLit "'" "'" "string"
+ ,t "'string with a '' quote'" $ StringLit "'" "'" "string with a '' quote"
+ ,t "'1'" $ StringLit "'" "'" "1"
+ ,t "interval '3' day"
+ $ IntervalLit Nothing "3" (Itf "day" Nothing) Nothing
+ ,t "interval '3' day (3)"
+ $ IntervalLit Nothing "3" (Itf "day" $ Just (3,Nothing)) Nothing
+ ,t "interval '3 weeks'" $ TypedLit (TypeName [Name Nothing "interval"]) "3 weeks"
+ ]
+
identifiers :: TestItem
-identifiers = Group "identifiers" $ 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"]]
diff --git a/tests/Language/SQL/SimpleSQL/TableRefs.hs b/tests/Language/SQL/SimpleSQL/TableRefs.hs
index 9f18dd9..e29a90e 100644
--- a/tests/Language/SQL/SimpleSQL/TableRefs.hs
+++ b/tests/Language/SQL/SimpleSQL/TableRefs.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/TestRunners.hs b/tests/Language/SQL/SimpleSQL/TestRunners.hs
new file mode 100644
index 0000000..2c2d506
--- /dev/null
+++ b/tests/Language/SQL/SimpleSQL/TestRunners.hs
@@ -0,0 +1,92 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+module Language.SQL.SimpleSQL.TestRunners
+ (testLex
+ ,lexFails
+ ,testScalarExpr
+ ,testQueryExpr
+ ,testStatement
+ ,testStatements
+ ,testParseQueryExpr
+ ,testParseQueryExprFails
+ ,testParseScalarExprFails
+ ,HasCallStack
+ ) where
+
+import Language.SQL.SimpleSQL.Syntax
+import Language.SQL.SimpleSQL.TestTypes
+import Language.SQL.SimpleSQL.Pretty
+import Language.SQL.SimpleSQL.Parse
+import qualified Language.SQL.SimpleSQL.Lex as Lex
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Language.SQL.SimpleSQL.Expectations
+ (shouldParseL
+ ,shouldFail
+ ,shouldParseA
+ ,shouldSucceed
+ )
+
+import Test.Hspec
+ (it
+ ,HasCallStack
+ )
+
+testLex :: HasCallStack => Dialect -> Text -> [Lex.Token] -> TestItem
+testLex d input a =
+ LexTest d input a $ do
+ it (T.unpack input) $ Lex.lexSQL d False "" Nothing input `shouldParseL` a
+ it (T.unpack $ "pp: " <> input) $ Lex.lexSQL d False "" Nothing (Lex.prettyTokens d a) `shouldParseL` a
+
+lexFails :: HasCallStack => Dialect -> Text -> TestItem
+lexFails d input =
+ LexFails d input $
+ it (T.unpack input) $ shouldFail $ Lex.lexSQL d False "" Nothing input
+
+testScalarExpr :: HasCallStack => Dialect -> Text -> ScalarExpr -> TestItem
+testScalarExpr d input a =
+ TestScalarExpr d input a $ do
+ it (T.unpack input) $ parseScalarExpr d "" Nothing input `shouldParseA` a
+ it (T.unpack $ "pp: " <> input) $ parseScalarExpr d "" Nothing (prettyScalarExpr d a) `shouldParseA` a
+
+testQueryExpr :: HasCallStack => Dialect -> Text -> QueryExpr -> TestItem
+testQueryExpr d input a =
+ TestQueryExpr d input a $ do
+ it (T.unpack input) $ parseQueryExpr d "" Nothing input `shouldParseA` a
+ it (T.unpack $ "pp: " <> input) $ parseQueryExpr d "" Nothing (prettyQueryExpr d a) `shouldParseA` a
+
+testParseQueryExpr :: HasCallStack => Dialect -> Text -> TestItem
+testParseQueryExpr d input =
+ let a = parseQueryExpr d "" Nothing input
+ in ParseQueryExpr d input $ do
+ it (T.unpack input) $ shouldSucceed (T.unpack . prettyError) a
+ case a of
+ Left _ -> pure ()
+ Right a' ->
+ it (T.unpack $ "pp: " <> input) $
+ parseQueryExpr d "" Nothing (prettyQueryExpr d a') `shouldParseA` a'
+
+testParseQueryExprFails :: HasCallStack => Dialect -> Text -> TestItem
+testParseQueryExprFails d input =
+ ParseQueryExprFails d input $
+ it (T.unpack input) $ shouldFail $ parseQueryExpr d "" Nothing input
+
+testParseScalarExprFails :: HasCallStack => Dialect -> Text -> TestItem
+testParseScalarExprFails d input =
+ ParseScalarExprFails d input $
+ it (T.unpack input) $ shouldFail $ parseScalarExpr d "" Nothing input
+
+testStatement :: HasCallStack => Dialect -> Text -> Statement -> TestItem
+testStatement d input a =
+ TestStatement d input a $ do
+ it (T.unpack input) $ parseStatement d "" Nothing input `shouldParseA` a
+ it (T.unpack $ "pp: " <> input) $ parseStatement d "" Nothing (prettyStatement d a) `shouldParseA` a
+
+testStatements :: HasCallStack => Dialect -> Text -> [Statement] -> TestItem
+testStatements d input a =
+ TestStatements d input a $ do
+ it (T.unpack input) $ parseStatements d "" Nothing input `shouldParseA` a
+ it (T.unpack $ "pp: " <> input) $ parseStatements d "" Nothing (prettyStatements d a) `shouldParseA` a
+
diff --git a/tests/Language/SQL/SimpleSQL/TestTypes.hs b/tests/Language/SQL/SimpleSQL/TestTypes.hs
index f2884aa..83f74a4 100644
--- a/tests/Language/SQL/SimpleSQL/TestTypes.hs
+++ b/tests/Language/SQL/SimpleSQL/TestTypes.hs
@@ -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 ())
+
diff --git a/tests/Language/SQL/SimpleSQL/Tests.hs b/tests/Language/SQL/SimpleSQL/Tests.hs
index 59b9fce..d5ea8fc 100644
--- a/tests/Language/SQL/SimpleSQL/Tests.hs
+++ b/tests/Language/SQL/SimpleSQL/Tests.hs
@@ -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
diff --git a/tests/Language/SQL/SimpleSQL/Tpch.hs b/tests/Language/SQL/SimpleSQL/Tpch.hs
index c5cfb87..b00f778 100644
--- a/tests/Language/SQL/SimpleSQL/Tpch.hs
+++ b/tests/Language/SQL/SimpleSQL/Tpch.hs
@@ -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
diff --git a/tests/RunTests.hs b/tests/RunTests.hs
index 168c564..d5cb9a1 100644
--- a/tests/RunTests.hs
+++ b/tests/RunTests.hs
@@ -1,8 +1,9 @@
-import Test.Tasty
+import Test.Hspec (hspec)
+
import Language.SQL.SimpleSQL.Tests
main :: IO ()
-main = defaultMain tests
+main = hspec tests
diff --git a/website/RenderTestCases.hs b/website/RenderTestCases.hs
index d42fd69..7234c04 100644
--- a/website/RenderTestCases.hs
+++ b/website/RenderTestCases.hs
@@ -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)
diff --git a/website/index.md b/website/index.md
index a2705c1..3c5d510 100644
--- a/website/index.md
+++ b/website/index.md
@@ -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
diff --git a/website/render-test-cases.cabal b/website/render-test-cases.cabal
index a8b7289..d4306b8 100644
--- a/website/render-test-cases.cabal
+++ b/website/render-test-cases.cabal
@@ -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