From c11bee4a9cc81e75fb8ce7d2f538ab5b0ab6615b Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Sun, 4 Feb 2024 16:00:59 +0000 Subject: [PATCH] switch tests to hspec, improve error messages --- Language/SQL/SimpleSQL/Lex.hs | 347 +++++++----- Language/SQL/SimpleSQL/Parse.hs | 405 ++++++++------ Makefile | 8 +- changelog | 5 + examples/ErrorMessagesTool.hs | 514 ++++++++++++++++++ examples/SimpleSQLParserTool.hs | 2 +- simple-sql-parser.cabal | 35 +- tests/Language/SQL/SimpleSQL/CreateIndex.hs | 10 +- tests/Language/SQL/SimpleSQL/CustomDialect.hs | 38 +- .../Language/SQL/SimpleSQL/EmptyStatement.hs | 27 +- tests/Language/SQL/SimpleSQL/ErrorMessages.hs | 216 +++----- tests/Language/SQL/SimpleSQL/Expectations.hs | 61 +++ tests/Language/SQL/SimpleSQL/FullQueries.hs | 19 +- tests/Language/SQL/SimpleSQL/GroupBy.hs | 124 +++-- tests/Language/SQL/SimpleSQL/LexerTests.hs | 206 ++++--- tests/Language/SQL/SimpleSQL/MySQL.hs | 22 +- tests/Language/SQL/SimpleSQL/Odbc.hs | 13 +- tests/Language/SQL/SimpleSQL/Oracle.hs | 23 +- tests/Language/SQL/SimpleSQL/Postgres.hs | 151 ++--- .../SQL/SimpleSQL/QueryExprComponents.hs | 174 +++--- tests/Language/SQL/SimpleSQL/QueryExprs.hs | 26 +- .../SQL/SimpleSQL/SQL2011AccessControl.hs | 156 +++--- tests/Language/SQL/SimpleSQL/SQL2011Bits.hs | 42 +- .../SQL/SimpleSQL/SQL2011DataManipulation.hs | 77 +-- .../Language/SQL/SimpleSQL/SQL2011Queries.hs | 353 ++++++------ tests/Language/SQL/SimpleSQL/SQL2011Schema.hs | 340 ++++++------ tests/Language/SQL/SimpleSQL/ScalarExprs.hs | 466 ++++++++-------- tests/Language/SQL/SimpleSQL/TableRefs.hs | 123 +++-- tests/Language/SQL/SimpleSQL/TestRunners.hs | 92 ++++ tests/Language/SQL/SimpleSQL/TestTypes.hs | 30 +- tests/Language/SQL/SimpleSQL/Tests.hs | 127 +---- tests/Language/SQL/SimpleSQL/Tpch.hs | 98 ++-- tests/RunTests.hs | 5 +- website/RenderTestCases.hs | 24 +- website/index.md | 9 + website/render-test-cases.cabal | 11 +- 36 files changed, 2570 insertions(+), 1809 deletions(-) create mode 100644 examples/ErrorMessagesTool.hs create mode 100644 tests/Language/SQL/SimpleSQL/Expectations.hs create mode 100644 tests/Language/SQL/SimpleSQL/TestRunners.hs 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 [ WITH ADMIN ] -} - ,(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 -} - ,(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 -} - ,(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 -} - ,(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 @@ -84,9 +84,8 @@ BEGIN is not in the standard! -} - ,(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 -} - ,(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 -} - ,(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 ] -} - (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 @@ -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" -} - ,(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)) ] -- ::= 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 @@ -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 -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 @@ -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 @@ -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 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 . 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 . 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 . 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" [ ... ] -} - (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
@@ -103,10 +105,10 @@ add schema element support: [ ON COMMIT
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 [ ] -} - ,(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 is supposed to just @@ -531,14 +533,14 @@ generated always (valueexpr) -} - ,(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) -} - ,(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 -} - ,(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 @@ -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 @@ -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 @@ -900,10 +901,10 @@ todo: more add column SET 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 ] -} - ,(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
-} - ,(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 -} - ,(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 @@ -1111,13 +1112,13 @@ defintely skip DROP TABLE
-} - ,(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 -} - ,(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 ] -} - ,(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 -} - ,(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 -} - ,(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 -} - ,(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 @@ -1347,13 +1348,13 @@ defintely skip DROP DOMAIN -} - ,(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 [ ] -} - ,(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 @@ -1442,13 +1443,13 @@ defintely skip DROP ASSERTION [ ] -} - ,(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 -} - ,(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 -} - ,(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: (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