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,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\