1
Fork 0

checkpoint during parser conversion to megaparsec

This commit is contained in:
Jake Wheat 2024-01-10 07:40:24 +00:00
parent 9396aa8cba
commit ab687318fb
31 changed files with 633 additions and 1186 deletions

View file

@ -1,720 +0,0 @@
{-
= Fixity fixups
The point of this code is to be able to take a table of fixity
information for unary and binary operators, then adjust an ast to
match these fixities. The standard way of handling this is handling
fixities at the parsing stage.
For the SQL parser, this is difficult because there is lots of weird
syntax for operators (such as prefix and postfix multiple keyword
operators, between, etc.).
An alterative idea which is used in some places is to parse the tree
regarding all the operators to have the same precedence and left
associativity, then correct the fixity in a pass over the ast after
parsing. Would also like to use this to fix the fixity for the join
trees, and set operations, after parsing them. TODO: anything else?
Approach
Really not sure how to get this correct. So: lots of testing
Basic testing idea: create an expression, then write down manually how
the expression should parse with correct fixity. Can write down the
expression in concrete syntax, and the correct fixity version using
parens.
Then can parse the expression, fix it, parse the fixed expression,
remove the parens and compare them to make sure they are equal.
Second layer of testing. For each source expression parsed, run it
through a generator which will generate every version of that tree by
choosing all possibilities of fixities on a token by token basis. This
will ensure the fixity fixer is robust. An alternative approach is to
guarantee the parser will produce trees where all the fixities are
known (e.g. unary operators always bind tighter than binary, binary
are all left associative, prefix unary bind tighter than postfix. This
way, the fix code can make some assumptions and have less code. We
will stick with the full general version which is more robust.
Another testing approach is to parse the tree with our non fixity
respecting parser then fix it, and also parse it with a fixity
respecting expression parser, and check the results are the same. This
is difficult with the parsec build expression parser which doesn't
handle nested unary operators, so have to find or write another build
expression parser. We can test the fixer with simple operators (single
symbol prefix, postfix and binary ops) and then use it on the complex
sql ast trees.
Can also try to generate trees ala quickcheck/smallcheck, then check
them with the fixer and the build expression parser.
generate a tree:
start with a term
then roll dice:
add a prefix
add a postfix
do nothing
then roll dice
add a binary op
for the second arg, recurse the algo
algorithm:
consider possible cases:
binop with two binops args
binop with prefix on left
binop with postfix on right
postfix with prefix inside
prefix with postfix inside
postfix with binop inside
prefix with binop inside
write a function to deal with each case and try to compose
Tasks:
write unary op tests: on each other, and with binary ops
figure out how to generate trees
do the step one tests (write the fixity with parens)
check out parsers expression parser
see if can generate trees using smallcheck
try to test these trees against expression parser
otherwise, generate tree, generate variations, check fixity always
produces same result
todo:
1. more tests for unary operators with each other
2. moving unary operators inside and outside binary operators:
have to think about how this will work in general case
3. ways to generate lots of tests and check them
-> what about creating a parser which parses to a list of all possible
parses with different fixities for each operator it sees?
4. ambiguous fixity cases - need position annotation to do these nicely
5. real sql: how to work with a variety of ast nodes
6. plug into simple-sql-parser
7. refactor the simple-sql-parser parsing code
8. simple-sql-parser todo for sqream: add other dml, dialects,
procedural?
9. testing idea: write big expressions with explicit parens everywhere
parse this
remove the parens
pretty print, then parse and fixfixity to see if same
then generate all variations of tree as if the fixities are different
and then fixfixity to check it restores the original
write fixity tests
write code to do the fixing
add error cases: put it in the either monad to report these
check the descend
then: move to real sql
different abstract representations of binops, etc.
what is the best way to deal with this? typeclass? conversion to and
from a generic tree?
can the binops be fixed on their own (precedence and assocativity)
and then the prefix and postfix ops in separate passes
what about a pass which puts the tree into canonical form:
all left associative, all unary ops tight as possible?
then the fixer can be easier?
-}
{-# LANGUAGE DeriveDataTypeable,TupleSections #-}
import Data.Data
import Text.Parsec.String (Parser)
import Text.Parsec (try)
import Text.Parsec.Char
import Text.Parsec.Combinator
import Text.Parsec (parse,ParseError)
import Control.Applicative ((<|>),many) -- ((<**>),(<$>),(<*), (*>),(<*>), (<$), (<|>), many)
--import qualified Text.Parsec.String.Expr as E
import Control.Monad
--import Data.List (intercalate)
import Data.Maybe ()
--import qualified Test.HUnit as H
--import FunctionsAndTypesForParsing
import Debug.Trace
import Text.Show.Pretty
import Data.List
import Control.Applicative
import qualified Test.Tasty as T
import qualified Test.Tasty.HUnit as H
data Expr = BinOp Expr String Expr
| PrefOp String Expr
| PostOp String Expr
| Iden String
| Lit String
| App String [Expr]
| Parens Expr
deriving (Eq,Show,Data,Typeable)
{-
--------
quick parser
-}
parensValue :: Parser Expr
parensValue = Parens <$> parens valueExpr
idenApp :: Parser Expr
idenApp = try $ do
i <- identifier
guard (i `notElem` ["not", "and", "or", "is"])
choice [do
args <- parens (commaSep valueExpr)
return $ App i args
,return $ Iden i
]
lit :: Parser Expr
lit = stringLit <|> numLit
where
stringLit = Lit <$> lexeme (char '\'' *> manyTill anyChar (char '\''))
numLit = do
x <- lexeme (many1 digit)
let y :: Integer
y = read x
return $ Lit $ show y
prefOp :: Parser Expr
prefOp = sym <|> kw
where
sym = do
let prefOps = ["+", "-"]
s <- choice $ map symbol prefOps
v <- term
return $ PrefOp s v
kw = do
let prefOps = ["not"]
i <- identifier
guard (i `elem` prefOps)
v <- term
return $ PrefOp i v
postOp :: Parser (Expr -> Expr)
postOp = try $ do
let kws = ["is null"]
kwsp = map (\a -> try $ do
let x :: [String]
x = words a
mapM_ keyword_ x
return $ PostOp a
) kws
choice kwsp
binOp :: Parser (Expr -> Expr -> Expr)
binOp = symbolBinOp <|> kwBinOp
where
symbolBinOp = do
let binOps = ["+", "-", "*", "/"]
s <- choice $ map symbol binOps
return $ \a b -> BinOp a s b
kwBinOp = do
let kwBinOps = ["and", "or"]
i <- identifier
guard (i `elem` kwBinOps)
return $ \a b -> BinOp a i b
term :: Parser Expr
term = (parensValue
<|> try prefOp
<|> idenApp
<|> lit)
<??*> postOp
-- (<??>) :: Parser a -> Parser (a -> a) -> Parser a
-- p <??> q = p <**> option id q
(<??*>) :: Parser a -> Parser (a -> a) -> Parser a
p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)
valueExpr :: Parser Expr
valueExpr = chainl1 term binOp
parens :: Parser a -> Parser a
parens = between openParen closeParen
openParen :: Parser Char
openParen = lexeme $ char '('
closeParen :: Parser Char
closeParen = lexeme $ char ')'
symbol :: String -> Parser String
symbol s = try $ lexeme $ do
u <- many1 (oneOf "<>=+-^%/*!|")
guard (s == u)
return s
identifier :: Parser String
identifier = lexeme ((:) <$> firstChar <*> many nonFirstChar)
where
firstChar = letter <|> char '_'
nonFirstChar = digit <|> firstChar
keyword :: String -> Parser String
keyword k = try $ do
i <- identifier
guard (i == k)
return k
keyword_ :: String -> Parser ()
keyword_ = void . keyword
whitespace :: Parser ()
whitespace =
choice [simpleWhitespace *> whitespace
,lineComment *> whitespace
,blockComment *> whitespace
,return ()]
where
lineComment = try (string "--")
*> manyTill anyChar (void (char '\n') <|> eof)
blockComment = try (string "/*")
*> manyTill anyChar (try $ string "*/")
simpleWhitespace = void $ many1 (oneOf " \t\n")
lexeme :: Parser a -> Parser a
lexeme p = p <* whitespace
comma :: Parser Char
comma = lexeme $ char ','
commaSep :: Parser a -> Parser [a]
commaSep = (`sepBy` comma)
parseExpr :: String -> Either ParseError Expr
parseExpr = parse (whitespace *> valueExpr <* eof) ""
-- --------------
data Assoc = AssocLeft | AssocRight | AssocNone deriving (Eq,Show)
type Fixities = [(String, (Int, Assoc))]
fixFixity :: Fixities -> Expr -> Expr
fixFixity fixities = fixBinOpPrecedence . fixBinOpAssociativity . fixNestedPrefPostPrec
where
fixBinOpAssociativity e = case e of
BinOp a op b ->
let a' = fixBinOpAssociativity a
b' = fixBinOpAssociativity b
def = BinOp a' op b'
in case (a',b') of
-- both
-- a1 op1 a2 op b1 op2 b2
(BinOp a1 op1 a2
,BinOp b1 op2 b2)
| Just (_p,opa) <- lookupFixity op
, Just (_p,op1a) <- lookupFixity op1
, Just (_p,op2a) <- lookupFixity op2
-> case (opa, op1a, op2a) of
(AssocRight, AssocRight, AssocRight) ->
BinOp a1 op1 (BinOp a2 op (BinOp b1 op2 b2))
(AssocLeft, AssocLeft, AssocLeft) ->
BinOp (BinOp (BinOp a1 op1 a2) op b1) op2 b2
--todo: other cases
_ -> def
-- just left side
(BinOp a1 op1 a2, _)
-- a1 op1 a2 op b'
| Just (_p,opa) <- lookupFixity op
, Just (_p,op1a) <- lookupFixity op1
-> case (opa, op1a) of
(AssocRight, AssocRight) ->
BinOp a1 op1 (BinOp a2 op b')
(AssocLeft, AssocLeft) ->
BinOp (BinOp a1 op1 a2) op b'
_ -> def
-- just right side
(_, BinOp b1 op2 b2)
-- e op b1 op2 b2
| Just (_p,opa) <- lookupFixity op
, Just (_p,op2a) <- lookupFixity op2
-> case (opa, op2a) of
(AssocRight, AssocRight) ->
BinOp a' op (BinOp b1 op2 b2)
(AssocLeft, AssocLeft) ->
BinOp (BinOp a' op b1) op2 b2
_ -> def
_ -> def
_ -> e
fixBinOpPrecedence e = case e of
BinOp a op b ->
let a' = fixBinOpPrecedence a
b' = fixBinOpPrecedence b
def = BinOp a' op b'
in case (a',b') of
-- both
-- a1 op1 a2 op b1 op2 b2
-- all equal
-- p > or < p1 == p2
-- p == p1 < or > p2
(BinOp a1 op1 a2
,BinOp b1 op2 b2)
| Just (p,_opa) <- lookupFixity op
, Just (p1,_op1a) <- lookupFixity op1
, Just (p2,_op2a) <- lookupFixity op2
-> case () of
-- _ | trace ("both prec " ++ show (p,p1,p2)) False -> undefined
_ | p == p1 && p1 == p2 -> def
_ | p > p1 && p1 == p2 -> BinOp a1 op1 b'
_ | p < p1 && p1 == p2 -> BinOp (BinOp a1 op1 a2) op b'
_ | p == p1 && p2 > p1 -> BinOp a' op (BinOp b1 op2 b2)
_ | p == p1 && p2 < p1 -> def -- todo
_ | otherwise -> def
-- just left side
(BinOp a1 op1 a2, _)
-- a1 op1 a2 op b'
| Just (p,_opa) <- lookupFixity op
, Just (p1,_op1a) <- lookupFixity op1
-> case () of
-- _ | trace ("left prec " ++ show (p,p1)) False -> undefined
_ | p < p1 -> {-trace "b1" $ -}BinOp (BinOp a1 op1 a2) op b'
| p > p1 -> {-trace "b2" $ -}BinOp a1 op1 (BinOp a2 op b')
| otherwise -> def
-- just right side
(_, BinOp b1 op2 b2)
-- a' op b1 op2 b2
| Just (p,_opa) <- lookupFixity op
, Just (p2,_op1a) <- lookupFixity op2
-> case () of
-- _ | trace ("right prec " ++ show (p,p2)) False -> undefined
_ | p > p2 -> {-trace "b1" $ -}BinOp (BinOp a' op b1) op2 b2
| p < p2 -> {-trace "b2" $ -}BinOp a' op (BinOp b1 op2 b2)
| otherwise -> {-trace "def" $ -} def
_ -> def
_ -> e
fixNestedPrefPostPrec e = case e of
PrefOp op a ->
let a' = fixNestedPrefPostPrec a
in case a' of
PostOp op1 b | Just (p,_) <- lookupFixity op
, Just (p1,_) <- lookupFixity op1
, p > p1 -> PostOp op1 (PrefOp op b)
_ -> PrefOp op a'
PostOp op a ->
let a' = fixNestedPrefPostPrec a
in case a' of
PrefOp op1 b | Just (p,_) <- lookupFixity op
, Just (p1,_) <- lookupFixity op1
, p > p1 -> PrefOp op1 (PostOp op b)
_ -> PostOp op a'
_ -> e
lookupFixity :: String -> Maybe (Int,Assoc)
lookupFixity s = maybe (trace ("didn't find " ++ s ++ "\n" ++ ppShow fixities) Nothing)
Just $ lookup s fixities
sqlFixity :: [(String, (Int, Assoc))]
sqlFixity = [(".", (13, AssocLeft))
,("[]", (12, AssocNone))
{-
unary + -
todo: split the fixity table into prefix, binary and postfix
todo: don't have explicit precedence numbers in the table??
-}
,("^", (10, AssocNone))]
++ m ["*", "/", "%"] (9, AssocLeft)
++ m ["+","-"] (8, AssocLeft)
++ m ["<", ">", "=", "<=", ">=", "<>"] (4, AssocNone)
++ [("is null", (3, AssocNone))
,("not", (2, AssocRight))
,("and", (1, AssocLeft))
,("or", (0, AssocLeft))]
where
m l a = map (,a) l
{-
-------
some simple parser tests
-}
data Test = Group String [Test]
| ParserTest String Expr
| FixityTest Fixities Expr Expr
parserTests :: Test
parserTests = Group "parserTests" $ map (uncurry ParserTest) $
[("a", Iden "a")
,("'test'", Lit "test")
,("34", Lit "34")
,("f()", App "f" [])
,("f(3)", App "f" [Lit "3"])
,("(7)", Parens (Lit "7"))
,("a + 3", BinOp (Iden "a") "+" (Lit "3"))
,("1 + 2 + 3", BinOp (BinOp (Lit "1") "+" (Lit "2")) "+" (Lit "3"))
,("a or b", BinOp (Iden "a") "or" (Iden "b"))
,("-1", PrefOp "-" (Lit "1"))
,("not a", PrefOp "not" (Iden "a"))
,("not not a", PrefOp "not" (PrefOp "not" (Iden "a")))
,("a is null", PostOp "is null" (Iden "a"))
,("a is null is null", PostOp "is null" (PostOp "is null" (Iden "a")))
,("-a+3", BinOp (PrefOp "-" (Iden "a")) "+" (Lit "3"))
,("a is null and b is null", BinOp (PostOp "is null" (Iden "a"))
"and"
(PostOp "is null" (Iden "b")))
]
makeParserTest :: String -> Expr -> T.TestTree
makeParserTest s e = H.testCase s $ do
let a = parseExpr s
if (Right e == a)
then putStrLn $ s ++ " OK"
else putStrLn $ "bad parse " ++ s ++ " " ++ show a
{-
------
fixity checks
test cases:
-}
fixityTests :: Test
fixityTests = Group "fixityTests" $
map (\(f,s,e) -> FixityTest f s e) $
[
-- 2 bin ops wrong associativity left + null versions
(sqlFixity
,i "a" `plus` (i "b" `plus` i "c")
,(i "a" `plus` i "b") `plus` i "c")
,(sqlFixity
,(i "a" `plus` i "b") `plus` i "c"
,(i "a" `plus` i "b") `plus` i "c")
-- 2 bin ops wrong associativity right
,(timesRight
,i "a" `times` (i "b" `times` i "c")
,i "a" `times` (i "b" `times` i "c"))
,(timesRight
,(i "a" `times` i "b") `times` i "c"
,i "a" `times` (i "b" `times` i "c"))
-- 2 bin ops wrong precedence left
,(sqlFixity
,i "a" `plus` (i "b" `times` i "c")
,i "a" `plus` (i "b" `times` i "c"))
,(sqlFixity
,(i "a" `plus` i "b") `times` i "c"
,i "a" `plus` (i "b" `times` i "c"))
-- 2 bin ops wrong precedence right
,(sqlFixity
,(i "a" `times` i "b") `plus` i "c"
,(i "a" `times` i "b") `plus` i "c")
,(sqlFixity
,i "a" `times` (i "b" `plus` i "c")
,(i "a" `times` i "b") `plus` i "c")
{-
a + b * c + d
a * b + c * d
check all variations
-}
] ++
(let t = (i "a" `plus` i "b")
`times`
(i "c" `plus` i "d")
trs = generateTrees $ splitTree t
in [(sqlFixity, x
,i "a" `plus` (i "b" `times` i "c")
`plus` i "d")
| x <- trs])
++
(let t = (i "a" `times` i "b")
`plus`
(i "c" `times` i "d")
trs = generateTrees $ splitTree t
in [(sqlFixity, x
,(i "a" `times` i "b")
`plus`
(i "c" `times` i "d"))
| x <- trs])
++ [
-- prefix then postfix wrong precedence
([("+", (9, AssocNone))
,("is null", (3, AssocNone))]
,PrefOp "+" (PostOp "is null" (i "a"))
,PostOp "is null" (PrefOp "+" (i "a")))
,([("+", (9, AssocNone))
,("is null", (3, AssocNone))]
,PostOp "is null" (PrefOp "+" (i "a"))
,PostOp "is null" (PrefOp "+" (i "a")))
,([("+", (3, AssocNone))
,("is null", (9, AssocNone))]
,PrefOp "+" (PostOp "is null" (i "a"))
,PrefOp "+" (PostOp "is null" (i "a")))
,([("+", (3, AssocNone))
,("is null", (9, AssocNone))]
,PostOp "is null" (PrefOp "+" (i "a"))
,PrefOp "+" (PostOp "is null" (i "a")))
{-
3-way unary operator movement:
take a starting point and generate variations
postfix on first arg of binop (cannot move) make sure precedence wants
it to move
prefix on second arg of binop (cannot move)
prefix on binop, precedence wrong
postfix on binop precedence wrong
prefix on first arg of binop, precedence wrong
postfix on second arg of binop, precedence wrong
ambiguous fixity tests
sanity check: parens stops rearrangement
check nesting 1 + f(expr)
-}
]
where
plus a b = BinOp a "+" b
times a b = BinOp a "*" b
i a = Iden a
timesRight = [("*", (9, AssocRight))]
-- testCase
makeFixityTest :: Fixities -> Expr -> Expr -> T.TestTree
makeFixityTest fs s e = H.testCase (show s) $ do
let s' = fixFixity fs s
H.assertEqual "" s' e
{-if (s' == e)
then putStrLn $ show s ++ " OK"
else putStrLn $ "ERROR\nstart: " ++ show s ++ "\nfixed: " ++ show s' ++ "\nshould be: " ++ show e-}
tests :: Test
tests = Group "Tests" [parserTests, fixityTests]
makeTest :: Test -> T.TestTree
makeTest (Group n ts) = T.testGroup n $ map makeTest ts
makeTest (ParserTest s e) = makeParserTest s e
makeTest (FixityTest f s e) = makeFixityTest f s e
{-
--------
> tests :: T.TestTree
> tests = T.testGroup "Tests" $ map makeFixityTest fixityTests
-}
main :: IO ()
main = T.defaultMain $ makeTest tests
{-do
mapM_ checkTest tests
mapM_ checkFixity fixityTests
let plus a b = BinOp a "+" b
times a b = BinOp a "*" b
i a = Iden a
let t = (i "a" `plus` i "b")
`times`
(i "c" `plus` i "d")
spl = splitTree t
trs = generateTrees spl
--putStrLn $ "\nSplit\n"
--putStrLn $ ppShow (fst spl, length $ snd spl)
--putStrLn $ show $ length trs
--putStrLn $ "\nTrees\n"
--putStrLn $ intercalate "\n" $ map show trs
return ()-}
{-
generating trees
1. tree -> list
val op val op val op ...
(has to be two lists?
generate variations:
pick numbers from 0 to n - 1 (n is the number of ops)
choose the op at this position to be the root
recurse on the two sides
-}
splitTree :: Expr -> ([Expr], [Expr->Expr->Expr])
splitTree (BinOp a op b) = let (x,y) = splitTree a
(z,w) = splitTree b
in (x++z, y++ [\a b -> BinOp a op b] ++ w)
splitTree x = ([x],[])
generateTrees :: ([Expr], [Expr->Expr->Expr]) -> [Expr]
generateTrees (es,ops) | length es /= length ops + 1 =
error $ "mismatch in lengths " ++ show (length es, length ops)
++"\n" ++ ppShow es ++ "\n"
generateTrees ([a,b], [op]) = [op a b]
generateTrees ([a], []) = [a]
generateTrees (vs, ops) =
let n = length ops
in --trace ("generating " ++ show (length vs, n) ++ "trees\n") $
concat $ flip map [0..n-1] $ \m ->
let (v1,v2) = splitAt (m + 1) vs
(ops1,op':ops2) = splitAt m ops
r = [op' t u | t <- generateTrees (v1,ops1)
, u <- generateTrees (v2,ops2)]
in -- trace ("generated " ++ show (length r) ++ " trees")
r
generateTrees ([],[]) = []

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.CreateIndex where
import Language.SQL.SimpleSQL.Syntax

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.CustomDialect (customDialectTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.EmptyStatement where
import Language.SQL.SimpleSQL.Syntax

View file

@ -1,6 +1,7 @@
-- Some tests for parsing full queries.
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.FullQueries (fullQueriesTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,6 +1,7 @@
-- Here are the tests for the group by component of query exprs
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.GroupBy (groupByTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,6 +1,7 @@
-- Tests for mysql dialect parsing
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.MySQL (mySQLTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.Odbc (odbcTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,6 +1,7 @@
-- Tests for oracle dialect parsing
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.Oracle (oracleTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -5,6 +5,7 @@ all of the postgres specific syntax has been skipped, this can be
revisited when the dialect support is added.
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.Postgres (postgresTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -7,6 +7,7 @@ table refs which are in a separate file.
These are a few misc tests which don't fit anywhere else.
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.QueryExprComponents (queryExprComponentTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -4,6 +4,7 @@ These are the tests for the queryExprs parsing which parses multiple
query expressions from one string.
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.QueryExprs (queryExprsTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -6,6 +6,7 @@ grant, etc
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.SQL2011AccessControl (sql2011AccessControlTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -7,6 +7,7 @@ commit, savepoint, etc.), and session management (set).
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.SQL2011Bits (sql2011BitsTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -2,6 +2,7 @@
-- Section 14 in Foundation
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.SQL2011DataManipulation (sql2011DataManipulationTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -31,10 +31,14 @@ some areas getting more comprehensive coverage tests, and also to note
which parts aren't currently supported.
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.SQL2011Queries (sql2011QueryTests) where
import Language.SQL.SimpleSQL.TestTypes
import Language.SQL.SimpleSQL.Syntax
import qualified Data.Text as T
import Data.Text (Text)
sql2011QueryTests :: TestItem
sql2011QueryTests = Group "sql 2011 query tests"
[literals
@ -1050,14 +1054,15 @@ new multipliers
create a list of type name variations:
-}
typeNames :: ([(String,TypeName)],[(String,TypeName)])
typeNames :: ([(Text,TypeName)],[(Text,TypeName)])
typeNames =
(basicTypes, concatMap makeArray basicTypes
++ map makeMultiset basicTypes)
<> map makeMultiset basicTypes)
where
makeArray (s,t) = [(s ++ " array", ArrayTypeName t Nothing)
,(s ++ " array[5]", ArrayTypeName t (Just 5))]
makeMultiset (s,t) = (s ++ " multiset", MultisetTypeName t)
makeArray (s,t) = [(s <> " array", ArrayTypeName t Nothing)
,(s <> " array[5]", ArrayTypeName t (Just 5))]
makeMultiset (s,t) = (s <> " multiset", MultisetTypeName t)
basicTypes :: [(Text, TypeName)]
basicTypes =
-- example of every standard type name
map (\t -> (t,TypeName [Name Nothing t]))
@ -1102,7 +1107,7 @@ typeNames =
-- array -- not allowed on own
-- multiset -- not allowed on own
++
<>
[-- 1 single prec + 1 with multiname
("char(5)", PrecTypeName [Name Nothing "char"] 5)
,("char varying(5)", PrecTypeName [Name Nothing "char varying"] 5)
@ -1224,12 +1229,12 @@ typeNameTests = Group "type names"
$ concatMap makeTests $ snd typeNames]
where
makeSimpleTests (ctn, stn) =
[(ctn ++ " 'test'", TypedLit stn "test")
[(ctn <> " 'test'", TypedLit stn "test")
]
makeCastTests (ctn, stn) =
[("cast('test' as " ++ ctn ++ ")", Cast (StringLit "'" "'" "test") stn)
[("cast('test' as " <> ctn <> ")", Cast (StringLit "'" "'" "test") stn)
]
makeTests a = makeSimpleTests a ++ makeCastTests a
makeTests a = makeSimpleTests a <> makeCastTests a
{-
@ -3590,7 +3595,7 @@ comparisonPredicates :: TestItem
comparisonPredicates = Group "comparison predicates"
$ map (uncurry (TestScalarExpr ansi2011))
$ map mkOp ["=", "<>", "<", ">", "<=", ">="]
++ [("ROW(a) = ROW(b)"
<> [("ROW(a) = ROW(b)"
,BinOp (App [Name Nothing "ROW"] [a])
[Name Nothing "="]
(App [Name Nothing "ROW"] [b]))
@ -3600,7 +3605,7 @@ comparisonPredicates = Group "comparison predicates"
(SpecialOp [Name Nothing "rowctor"] [Iden [Name Nothing "c"], Iden [Name Nothing "d"]]))
]
where
mkOp nm = ("a " ++ nm ++ " b"
mkOp nm = ("a " <> nm <> " b"
,BinOp a [Name Nothing nm] b)
a = Iden [Name Nothing "a"]
b = Iden [Name Nothing "b"]
@ -3911,7 +3916,7 @@ matchPredicate = Group "match predicate"
{qeSelectList = [(Iden [Name Nothing "a"],Nothing)]
,qeFrom = [TRSimple [Name Nothing "t"]]}
qea = qe {qeSelectList = qeSelectList qe
++ [(Iden [Name Nothing "b"],Nothing)]}
<> [(Iden [Name Nothing "b"],Nothing)]}
{-
TODO: simple, partial and full
@ -4397,7 +4402,7 @@ aggregateFunction = Group "aggregate function"
,AggregateApp [Name Nothing "count"]
All
[Iden [Name Nothing "a"]] [] fil)
] ++ concatMap mkSimpleAgg
] <> concatMap mkSimpleAgg
["avg","max","min","sum"
,"every", "any", "some"
,"stddev_pop","stddev_samp","var_samp","var_pop"
@ -4405,7 +4410,7 @@ aggregateFunction = Group "aggregate function"
-- bsf
++ concatMap mkBsf
<> concatMap mkBsf
["COVAR_POP","COVAR_SAMP","CORR","REGR_SLOPE"
,"REGR_INTERCEPT","REGR_COUNT","REGR_R2"
,"REGR_AVGX","REGR_AVGY"
@ -4413,15 +4418,15 @@ aggregateFunction = Group "aggregate function"
-- osf
++
<>
[("rank(a,c) within group (order by b)"
,AggregateAppGroup [Name Nothing "rank"]
[Iden [Name Nothing "a"], Iden [Name Nothing "c"]]
ob)]
++ map mkGp ["dense_rank","percent_rank"
<> map mkGp ["dense_rank","percent_rank"
,"cume_dist", "percentile_cont"
,"percentile_disc"]
++ [("array_agg(a)", App [Name Nothing "array_agg"] [Iden [Name Nothing "a"]])
<> [("array_agg(a)", App [Name Nothing "array_agg"] [Iden [Name Nothing "a"]])
,("array_agg(a order by z)"
,AggregateApp [Name Nothing "array_agg"]
SQDefault
@ -4433,20 +4438,20 @@ aggregateFunction = Group "aggregate function"
where
fil = Just $ BinOp (Iden [Name Nothing "something"]) [Name Nothing ">"] (NumLit "5")
ob = [SortSpec (Iden [Name Nothing "b"]) DirDefault NullsOrderDefault]
mkGp nm = (nm ++ "(a) within group (order by b)"
mkGp nm = (nm <> "(a) within group (order by b)"
,AggregateAppGroup [Name Nothing nm]
[Iden [Name Nothing "a"]]
ob)
mkSimpleAgg nm =
[(nm ++ "(a)",App [Name Nothing nm] [Iden [Name Nothing "a"]])
,(nm ++ "(distinct a)"
[(nm <> "(a)",App [Name Nothing nm] [Iden [Name Nothing "a"]])
,(nm <> "(distinct a)"
,AggregateApp [Name Nothing nm]
Distinct
[Iden [Name Nothing "a"]] [] Nothing)]
mkBsf nm =
[(nm ++ "(a,b)",App [Name Nothing nm] [Iden [Name Nothing "a"],Iden [Name Nothing "b"]])
,(nm ++"(a,b) filter (where something > 5)"
[(nm <> "(a,b)",App [Name Nothing nm] [Iden [Name Nothing "a"],Iden [Name Nothing "b"]])
,(nm <> "(a,b) filter (where something > 5)"
,AggregateApp [Name Nothing nm]
SQDefault
[Iden [Name Nothing "a"],Iden [Name Nothing "b"]] [] fil)]

View file

@ -5,6 +5,7 @@ Section 11 in Foundation
This module covers the tests for parsing schema and DDL statements.
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.SQL2011Schema (sql2011SchemaTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -1,11 +1,14 @@
-- Tests for parsing scalar expressions
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.ScalarExprs (scalarExprTests) where
import Language.SQL.SimpleSQL.TestTypes
import Language.SQL.SimpleSQL.Syntax
import qualified Data.Text as T
scalarExprTests :: TestItem
scalarExprTests = Group "scalarExprTests"
[literals
@ -428,5 +431,5 @@ functionsWithReservedNames = Group "functionsWithReservedNames" $ map t
,"char_length"
]
where
t fn = TestScalarExpr ansi2011 (fn ++ "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]
t fn = TestScalarExpr ansi2011 (fn <> "(a)") $ App [Name Nothing fn] [Iden [Name Nothing "a"]]

View file

@ -4,6 +4,7 @@ These are the tests for parsing focusing on the from part of query
expression
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.TableRefs (tableRefTests) where
import Language.SQL.SimpleSQL.TestTypes

View file

@ -22,11 +22,11 @@ mentioned give a parse error. Not sure if this will be too awkward due
to lots of tricky exceptions/variationsx.
-}
data TestItem = Group String [TestItem]
| TestScalarExpr Dialect String ScalarExpr
| TestQueryExpr Dialect String QueryExpr
| TestStatement Dialect String Statement
| TestStatements Dialect String [Statement]
data TestItem = Group Text [TestItem]
| TestScalarExpr Dialect Text ScalarExpr
| TestQueryExpr Dialect Text QueryExpr
| TestStatement Dialect Text Statement
| TestStatements Dialect Text [Statement]
{-
this just checks the sql parses without error, mostly just a
@ -34,12 +34,12 @@ intermediate when I'm too lazy to write out the parsed AST. These
should all be TODO to convert to a testqueryexpr test.
-}
| ParseQueryExpr Dialect String
| ParseQueryExpr Dialect Text
-- check that the string given fails to parse
| ParseQueryExprFails Dialect String
| ParseScalarExprFails Dialect String
| ParseQueryExprFails Dialect Text
| ParseScalarExprFails Dialect Text
| LexTest Dialect Text [Token]
| LexFails Dialect String
| LexFails Dialect Text
deriving (Eq,Show)

View file

@ -87,7 +87,7 @@ tests = itemToTest testData
itemToTest :: TestItem -> T.TestTree
itemToTest (Group nm ts) =
T.testGroup nm $ map itemToTest 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) =
@ -116,65 +116,64 @@ makeLexerTest d s ts = H.testCase (T.unpack s) $ do
let s' = Lex.prettyTokens d $ ts1
H.assertEqual "pretty print" s s'
makeLexingFailsTest :: Dialect -> String -> T.TestTree
makeLexingFailsTest d s = H.testCase s $ do
makeLexingFailsTest :: Dialect -> Text -> T.TestTree
makeLexingFailsTest d s = H.testCase (T.unpack s) $ do
undefined {-case lexSQL d "" Nothing s of
Right x -> H.assertFailure $ "lexing should have failed: " ++ s ++ "\ngot: " ++ show x
Left _ -> return ()-}
toTest :: (Eq a, Show a) =>
(Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
-> (Dialect -> a -> String)
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> String
-> Text
-> a
-> T.TestTree
toTest parser pp d str expected = H.testCase str $ do
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 $ peFormattedError e
Left e -> H.assertFailure $ T.unpack $ prettyError e
Right got -> do
H.assertEqual "" expected got
let str' = pp d got
let egot' = parser d "" Nothing str'
case egot' of
Left e' -> H.assertFailure $ "pp roundtrip"
++ "\n" ++ str'
++ peFormattedError e'
++ "\n" ++ (T.unpack str')
++ (T.unpack $ prettyError e')
Right got' -> H.assertEqual
("pp roundtrip" ++ "\n" ++ str')
("pp roundtrip" ++ "\n" ++ T.unpack str')
expected got'
toPTest :: (Eq a, Show a) =>
(Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
-> (Dialect -> a -> String)
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> String
-> Text
-> T.TestTree
toPTest parser pp d str = H.testCase str $ do
toPTest parser pp d str = H.testCase (T.unpack str) $ do
let egot = parser d "" Nothing str
case egot of
Left e -> H.assertFailure $ peFormattedError e
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" ++ str' ++ "\n"
++ peFormattedError e'
++ "\n" ++ T.unpack str' ++ "\n"
++ T.unpack (prettyError e')
Right _got' -> return ()
toFTest :: (Eq a, Show a) =>
(Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
-> (Dialect -> a -> String)
(Dialect -> Text -> Maybe (Int,Int) -> Text -> Either ParseError a)
-> (Dialect -> a -> Text)
-> Dialect
-> String
-> Text
-> T.TestTree
toFTest parser _pp d str = H.testCase str $ do
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" ++ str
H.assertFailure $ "parse didn't fail: " ++ show d ++ "\n" ++ T.unpack str

View file

@ -8,16 +8,19 @@ The changes made to the official syntax are:
using a common table expression
-}
{-# LANGUAGE OverloadedStrings #-}
module Language.SQL.SimpleSQL.Tpch (tpchTests,tpchQueries) where
import Language.SQL.SimpleSQL.TestTypes
import Data.Text (Text)
tpchTests :: TestItem
tpchTests =
Group "parse tpch"
$ map (ParseQueryExpr ansi2011 . snd) tpchQueries
tpchQueries :: [(String,String)]
tpchQueries :: [(String,Text)]
tpchQueries =
[("Q1","\n\
\select\n\

View file

@ -7,20 +7,30 @@ Commands:
parse: parse sql from file, stdin or from command line
lex: lex sql same
indent: parse then pretty print sql
TODO: this is supposed to be a simple example, but it's a total mess
write some simple helpers so it's all in text?
-}
{-# LANGUAGE TupleSections #-}
import System.Environment
import Control.Monad
import Data.Maybe
import System.Exit
import Data.List
import Text.Show.Pretty
import System.Environment (getArgs)
import Control.Monad (forM_, when)
import Data.Maybe (isJust)
import System.Exit (exitFailure)
import Data.List (intercalate)
import Text.Show.Pretty (ppShow)
--import Control.Applicative
import qualified Data.Text as T
import Language.SQL.SimpleSQL.Pretty
(prettyStatements)
import Language.SQL.SimpleSQL.Parse
import Language.SQL.SimpleSQL.Lex
(parseStatements
,prettyError)
import qualified Language.SQL.SimpleSQL.Lex as L
import Language.SQL.SimpleSQL.Dialect (ansi2011)
main :: IO ()
@ -67,9 +77,9 @@ parseCommand =
("parse SQL from file/stdin/command line (use -c to parse from command line)"
,\args -> do
(f,src) <- getInput args
either (error . peFormattedError)
either (error . T.unpack . prettyError)
(putStrLn . ppShow)
$ parseStatements ansi2011 f Nothing src
$ parseStatements ansi2011 (T.pack f) Nothing (T.pack src)
)
lexCommand :: (String,[String] -> IO ())
@ -77,9 +87,9 @@ lexCommand =
("lex SQL from file/stdin/command line (use -c to parse from command line)"
,\args -> do
(f,src) <- getInput args
either (error . peFormattedError)
either (error . T.unpack . L.prettyError)
(putStrLn . intercalate ",\n" . map show)
$ lexSQL ansi2011 f Nothing src
$ L.lexSQL ansi2011 (T.pack f) Nothing (T.pack src)
)
@ -88,8 +98,8 @@ indentCommand =
("parse then pretty print SQL from file/stdin/command line (use -c to parse from command line)"
,\args -> do
(f,src) <- getInput args
either (error . peFormattedError)
(putStrLn . prettyStatements ansi2011)
$ parseStatements ansi2011 f Nothing src
either (error . T.unpack . prettyError)
(putStrLn . T.unpack . prettyStatements ansi2011)
$ parseStatements ansi2011 (T.pack f) Nothing (T.pack src)
)