checkpoint during parser conversion to megaparsec
This commit is contained in:
parent
9396aa8cba
commit
ab687318fb
31 changed files with 633 additions and 1186 deletions
tools/Language/SQL/SimpleSQL
|
@ -1,4 +1,5 @@
|
|||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.CreateIndex where
|
||||
|
||||
import Language.SQL.SimpleSQL.Syntax
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.CustomDialect (customDialectTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.EmptyStatement where
|
||||
|
||||
import Language.SQL.SimpleSQL.Syntax
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
-- Some tests for parsing full queries.
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.FullQueries (fullQueriesTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
-- Tests for mysql dialect parsing
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.MySQL (mySQLTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.Odbc (odbcTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
-- Tests for oracle dialect parsing
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.Oracle (oracleTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -6,6 +6,7 @@ grant, etc
|
|||
-}
|
||||
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.SQL2011AccessControl (sql2011AccessControlTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
-- Section 14 in Foundation
|
||||
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Language.SQL.SimpleSQL.SQL2011DataManipulation (sql2011DataManipulationTests) where
|
||||
|
||||
import Language.SQL.SimpleSQL.TestTypes
|
||||
|
|
|
@ -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)]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"]]
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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\
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue