starlitcanopy/simple-sql-parser
1
Fork 0
Code Activity

start on dialect prototype code

Browse source
This commit is contained in:
Jake Wheat 2014-06-27 12:19:15 +03:00
parent 7914898cc8
commit 7d63c8f8e5
18 changed files with 207 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
Language/SQL/SimpleSQL/Parser.lhs
View file

@ -204,11 +204,13 @@ fixing them in the syntax but leaving them till the semantic checking
= Public API
> -- | Parses a query expr, trailing semicolon optional.
> parseQueryExpr :: FilePath
> -- ^ filename to use in errors
> parseQueryExpr :: Dialect
> -- ^ dialect of SQL to use
> -> FilePath
> -- ^ filename to use in error messages
> -> Maybe (Int,Int)
> -- ^ line number and column number of the first character
> -- in the source (to use in errors)
> -- in the source to use in error messages
> -> String
> -- ^ the SQL source to parse
> -> Either ParseError QueryExpr
@ -216,22 +218,26 @@ fixing them in the syntax but leaving them till the semantic checking
> -- | Parses a list of query expressions, with semi colons between
> -- them. The final semicolon is optional.
> parseQueryExprs :: FilePath
> -- ^ filename to use in errors
> parseQueryExprs :: Dialect
> -- ^ dialect of SQL to use
> -> FilePath
> -- ^ filename to use in error messages
> -> Maybe (Int,Int)
> -- ^ line number and column number of the first character
> -- in the source (to use in errors)
> -- in the source to use in error messages
> -> String
> -- ^ the SQL source to parse
> -> Either ParseError [QueryExpr]
> parseQueryExprs = wrapParse queryExprs
> -- | Parses a value expression.
> parseValueExpr :: FilePath
> -- ^ filename to use in errors
> parseValueExpr :: Dialect
> -- ^ dialect of SQL to use
> -> FilePath
> -- ^ filename to use in error messages
> -> Maybe (Int,Int)
> -- ^ line number and column number of the first character
> -- in the source (to use in errors)
> -- in the source to use in error messages
> -> String
> -- ^ the SQL source to parse
> -> Either ParseError ValueExpr
@ -245,11 +251,12 @@ checks the parser parses all the input using eof
converts the error return to the nice wrapper
> wrapParse :: Parser a
> -> Dialect
> -> FilePath
> -> Maybe (Int,Int)
> -> String
> -> Either ParseError a
> wrapParse parser f p src =
> wrapParse parser _ f p src =
> either (Left . convParseError src) Right
> $ parse (setPos p *> whitespace *> parser <* eof) f src
> where
@ -296,7 +303,12 @@ u&"example quoted"
> name :: Parser Name
> name = choice [QName <$> quotedIdentifier
> ,UQName <$> uquotedIdentifier
> ,Name <$> identifierBlacklist blacklist]
> ,Name <$> identifierBlacklist blacklist
> ,dqName]
> where
> dqName = lexeme (DQName "`" "`"
> <$> (char '`'
> *> manyTill anyChar (char '`')))
todo: replace (:[]) with a named function all over
@ -1289,10 +1301,13 @@ allows offset and fetch in either order
> ,keyword_ "row"])
> fetch :: Parser ValueExpr
> fetch = fs *> valueExpr <* ro
> fetch = fetchFirst <|> limit
> where
> fetchFirst = fs *> valueExpr <* ro
> fs = makeKeywordTree ["fetch first", "fetch next"]
> ro = makeKeywordTree ["rows only", "row only"]
> -- todo: not in ansi sql dialect
> limit = keyword_ "limit" *> valueExpr
== common table expressions
@ -1971,4 +1986,6 @@ means).
> ,"within"
> ,"without"
> --,"year"
> -- added for mysql dialect, todo: make dialect specific lists
> ,"limit"
> ]

13
Language/SQL/SimpleSQL/Pretty.lhs
View file

@ -19,17 +19,17 @@ which have been changed to try to improve the layout of the output.
> import Data.List (intercalate)
> -- | Convert a query expr ast to concrete syntax.
> prettyQueryExpr :: QueryExpr -> String
> prettyQueryExpr = render . queryExpr
> prettyQueryExpr :: Dialect -> QueryExpr -> String
> prettyQueryExpr _ = render . queryExpr
> -- | Convert a value expr ast to concrete syntax.
> prettyValueExpr :: ValueExpr -> String
> prettyValueExpr = render . valueExpr
> prettyValueExpr :: Dialect -> ValueExpr -> String
> prettyValueExpr _ = render . valueExpr
> -- | Convert a list of query exprs to concrete syntax. A semi colon
> -- is inserted after each query expr.
> prettyQueryExprs :: [QueryExpr] -> String
> prettyQueryExprs = render . vcat . map ((<> text ";\n") . queryExpr)
> prettyQueryExprs :: Dialect -> [QueryExpr] -> String
> prettyQueryExprs _ = render . vcat . map ((<> text ";\n") . queryExpr)
= value expressions
@ -248,6 +248,7 @@ which have been changed to try to improve the layout of the output.
> name (UQName n) =
> text "U&" <> doubleQuotes (text $ doubleUpDoubleQuotes n)
> name (Name n) = text n
> name (DQName s e n) = text s <> text n <> text e
> names :: [Name] -> Doc
> names ns = hcat $ punctuate (text ".") $ map name ns

11
Language/SQL/SimpleSQL/Syntax.lhs
View file

@ -30,6 +30,8 @@
> ,TableRef(..)
> ,JoinType(..)
> ,JoinCondition(..)
> -- * dialect
> ,Dialect(..)
> ) where
> import Data.Data
@ -165,6 +167,8 @@
> data Name = Name String
> | QName String
> | UQName String
> | DQName String String String
> -- ^ dialect quoted name, the fields are start quote, end quote and the string itself, e.g. `something` is parsed to DQName "`" "`" "something, and $a$ test $a$ is parsed to DQName "$a$" "$a" " test "
> deriving (Eq,Show,Read,Data,Typeable)
> -- | Represents a type name, used in casts.
@ -372,3 +376,10 @@ I'm not sure if this is valid syntax or not.
> data JoinCondition = JoinOn ValueExpr -- ^ on expr
> | JoinUsing [Name] -- ^ using (column list)
> deriving (Eq,Show,Read,Data,Typeable)
> -- | Used to set the dialect used for parsing and pretty printing,
> -- very unfinished at the moment.
> data Dialect = SQL2011
> | MySQL
> deriving (Eq,Show,Read,Data,Typeable)

7
TODO
View file

@ -1,8 +1,13 @@
work on reasonable subset of sql which is similar to the current
subset and smaller than the complete 2011 target
prototype for dialect handling
prototype for dialect handling, todo:
add test which test for failure
test that mysql specific syntax fails on ansi mode
and that the ansi equivalents of the mysql specific syntax which
has been implemented fail in mysql mode
position annotation
simple stuff for error message and pretty printing monitoring
work on the new refactoring of the parser
create a new module for generic combinators

5
changelog
View file

@ -1,8 +1,9 @@
If you need help updating to a new version of simple-sql-parser,
please email jakewheatmail@gmail.com or use the github bug tracker,
https://github.com/JakeWheat/simple-sql-parser/issues.
0.4.0 (updated to dbd48baaa1d1bce3d0d0139b8ffe55370fabe672)
0.4.1 (unreleased)
simple demonstration of how dialects could be handled internally
0.4.0 (commit 7914898cc8f07bbaf8358d208469392346341964)
now targets SQL:2011
update to ghc 7.8.2
remove dependency on haskell-src-exts

3
simple-sql-parser.cabal
View file

@ -1,5 +1,5 @@
name: simple-sql-parser
version: 0.4.0
version: 0.4.1
synopsis: A parser for SQL queries
description: A parser for SQL queries. Parses most SQL:2011
@ -64,6 +64,7 @@ Test-Suite Tests
Language.SQL.SimpleSQL.ErrorMessages,
Language.SQL.SimpleSQL.FullQueries,
Language.SQL.SimpleSQL.GroupBy,
Language.SQL.SimpleSQL.MySQL,
Language.SQL.SimpleSQL.Postgres,
Language.SQL.SimpleSQL.QueryExprComponents,
Language.SQL.SimpleSQL.QueryExprs,

2
tools/Language/SQL/SimpleSQL/FullQueries.lhs
View file

@ -8,7 +8,7 @@ Some tests for parsing full queries.
> fullQueriesTests :: TestItem
> fullQueriesTests = Group "queries" $ map (uncurry TestQueryExpr)
> fullQueriesTests = Group "queries" $ map (uncurry (TestQueryExpr SQL2011))
> [("select count(*) from t"
> ,makeSelect
> {qeSelectList = [(App [Name "count"] [Star], Nothing)]

6
tools/Language/SQL/SimpleSQL/GroupBy.lhs
View file

@ -15,7 +15,7 @@ Here are the tests for the group by component of query exprs
> ]
> simpleGroupBy :: TestItem
> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry TestQueryExpr)
> simpleGroupBy = Group "simpleGroupBy" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a,sum(b) from t group by a"
> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)
> ,(App [Name "sum"] [Iden [Name "b"]],Nothing)]
@ -37,7 +37,7 @@ test the new group by (), grouping sets, cube and rollup syntax (not
sure which sql version they were introduced, 1999 or 2003 I think).
> newGroupBy :: TestItem
> newGroupBy = Group "newGroupBy" $ map (uncurry TestQueryExpr)
> newGroupBy = Group "newGroupBy" $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from t group by ()", ms [GroupingParens []])
> ,("select * from t group by grouping sets ((), (a))"
> ,ms [GroupingSets [GroupingParens []
@ -53,7 +53,7 @@ sure which sql version they were introduced, 1999 or 2003 I think).
> ,qeGroupBy = g}
> randomGroupBy :: TestItem
> randomGroupBy = Group "randomGroupBy" $ map ParseQueryExpr
> randomGroupBy = Group "randomGroupBy" $ map (ParseQueryExpr SQL2011)
> ["select * from t GROUP BY a"
> ,"select * from t GROUP BY GROUPING SETS((a))"
> ,"select * from t GROUP BY a,b,c"

36
tools/Language/SQL/SimpleSQL/MySQL.lhs Normal file
View file

@ -0,0 +1,36 @@
Tests for mysql dialect parsing
> module Language.SQL.SimpleSQL.MySQL (mySQLTests) where
> import Language.SQL.SimpleSQL.TestTypes
> import Language.SQL.SimpleSQL.Syntax
> mySQLTests :: TestItem
> mySQLTests = Group "mysql dialect"
> [backtickQuotes
> ,limit]
backtick quotes
limit syntax
[LIMIT {[offset,] row_count | row_count OFFSET offset}]
> backtickQuotes :: TestItem
> backtickQuotes = Group "backtickQuotes" $ map (uncurry (TestValueExpr MySQL))
> [("`test`", Iden [DQName "`" "`" "test"])
> ]
> limit :: TestItem
> limit = Group "queries" $ map (uncurry (TestQueryExpr MySQL))
> [("select * from t limit 5"
> ,sel {qeFetchFirst = Just (NumLit "5")}
> )
> ]
> where
> sel = makeSelect
> {qeSelectList = [(Star, Nothing)]
> ,qeFrom = [TRSimple [Name "t"]]
> }

3
tools/Language/SQL/SimpleSQL/Postgres.lhs
View file

@ -6,10 +6,9 @@ revisited when the dialect support is added.
> module Language.SQL.SimpleSQL.Postgres (postgresTests) where
> import Language.SQL.SimpleSQL.TestTypes
> --import Language.SQL.SimpleSQL.Syntax
> postgresTests :: TestItem
> postgresTests = Group "postgresTests" $ map ParseQueryExpr
> postgresTests = Group "postgresTests" $ map (ParseQueryExpr SQL2011)
lexical syntax section

20
tools/Language/SQL/SimpleSQL/QueryExprComponents.lhs
View file

@ -28,7 +28,7 @@ These are a few misc tests which don't fit anywhere else.
> duplicates :: TestItem
> duplicates = Group "duplicates" $ map (uncurry TestQueryExpr)
> duplicates = Group "duplicates" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t" ,ms SQDefault)
> ,("select all a from t" ,ms All)
> ,("select distinct a from t", ms Distinct)
@ -40,7 +40,7 @@ These are a few misc tests which don't fit anywhere else.
> ,qeFrom = [TRSimple [Name "t"]]}
> selectLists :: TestItem
> selectLists = Group "selectLists" $ map (uncurry TestQueryExpr)
> selectLists = Group "selectLists" $ map (uncurry (TestQueryExpr SQL2011))
> [("select 1",
> makeSelect {qeSelectList = [(NumLit "1",Nothing)]})
@ -73,7 +73,7 @@ These are a few misc tests which don't fit anywhere else.
> ]
> whereClause :: TestItem
> whereClause = Group "whereClause" $ map (uncurry TestQueryExpr)
> whereClause = Group "whereClause" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t where a = 5"
> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)]
> ,qeFrom = [TRSimple [Name "t"]]
@ -81,7 +81,7 @@ These are a few misc tests which don't fit anywhere else.
> ]
> having :: TestItem
> having = Group "having" $ map (uncurry TestQueryExpr)
> having = Group "having" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a,sum(b) from t group by a having sum(b) > 5"
> ,makeSelect {qeSelectList = [(Iden [Name "a"],Nothing)
> ,(App [Name "sum"] [Iden [Name "b"]],Nothing)]
@ -93,7 +93,7 @@ These are a few misc tests which don't fit anywhere else.
> ]
> orderBy :: TestItem
> orderBy = Group "orderBy" $ map (uncurry TestQueryExpr)
> orderBy = Group "orderBy" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t order by a"
> ,ms [SortSpec (Iden [Name "a"]) DirDefault NullsOrderDefault])
@ -119,7 +119,7 @@ These are a few misc tests which don't fit anywhere else.
> ,qeOrderBy = o}
> offsetFetch :: TestItem
> offsetFetch = Group "offsetFetch" $ map (uncurry TestQueryExpr)
> offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr SQL2011))
> [-- ansi standard
> ("select a from t offset 5 rows fetch next 10 rows only"
> ,ms (Just $ NumLit "5") (Just $ NumLit "10"))
@ -142,7 +142,7 @@ These are a few misc tests which don't fit anywhere else.
> ,qeFetchFirst = l}
> combos :: TestItem
> combos = Group "combos" $ map (uncurry TestQueryExpr)
> combos = Group "combos" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t union select b from u"
> ,CombineQueryExpr ms1 Union SQDefault Respectively ms2)
@ -173,7 +173,7 @@ These are a few misc tests which don't fit anywhere else.
> withQueries :: TestItem
> withQueries = Group "with queries" $ map (uncurry TestQueryExpr)
> withQueries = Group "with queries" $ map (uncurry (TestQueryExpr SQL2011))
> [("with u as (select a from t) select a from u"
> ,With False [(Alias (Name "u") Nothing, ms1)] ms2)
@ -197,13 +197,13 @@ These are a few misc tests which don't fit anywhere else.
> ms3 = ms "a" "x"
> values :: TestItem
> values = Group "values" $ map (uncurry TestQueryExpr)
> values = Group "values" $ map (uncurry (TestQueryExpr SQL2011))
> [("values (1,2),(3,4)"
> ,Values [[NumLit "1", NumLit "2"]
> ,[NumLit "3", NumLit "4"]])
> ]
> tables :: TestItem
> tables = Group "tables" $ map (uncurry TestQueryExpr)
> tables = Group "tables" $ map (uncurry (TestQueryExpr SQL2011))
> [("table tbl", Table [Name "tbl"])
> ]

2
tools/Language/SQL/SimpleSQL/QueryExprs.lhs
View file

@ -8,7 +8,7 @@ query expressions from one string.
> import Language.SQL.SimpleSQL.Syntax
> queryExprsTests :: TestItem
> queryExprsTests = Group "query exprs" $ map (uncurry TestQueryExprs)
> queryExprsTests = Group "query exprs" $ map (uncurry (TestQueryExprs SQL2011))
> [("select 1",[ms])
> ,("select 1;",[ms])
> ,("select 1;select 1",[ms,ms])

96
tools/Language/SQL/SimpleSQL/SQL2011.lhs
View file

@ -482,7 +482,7 @@ Specify a non-null value.
> characterStringLiterals :: TestItem
> characterStringLiterals = Group "character string literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("'a regular string literal'"
> ,StringLit "a regular string literal")
> ,("'something' ' some more' 'and more'"
@ -510,7 +510,7 @@ character set allows them.
> nationalCharacterStringLiterals :: TestItem
> nationalCharacterStringLiterals = Group "national character string literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("N'something'", CSStringLit "N" "something")
> ,("n'something'", CSStringLit "n" "something")
> ]
@ -527,7 +527,7 @@ character set allows them.
> unicodeCharacterStringLiterals :: TestItem
> unicodeCharacterStringLiterals = Group "unicode character string literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("U&'something'", CSStringLit "U&" "something")
> ,("u&'something' escape ="
> ,Escape (CSStringLit "u&" "something") '=')
@ -546,7 +546,7 @@ TODO: unicode escape
> binaryStringLiterals :: TestItem
> binaryStringLiterals = Group "binary string literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [--("B'101010'", CSStringLit "B" "101010")
> ("X'7f7f7f'", CSStringLit "X" "7f7f7f")
> ,("X'7f7f7f' escape z", Escape (CSStringLit "X" "7f7f7f") 'z')
@ -576,7 +576,7 @@ TODO: unicode escape
> numericLiterals :: TestItem
> numericLiterals = Group "numeric literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("11", NumLit "11")
> ,("11.11", NumLit "11.11")
@ -682,7 +682,7 @@ TODO: unicode escape
> intervalLiterals :: TestItem
> intervalLiterals = Group "intervalLiterals literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("interval '1'", TypedLit (TypeName [Name "interval"]) "1")
> ,("interval '1' day"
> ,IntervalLit Nothing "1" (Itf "day" Nothing) Nothing)
@ -705,7 +705,7 @@ TODO: unicode escape
> booleanLiterals :: TestItem
> booleanLiterals = Group "boolean literals"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("true", Iden [Name "true"])
> ,("false", Iden [Name "false"])
> ,("unknown", Iden [Name "unknown"])
@ -725,7 +725,7 @@ Specify names.
> identifiers :: TestItem
> identifiers = Group "identifiers"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("test",Iden [Name "test"])
> ,("_test",Iden [Name "_test"])
> ,("t1",Iden [Name "t1"])
@ -1166,7 +1166,7 @@ Now test each variation in both cast expression and typed literal
expression
> typeNameTests :: TestItem
> typeNameTests = Group "type names" $ map (uncurry TestValueExpr)
> typeNameTests = Group "type names" $ map (uncurry (TestValueExpr SQL2011))
> $ concatMap makeTests typeNames
> where
> makeTests (ctn, stn) =
@ -1184,7 +1184,7 @@ Define a field of a row type.
> fieldDefinition :: TestItem
> fieldDefinition = Group "field definition"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("cast('(1,2)' as row(a int,b char))"
> ,Cast (StringLit "(1,2)")
> $ RowTypeName [(Name "a", TypeName [Name "int"])
@ -1264,7 +1264,7 @@ Specify a value that is syntactically self-delimited.
> parenthesizedValueExpression :: TestItem
> parenthesizedValueExpression = Group "parenthesized value expression"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("(3)", Parens (NumLit "3"))
> ,("((3))", Parens $ Parens (NumLit "3"))
> ]
@ -1300,7 +1300,7 @@ Specify one or more values, host parameters, SQL parameters, dynamic parameters,
> generalValueSpecification :: TestItem
> generalValueSpecification = Group "general value specification"
> $ map (uncurry TestValueExpr) $
> $ map (uncurry (TestValueExpr SQL2011)) $
> map mkIden ["CURRENT_DEFAULT_TRANSFORM_GROUP"
> ,"CURRENT_PATH"
> ,"CURRENT_ROLE"
@ -1354,7 +1354,7 @@ TODO: add the missing bits
> parameterSpecification :: TestItem
> parameterSpecification = Group "parameter specification"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [(":hostparam", HostParameter "hostparam" Nothing)
> ,(":hostparam indicator :another_host_param"
> ,HostParameter "hostparam" $ Just "another_host_param")
@ -1391,7 +1391,7 @@ Specify a value whose data type is to be inferred from its context.
> contextuallyTypedValueSpecification :: TestItem
> contextuallyTypedValueSpecification =
> Group "contextually typed value specification"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("null", Iden [Name "null"])
> ,("array[]", Array (Iden [Name "array"]) [])
> ,("multiset[]", MultisetCtor [])
@ -1409,7 +1409,7 @@ Disambiguate a <period>-separated chain of identifiers.
> identifierChain :: TestItem
> identifierChain = Group "identifier chain"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a.b", Iden [Name "a",Name "b"])]
== 6.7 <column reference>
@ -1423,7 +1423,7 @@ Reference a column.
> columnReference :: TestItem
> columnReference = Group "column reference"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("module.a.b", Iden [Name "module",Name "a",Name "b"])]
== 6.8 <SQL parameter reference>
@ -1446,7 +1446,7 @@ Specify a value derived by the application of a function to an argument.
> setFunctionSpecification :: TestItem
> setFunctionSpecification = Group "set function specification"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("SELECT SalesQuota, SUM(SalesYTD) TotalSalesYTD,\n\
> \ GROUPING(SalesQuota) AS Grouping\n\
> \FROM Sales.SalesPerson\n\
@ -1647,7 +1647,7 @@ Specify a data conversion.
> castSpecification :: TestItem
> castSpecification = Group "cast specification"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("cast(a as int)"
> ,Cast (Iden [Name "a"]) (TypeName [Name "int"]))
> ]
@ -1661,7 +1661,7 @@ Return the next value of a sequence generator.
> nextValueExpression :: TestItem
> nextValueExpression = Group "next value expression"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("next value for a.b", NextValueFor [Name "a", Name "b"])
> ]
@ -1674,7 +1674,7 @@ Reference a field of a row value.
> fieldReference :: TestItem
> fieldReference = Group "field reference"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("f(something).a"
> ,BinOp (App [Name "f"] [Iden [Name "something"]])
> [Name "."]
@ -1798,7 +1798,7 @@ Return an element of an array.
> arrayElementReference :: TestItem
> arrayElementReference = Group "array element reference"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("something[3]"
> ,Array (Iden [Name "something"]) [NumLit "3"])
> ,("(something(a))[x]"
@ -1821,7 +1821,7 @@ Return the sole element of a multiset of one element.
> multisetElementReference :: TestItem
> multisetElementReference = Group "multisetElementReference"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("element(something)"
> ,App [Name "element"] [Iden [Name "something"]])
> ]
@ -1871,7 +1871,7 @@ Specify a numeric value.
> numericValueExpression :: TestItem
> numericValueExpression = Group "numeric value expression"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a + b", binOp "+")
> ,("a - b", binOp "-")
> ,("a * b", binOp "*")
@ -2328,7 +2328,7 @@ Specify a boolean value.
> booleanValueExpression :: TestItem
> booleanValueExpression = Group "booleab value expression"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a or b", BinOp a [Name "or"] b)
> ,("a and b", BinOp a [Name "and"] b)
> ,("not a", PrefixOp [Name "not"] a)
@ -2403,7 +2403,7 @@ Specify construction of an array.
> arrayValueConstructor :: TestItem
> arrayValueConstructor = Group "array value constructor"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("array[1,2,3]"
> ,Array (Iden [Name "array"])
> [NumLit "1", NumLit "2", NumLit "3"])
@ -2441,7 +2441,7 @@ Specify a multiset value.
> multisetValueExpression :: TestItem
> multisetValueExpression = Group "multiset value expression"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a multiset union b"
> ,MultisetBinOp (Iden [Name "a"]) Union SQDefault (Iden [Name "b"]))
> ,("a multiset union all b"
@ -2468,7 +2468,7 @@ Specify a function yielding a value of a multiset type.
> multisetValueFunction :: TestItem
> multisetValueFunction = Group "multiset value function"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("set(a)", App [Name "set"] [Iden [Name "a"]])
> ]
@ -2496,7 +2496,7 @@ Specify construction of a multiset.
> multisetValueConstructor :: TestItem
> multisetValueConstructor = Group "multiset value constructor"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("multiset[a,b,c]", MultisetCtor[Iden [Name "a"]
> ,Iden [Name "b"], Iden [Name "c"]])
> ,("multiset(select * from t)", MultisetQueryCtor qe)
@ -2574,7 +2574,7 @@ Specify a value or list of values to be constructed into a row.
> rowValueConstructor :: TestItem
> rowValueConstructor = Group "row value constructor"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("(a,b)"
> ,SpecialOp [Name "rowctor"] [Iden [Name "a"], Iden [Name "b"]])
> ,("row(1)",App [Name "row"] [NumLit "1"])
@ -2625,7 +2625,7 @@ Specify a set of <row value expression>s to be constructed into a table.
> tableValueConstructor :: TestItem
> tableValueConstructor = Group "table value constructor"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("values (1,2), (a+b,(select count(*) from t));"
> ,Values [[NumLit "1", NumLit "2"]
> ,[BinOp (Iden [Name "a"]) [Name "+"]
@ -2660,7 +2660,7 @@ Specify a table derived from one or more tables.
> fromClause :: TestItem
> fromClause = Group "fromClause"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from tbl1,tbl2"
> ,makeSelect
> {qeSelectList = [(Star, Nothing)]
@ -2675,7 +2675,7 @@ Reference a table.
> tableReference :: TestItem
> tableReference = Group "table reference"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from t", sel)
<table reference> ::= <table factor> | <joined table>
@ -2856,7 +2856,7 @@ Specify a table derived from a Cartesian product, inner join, or outer join.
> joinedTable :: TestItem
> joinedTable = Group "joined table"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from a cross join b"
> ,sel $ TRJoin a False JCross b Nothing)
> ,("select * from a join b on true"
@ -2913,7 +2913,7 @@ the result of the preceding <from clause>.
> whereClause :: TestItem
> whereClause = Group "where clause"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from t where a = 5"
> ,makeSelect
> {qeSelectList = [(Star,Nothing)]
@ -2973,7 +2973,7 @@ clause> to the result of the previously specified clause.
> groupByClause :: TestItem
> groupByClause = Group "group by clause"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select a,sum(x) from t group by a"
> ,qe [SimpleGroup $ Iden [Name "a"]])
> ,("select a,sum(x) from t group by a collate c"
@ -3021,7 +3021,7 @@ not satisfy a <search condition>.
> havingClause :: TestItem
> havingClause = Group "having clause"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select a,sum(x) from t group by a having sum(x) > 1000"
> ,makeSelect
> {qeSelectList = [(Iden [Name "a"], Nothing)
@ -3144,7 +3144,7 @@ Specify a table derived from the result of a <table expression>.
> querySpecification :: TestItem
> querySpecification = Group "query specification"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t",qe)
> ,("select all a from t",qe {qeSetQuantifier = All})
> ,("select distinct a from t",qe {qeSetQuantifier = Distinct})
@ -3212,7 +3212,7 @@ Specify a table.
> setOpQueryExpression :: TestItem
> setOpQueryExpression= Group "set operation query expression"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> -- todo: complete setop query expression tests
> [{-("select * from t union select * from t"
> ,undefined)
@ -3249,7 +3249,7 @@ everywhere
> explicitTableQueryExpression :: TestItem
> explicitTableQueryExpression= Group "explicit table query expression"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("table t", Table [Name "t"])
> ]
@ -3271,7 +3271,7 @@ everywhere
> orderOffsetFetchQueryExpression :: TestItem
> orderOffsetFetchQueryExpression = Group "order, offset, fetch query expression"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [-- todo: finish tests for order offset and fetch
> ("select a from t order by a"
> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"])
@ -3428,7 +3428,7 @@ Specify a comparison of two row values.
> comparisonPredicates :: TestItem
> comparisonPredicates = Group "comparison predicates"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> $ map mkOp ["=", "<>", "<", ">", "<=", ">="]
> ++ [("ROW(a) = ROW(b)"
> ,BinOp (App [Name "ROW"] [a])
@ -3632,7 +3632,7 @@ Specify a quantified comparison.
> quantifiedComparisonPredicate :: TestItem
> quantifiedComparisonPredicate = Group "quantified comparison predicate"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a = any (select * from t)"
> ,QuantifiedComparison (Iden [Name "a"]) [Name "="] CPAny qe)
@ -3659,7 +3659,7 @@ Specify a test for a non-empty set.
> existsPredicate :: TestItem
> existsPredicate = Group "exists predicate"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("exists(select * from t where a = 4)"
> ,SubQueryExpr SqExists
> $ makeSelect
@ -3678,7 +3678,7 @@ Specify a test for the absence of duplicate rows.
> uniquePredicate :: TestItem
> uniquePredicate = Group "unique predicate"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("unique(select * from t where a = 4)"
> ,SubQueryExpr SqUnique
> $ makeSelect
@ -3714,7 +3714,7 @@ Specify a test for matching rows.
> matchPredicate :: TestItem
> matchPredicate = Group "match predicate"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a match (select a from t)"
> ,Match (Iden [Name "a"]) False qe)
> ,("(a,b) match (select a,b from t)"
@ -4066,7 +4066,7 @@ Specify a default collation.
> collateClause :: TestItem
> collateClause = Group "collate clause"
> $ map (uncurry TestValueExpr)
> $ map (uncurry (TestValueExpr SQL2011))
> [("a collate my_collation"
> ,Collate (Iden [Name "a"]) [Name "my_collation"])]
@ -4177,7 +4177,7 @@ Specify a value computed from a collection of rows.
> aggregateFunction :: TestItem
> aggregateFunction = Group "aggregate function"
> $ map (uncurry TestValueExpr) $
> $ map (uncurry (TestValueExpr SQL2011)) $
> [("count(*)",App [Name "count"] [Star])
> ,("count(*) filter (where something > 5)"
> ,AggregateApp [Name "count"] SQDefault [Star] [] fil)
@ -4272,7 +4272,7 @@ Specify a sort order.
> sortSpecificationList :: TestItem
> sortSpecificationList = Group "sort specification list"
> $ map (uncurry TestQueryExpr)
> $ map (uncurry (TestQueryExpr SQL2011))
> [("select * from t order by a"
> ,qe {qeOrderBy = [SortSpec (Iden [Name "a"])
> DirDefault NullsOrderDefault]})

2
tools/Language/SQL/SimpleSQL/TableRefs.lhs
View file

@ -9,7 +9,7 @@ expression
> tableRefTests :: TestItem
> tableRefTests = Group "tableRefTests" $ map (uncurry TestQueryExpr)
> tableRefTests = Group "tableRefTests" $ map (uncurry (TestQueryExpr SQL2011))
> [("select a from t"
> ,ms [TRSimple [Name "t"]])

12
tools/Language/SQL/SimpleSQL/TestTypes.lhs
View file

@ -2,18 +2,20 @@
This is the types used to define the tests as pure data. See the
Tests.lhs module for the 'interpreter'.
> module Language.SQL.SimpleSQL.TestTypes where
> module Language.SQL.SimpleSQL.TestTypes
> (TestItem(..)
> ,Dialect(..)) where
> import Language.SQL.SimpleSQL.Syntax
> data TestItem = Group String [TestItem]
> | TestValueExpr String ValueExpr
> | TestQueryExpr String QueryExpr
> | TestQueryExprs String [QueryExpr]
> | TestValueExpr Dialect String ValueExpr
> | TestQueryExpr Dialect String QueryExpr
> | TestQueryExprs Dialect String [QueryExpr]
this just checks the sql parses without error, mostly just a
intermediate when I'm too lazy to write out the parsed AST. These
should all be TODO to convert to a testqueryexpr test.
> | ParseQueryExpr String
> | ParseQueryExpr Dialect String
> deriving (Eq,Show)

45
tools/Language/SQL/SimpleSQL/Tests.lhs
View file

@ -30,6 +30,8 @@ test data to the Test.Framework tests.
> import Language.SQL.SimpleSQL.SQL2011
> import Language.SQL.SimpleSQL.MySQL
Order the tests to start from the simplest first. This is also the
order on the generated documentation.
@ -45,6 +47,7 @@ order on the generated documentation.
> ,postgresTests
> ,tpchTests
> ,sql2011Tests
> ,mySQLTests
> ]
> tests :: Test.Framework.Test
@ -56,29 +59,30 @@ order on the generated documentation.
> itemToTest :: TestItem -> Test.Framework.Test
> itemToTest (Group nm ts) =
> testGroup nm $ map itemToTest ts
> itemToTest (TestValueExpr str expected) =
> toTest parseValueExpr prettyValueExpr str expected
> itemToTest (TestQueryExpr str expected) =
> toTest parseQueryExpr prettyQueryExpr str expected
> itemToTest (TestQueryExprs str expected) =
> toTest parseQueryExprs prettyQueryExprs str expected
> itemToTest (ParseQueryExpr str) =
> toPTest parseQueryExpr prettyQueryExpr str
> itemToTest (TestValueExpr d str expected) =
> toTest parseValueExpr prettyValueExpr d str expected
> itemToTest (TestQueryExpr d str expected) =
> toTest parseQueryExpr prettyQueryExpr d str expected
> itemToTest (TestQueryExprs d str expected) =
> toTest parseQueryExprs prettyQueryExprs d str expected
> itemToTest (ParseQueryExpr d str) =
> toPTest parseQueryExpr prettyQueryExpr d str
> toTest :: (Eq a, Show a) =>
> (String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (a -> String)
> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (Dialect -> a -> String)
> -> Dialect
> -> String
> -> a
> -> Test.Framework.Test
> toTest parser pp str expected = testCase str $ do
> let egot = parser "" Nothing str
> toTest parser pp d str expected = testCase str $ do
> let egot = parser d "" Nothing str
> case egot of
> Left e -> H.assertFailure $ peFormattedError e
> Right got -> do
> H.assertEqual "" expected got
> let str' = pp got
> let egot' = parser "" Nothing str'
> let str' = pp d got
> let egot' = parser d "" Nothing str'
> case egot' of
> Left e' -> H.assertFailure $ "pp roundtrip"
> ++ "\n" ++ str'
@ -88,17 +92,18 @@ order on the generated documentation.
> expected got'
> toPTest :: (Eq a, Show a) =>
> (String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (a -> String)
> (Dialect -> String -> Maybe (Int,Int) -> String -> Either ParseError a)
> -> (Dialect -> a -> String)
> -> Dialect
> -> String
> -> Test.Framework.Test
> toPTest parser pp str = testCase str $ do
> let egot = parser "" Nothing str
> toPTest parser pp d str = testCase str $ do
> let egot = parser d "" Nothing str
> case egot of
> Left e -> H.assertFailure $ peFormattedError e
> Right got -> do
> let str' = pp got
> let egot' = parser "" Nothing str'
> let str' = pp d got
> let egot' = parser d "" Nothing str'
> case egot' of
> Left e' -> H.assertFailure $ "pp roundtrip "
> ++ "\n" ++ str' ++ "\n"

2
tools/Language/SQL/SimpleSQL/Tpch.lhs
View file

@ -13,7 +13,7 @@ The changes made to the official syntax are:
> tpchTests :: TestItem
> tpchTests =
> Group "parse tpch"
> $ map (ParseQueryExpr . snd) tpchQueries
> $ map (ParseQueryExpr SQL2011 . snd) tpchQueries
> tpchQueries :: [(String,String)]
> tpchQueries =

30
tools/Language/SQL/SimpleSQL/ValueExprs.lhs
View file

@ -23,7 +23,7 @@ Tests for parsing value expressions
> ]
> literals :: TestItem
> literals = Group "literals" $ map (uncurry TestValueExpr)
> literals = Group "literals" $ map (uncurry (TestValueExpr SQL2011))
> [("3", NumLit "3")
> ,("3.", NumLit "3.")
> ,("3.3", NumLit "3.3")
@ -45,27 +45,27 @@ Tests for parsing value expressions
> ]
> identifiers :: TestItem
> identifiers = Group "identifiers" $ map (uncurry TestValueExpr)
> identifiers = Group "identifiers" $ map (uncurry (TestValueExpr SQL2011))
> [("iden1", Iden [Name "iden1"])
> --,("t.a", Iden2 "t" "a")
> ,("\"quoted identifier\"", Iden [QName "quoted identifier"])
> ]
> star :: TestItem
> star = Group "star" $ map (uncurry TestValueExpr)
> star = Group "star" $ map (uncurry (TestValueExpr SQL2011))
> [("*", Star)
> --,("t.*", Star2 "t")
> --,("ROW(t.*,42)", App "ROW" [Star2 "t", NumLit "42"])
> ]
> parameter :: TestItem
> parameter = Group "parameter" $ map (uncurry TestValueExpr)
> parameter = Group "parameter" $ map (uncurry (TestValueExpr SQL2011))
> [("?", Parameter)
> ]
> dots :: TestItem
> dots = Group "dot" $ map (uncurry TestValueExpr)
> dots = Group "dot" $ map (uncurry (TestValueExpr SQL2011))
> [("t.a", Iden [Name "t",Name "a"])
> ,("t.*", BinOp (Iden [Name "t"]) [Name "."] Star)
> ,("a.b.c", Iden [Name "a",Name "b",Name "c"])
@ -73,14 +73,14 @@ Tests for parsing value expressions
> ]
> app :: TestItem
> app = Group "app" $ map (uncurry TestValueExpr)
> app = Group "app" $ map (uncurry (TestValueExpr SQL2011))
> [("f()", App [Name "f"] [])
> ,("f(a)", App [Name "f"] [Iden [Name "a"]])
> ,("f(a,b)", App [Name "f"] [Iden [Name "a"], Iden [Name "b"]])
> ]
> caseexp :: TestItem
> caseexp = Group "caseexp" $ map (uncurry TestValueExpr)
> caseexp = Group "caseexp" $ map (uncurry (TestValueExpr SQL2011))
> [("case a when 1 then 2 end"
> ,Case (Just $ Iden [Name "a"]) [([NumLit "1"]
> ,NumLit "2")] Nothing)
@ -116,7 +116,7 @@ Tests for parsing value expressions
> ,miscOps]
> binaryOperators :: TestItem
> binaryOperators = Group "binaryOperators" $ map (uncurry TestValueExpr)
> binaryOperators = Group "binaryOperators" $ map (uncurry (TestValueExpr SQL2011))
> [("a + b", BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"]))
> -- sanity check fixities
> -- todo: add more fixity checking
@ -131,7 +131,7 @@ Tests for parsing value expressions
> ]
> unaryOperators :: TestItem
> unaryOperators = Group "unaryOperators" $ map (uncurry TestValueExpr)
> unaryOperators = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011))
> [("not a", PrefixOp [Name "not"] $ Iden [Name "a"])
> ,("not not a", PrefixOp [Name "not"] $ PrefixOp [Name "not"] $ Iden [Name "a"])
> ,("+a", PrefixOp [Name "+"] $ Iden [Name "a"])
@ -140,7 +140,7 @@ Tests for parsing value expressions
> casts :: TestItem
> casts = Group "operators" $ map (uncurry TestValueExpr)
> casts = Group "operators" $ map (uncurry (TestValueExpr SQL2011))
> [("cast('1' as int)"
> ,Cast (StringLit "1") $ TypeName [Name "int"])
@ -162,7 +162,7 @@ Tests for parsing value expressions
> ]
> subqueries :: TestItem
> subqueries = Group "unaryOperators" $ map (uncurry TestValueExpr)
> subqueries = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011))
> [("exists (select a from t)", SubQueryExpr SqExists ms)
> ,("(select a from t)", SubQueryExpr SqSq ms)
@ -188,7 +188,7 @@ Tests for parsing value expressions
> }
> miscOps :: TestItem
> miscOps = Group "unaryOperators" $ map (uncurry TestValueExpr)
> miscOps = Group "unaryOperators" $ map (uncurry (TestValueExpr SQL2011))
> [("a in (1,2,3)"
> ,In True (Iden [Name "a"]) $ InList $ map NumLit ["1","2","3"])
@ -326,7 +326,7 @@ target_string
> ]
> aggregates :: TestItem
> aggregates = Group "aggregates" $ map (uncurry TestValueExpr)
> aggregates = Group "aggregates" $ map (uncurry (TestValueExpr SQL2011))
> [("count(*)",App [Name "count"] [Star])
> ,("sum(a order by a)"
@ -341,7 +341,7 @@ target_string
> ]
> windowFunctions :: TestItem
> windowFunctions = Group "windowFunctions" $ map (uncurry TestValueExpr)
> windowFunctions = Group "windowFunctions" $ map (uncurry (TestValueExpr SQL2011))
> [("max(a) over ()", WindowApp [Name "max"] [Iden [Name "a"]] [] [] Nothing)
> ,("count(*) over ()", WindowApp [Name "count"] [Star] [] [] Nothing)
@ -400,7 +400,7 @@ target_string
> ]
> parens :: TestItem
> parens = Group "parens" $ map (uncurry TestValueExpr)
> parens = Group "parens" $ map (uncurry (TestValueExpr SQL2011))
> [("(a)", Parens (Iden [Name "a"]))
> ,("(a + b)", Parens (BinOp (Iden [Name "a"]) [Name "+"] (Iden [Name "b"])))
> ]