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

add haddock, reorder the fields in binop and jointref to be more natural

Browse source
This commit is contained in:
Jake Wheat 2013-12-14 13:33:15 +02:00
parent 65610af74e
commit c28db4d470
6 changed files with 107 additions and 77 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,5 @@
The parser code
> -- | This is the module with the parser functions.
> module Language.SQL.SimpleSQL.Parser
> (parseQueryExpr
> ,parseScalarExpr
@ -363,7 +362,7 @@ associativity.
> binaryOperatorSuffix :: Bool -> ScalarExpr -> P ScalarExpr
> binaryOperatorSuffix bExpr e0 =
> BinOp <$> opSymbol <*> return e0 <*> factor
> BinOp e0 <$> opSymbol <*> factor
> where
> opSymbol = choice
> (map (try . symbol) binOpSymbolNames
@ -492,17 +491,16 @@ tref
> in option j (JoinAlias j <$> try tableAlias <*> try columnAliases)
> joinTrefSuffix t = (do
> nat <- option False $ try (True <$ (try $ keyword_ "natural"))
> JoinTableRef <$> joinType
> <*> return t
> <*> nonJoinTref
> <*> optionMaybe (joinCondition nat))
> JoinTableRef t <$> joinType
> <*> nonJoinTref
> <*> optionMaybe (joinCondition nat))
> >>= optionSuffix joinTrefSuffix
> joinType = choice
> [Cross <$ try (keyword_ "cross")
> ,Inner <$ try (keyword_ "inner")
> [JCross <$ try (keyword_ "cross")
> ,JInner <$ try (keyword_ "inner")
> ,choice [JLeft <$ try (keyword_ "left")
> ,JRight <$ try (keyword_ "right")
> ,Full <$ try (keyword_ "full")]
> ,JFull <$ try (keyword_ "full")]
> <* optional (try $ keyword_ "outer")]
> <* keyword "join"
> joinCondition nat =

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

@ -2,6 +2,7 @@
This is the pretty printer code which takes AST values and turns them
back into SQL source text. It attempts to format the output nicely.
> -- | These is the pretty printing functions, which produce SQL source from ASTs. The code attempts to format the output in a readable way.
> module Language.SQL.SimpleSQL.Pretty
> (prettyQueryExpr
> ,prettyScalarExpr
@ -12,14 +13,17 @@ back into SQL source text. It attempts to format the output nicely.
> import Text.PrettyPrint
> import Data.Maybe
> -- | Convert a query expr ast to concrete syntax.
> prettyQueryExpr :: QueryExpr -> String
> prettyQueryExpr = render . queryExpr
> -- | Convert a scalar expr ast to concrete syntax.
> prettyScalarExpr :: ScalarExpr -> String
> prettyScalarExpr = render . scalarExpr
> -- | Convert a list of query exprs to concrete syntax. A semi colon is inserted following each query expr.
> prettyQueryExprs :: [QueryExpr] -> String
> prettyQueryExprs = render . vcat . map ((<> text ";") . queryExpr)
> prettyQueryExprs = render . vcat . map ((<> text ";\n") . queryExpr)
= scalar expressions
@ -75,9 +79,9 @@ back into SQL source text. It attempts to format the output nicely.
> scalarExpr (PrefixOp f e) = text f <+> scalarExpr e
> scalarExpr (PostfixOp f e) = scalarExpr e <+> text f
> scalarExpr (BinOp "and" e0 e1) =
> scalarExpr (BinOp e0 "and" e1) =
> sep [scalarExpr e0, text "and" <+> scalarExpr e1]
> scalarExpr (BinOp f e0 e1) =
> scalarExpr (BinOp e0 f e1) =
> scalarExpr e0 <+> text f <+> scalarExpr e1
> scalarExpr (Case t ws els) =
@ -171,7 +175,7 @@ back into SQL source text. It attempts to format the output nicely.
> <+> maybe empty (parens . commaSep . map text) cs
> tr (JoinParens t) = parens $ tr t
> tr (JoinQueryExpr q) = parens $ queryExpr q
> tr (JoinTableRef jt t0 t1 jc) =
> tr (JoinTableRef t0 jt t1 jc) =
> sep [tr t0
> ,joinText jt jc
> ,tr t1
@ -181,11 +185,11 @@ back into SQL source text. It attempts to format the output nicely.
> Just JoinNatural -> text "natural"
> _ -> empty
> ,case jt of
> Inner -> text "inner"
> JInner -> text "inner"
> JLeft -> text "left"
> JRight -> text "right"
> Full -> text "full"
> Cross -> text "cross"
> JFull -> text "full"
> JCross -> text "cross"
> ,text "join"]
> joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr e
> joinCond (Just (JoinUsing es)) = text "using" <+> parens (commaSep $ map text es)

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

@ -1,21 +1,25 @@
> -- | The AST for SQL queries
> module Language.SQL.SimpleSQL.Syntax
> (ScalarExpr(..)
> (-- * Scalar expressions
> ScalarExpr(..)
> ,TypeName(..)
> ,SubQueryExprType(..)
> ,InThing(..)
> ,QueryExpr(..)
> ,makeSelect
> ,Duplicates(..)
> ,Direction(..)
> ,InThing(..)
> ,SubQueryExprType(..)
> -- * Query expressions
> ,QueryExpr(..)
> ,makeSelect
> ,CombineOp(..)
> ,Corresponding(..)
> -- ** From
> ,TableRef(..)
> ,JoinType(..)
> ,JoinCondition(..)
> ) where
> -- | Represents a scalar expression
> data ScalarExpr = NumLit String
> | StringLit String
> | IntervalLit String -- text of interval
@ -34,7 +38,7 @@
> -- are used for symbol and keyword operators
> -- these are used even for the multiple keyword
> -- operators
> | BinOp String ScalarExpr ScalarExpr
> | BinOp ScalarExpr String ScalarExpr
> | PrefixOp String ScalarExpr
> | PostfixOp String ScalarExpr
> -- the special op is used for ternary, mixfix and other non orthodox operators
@ -51,13 +55,23 @@
> deriving (Eq,Show)
> data TypeName = TypeName String deriving (Eq,Show)
> -- Represents 'expr in (scalar expression list)', and 'expr in
> -- (subquery)' syntax
> data InThing = InList [ScalarExpr]
> | InQueryExpr QueryExpr
> deriving (Eq,Show)
> -- | A subquery in a scalar expression
> data SubQueryExprType = SqExists | SqSq | SqAll | SqSome | SqAny
> deriving (Eq,Show)
> -- | Represents a query expression, which can be a select, a 'set
> -- operator' (union/except/intersect), a common table expression
> -- (with), a values expression (not yet supported) or the table
> -- syntax - 'table t', shorthand for 'select * from t' (not yet
> -- supported).
> data QueryExpr
> = Select
> {qeDuplicates :: Duplicates
@ -84,11 +98,20 @@ TODO: add queryexpr parens to deal with e.g.
(select 1 union select 2) union select 3
I'm not sure if this is valid syntax or not
> -- | represents the Distinct or All keywords, which can be used
> -- before a select list, in an aggregate/window function
> -- application, or in a query expression 'set operator'
> data Duplicates = Distinct | All deriving (Eq,Show)
> -- | The direction for a column in order by.
> data Direction = Asc | Desc deriving (Eq,Show)
> -- | Query expression 'set operators'
> data CombineOp = Union | Except | Intersect deriving (Eq,Show)
> -- | Corresponding, an option for the 'set operators'
> data Corresponding = Corresponding | Respectively deriving (Eq,Show)
> -- | helper/'default' value for query exprs to make creating query expr values a little easier
> makeSelect :: QueryExpr
> makeSelect = Select {qeDuplicates = All
> ,qeSelectList = []
@ -100,21 +123,22 @@ I'm not sure if this is valid syntax or not
> ,qeLimit = Nothing
> ,qeOffset = Nothing}
> data TableRef = SimpleTableRef String
> | JoinTableRef JoinType TableRef TableRef (Maybe JoinCondition)
> | JoinParens TableRef
> | JoinAlias TableRef String (Maybe [String])
> | JoinQueryExpr QueryExpr
> -- | Represents a entry in the csv of tables in the from clause.
> data TableRef = SimpleTableRef String -- from t
> | JoinTableRef TableRef JoinType TableRef (Maybe JoinCondition) -- from a join b
> | JoinParens TableRef -- from (a)
> | JoinAlias TableRef String (Maybe [String]) -- from a as b(c,d)
> | JoinQueryExpr QueryExpr -- from (query expr)
> deriving (Eq,Show)
TODO: add function table ref
> data JoinType = Inner | JLeft | JRight | Full | Cross
> -- | The type of a join
> data JoinType = JInner | JLeft | JRight | JFull | JCross
> deriving (Eq,Show)
> data JoinCondition = JoinOn ScalarExpr
> | JoinUsing [String]
> | JoinNatural
> -- | The join condition.
> data JoinCondition = JoinOn ScalarExpr -- ^ on expr
> | JoinUsing [String] -- ^ using (column list)
> | JoinNatural -- ^ natural join was specified
> deriving (Eq,Show)

2
PrettyIt.lhs
View file

@ -12,6 +12,6 @@
> [f] -> do
> src <- readFile f
> either (error . peFormattedError)
> (putStrLn . intercalate "\n" . map prettyQueryExpr)
> (putStrLn . prettyQueryExprs)
> $ parseQueryExprs f Nothing src
> _ -> error "please pass filename to prettify"

3
TODO
View file

@ -2,13 +2,12 @@
first release:
tests for the queryexprs parser
check the pretty printer on the tpch queries
fix the fixity issue
add automated tests to cabal
do code documentation and haddock
check the order of exports, imports and functions/cases in the files
fix up the import namespaces/explicit names nicelyx
fix up the import namespaces/explicit names nicely
do some tests for parse errors?
website with haddock and table of parsing tests

83
Tests.lhs
View file

@ -78,8 +78,8 @@
> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2")
> ,(NumLit "3", NumLit "4")] (Just $ NumLit "5"))
> ,("case when a=1 then 2 when a=3 then 4 else 5 end"
> ,Case Nothing [(BinOp "=" (Iden "a") (NumLit "1"), NumLit "2")
> ,(BinOp "=" (Iden "a") (NumLit "3"), NumLit "4")]
> ,Case Nothing [(BinOp (Iden "a") "=" (NumLit "1"), NumLit "2")
> ,(BinOp (Iden "a") "=" (NumLit "3"), NumLit "4")]
> (Just $ NumLit "5"))
> ]
@ -92,7 +92,7 @@
> binaryOperators :: TestItem
> binaryOperators = Group "binaryOperators" $ map (uncurry TestScalarExpr)
> [("a + b", BinOp "+" (Iden "a") (Iden "b"))
> [("a + b", BinOp (Iden "a") "+" (Iden "b"))
> -- sanity check fixities
> -- todo: add more fixity checking
> {-,("a + b * c"
@ -134,11 +134,11 @@
> ,("a not in (select a from t)"
> ,In False (Iden "a") (InQueryExpr ms))
> ,("a > all (select a from t)"
> ,BinOp ">" (Iden "a") (SubQueryExpr SqAll ms))
> ,BinOp (Iden "a") ">" (SubQueryExpr SqAll ms))
> ,("a = some (select a from t)"
> ,BinOp "=" (Iden "a") (SubQueryExpr SqSome ms))
> ,BinOp (Iden "a") "=" (SubQueryExpr SqSome ms))
> ,("a <= any (select a from t)"
> ,BinOp "<=" (Iden "a") (SubQueryExpr SqAny ms))
> ,BinOp (Iden "a") "<=" (SubQueryExpr SqAny ms))
> ]
> where
> ms = makeSelect
@ -164,13 +164,15 @@
> ,("a is not false", PostfixOp "is not false" (Iden "a"))
> ,("a is unknown", PostfixOp "is unknown" (Iden "a"))
> ,("a is not unknown", PostfixOp "is not unknown" (Iden "a"))
> ,("a is distinct from b", BinOp "is distinct from" (Iden "a") (Iden "b"))
> ,("a is not distinct from b", BinOp "is not distinct from" (Iden "a") (Iden "b"))
> ,("a like b", BinOp "like" (Iden "a") (Iden "b"))
> ,("a not like b", BinOp "not like" (Iden "a") (Iden "b"))
> ,("a is similar to b", BinOp "is similar to" (Iden "a") (Iden "b"))
> ,("a is not similar to b", BinOp "is not similar to" (Iden "a") (Iden "b"))
> ,("a overlaps b", BinOp "overlaps" (Iden "a") (Iden "b"))
> ,("a is distinct from b", BinOp (Iden "a") "is distinct from"(Iden "b"))
> ,("a is not distinct from b"
> ,BinOp (Iden "a") "is not distinct from" (Iden "b"))
> ,("a like b", BinOp (Iden "a") "like" (Iden "b"))
> ,("a not like b", BinOp (Iden "a") "not like" (Iden "b"))
> ,("a is similar to b", BinOp (Iden "a") "is similar to" (Iden "b"))
> ,("a is not similar to b"
> ,BinOp (Iden "a") "is not similar to" (Iden "b"))
> ,("a overlaps b", BinOp (Iden "a") "overlaps" (Iden "b"))
> ,("extract(day from t)", SpecialOp "extract" [Iden "day", Iden "t"])
> ,("substring(x from 1 for 2)"
> ,SpecialOp "substring" [Iden "x", NumLit "1", NumLit "2"])
@ -208,7 +210,7 @@
> parens :: TestItem
> parens = Group "parens" $ map (uncurry TestScalarExpr)
> [("(a)", Parens (Iden "a"))
> ,("(a + b)", Parens (BinOp "+" (Iden "a") (Iden "b")))
> ,("(a + b)", Parens (BinOp (Iden "a") "+" (Iden "b")))
> ]
> queryExprParserTests :: TestItem
@ -251,8 +253,8 @@
> ,(Nothing,Iden "b")]})
> ,("select 1+2,3+4"
> ,makeSelect {qeSelectList =
> [(Nothing,BinOp "+" (NumLit "1") (NumLit "2"))
> ,(Nothing,BinOp "+" (NumLit "3") (NumLit "4"))]})
> [(Nothing,BinOp (NumLit "1") "+" (NumLit "2"))
> ,(Nothing,BinOp (NumLit "3") "+" (NumLit "4"))]})
> ,("select a as a, /*comment*/ b as b"
> ,makeSelect {qeSelectList = [(Just "a", Iden "a")
> ,(Just "b", Iden "b")]})
@ -268,25 +270,25 @@
> ,("select a from t,u"
> ,ms [SimpleTableRef "t", SimpleTableRef "u"])
> ,("select a from t inner join u on expr"
> ,ms [JoinTableRef Inner (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JInner (SimpleTableRef "u")
> (Just $ JoinOn $ Iden "expr")])
> ,("select a from t left join u on expr"
> ,ms [JoinTableRef JLeft (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JLeft (SimpleTableRef "u")
> (Just $ JoinOn $ Iden "expr")])
> ,("select a from t right join u on expr"
> ,ms [JoinTableRef JRight (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JRight (SimpleTableRef "u")
> (Just $ JoinOn $ Iden "expr")])
> ,("select a from t full join u on expr"
> ,ms [JoinTableRef Full (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JFull (SimpleTableRef "u")
> (Just $ JoinOn $ Iden "expr")])
> ,("select a from t cross join u"
> ,ms [JoinTableRef Cross (SimpleTableRef "t")
> (SimpleTableRef "u") Nothing])
> ,ms [JoinTableRef (SimpleTableRef "t")
> JCross (SimpleTableRef "u") Nothing])
> ,("select a from t natural inner join u"
> ,ms [JoinTableRef Inner (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JInner (SimpleTableRef "u")
> (Just JoinNatural)])
> ,("select a from t inner join u using(a,b)"
> ,ms [JoinTableRef Inner (SimpleTableRef "t") (SimpleTableRef "u")
> ,ms [JoinTableRef (SimpleTableRef "t") JInner (SimpleTableRef "u")
> (Just $ JoinUsing ["a", "b"])])
> ,("select a from (select a from t)"
> ,ms [JoinQueryExpr $ ms [SimpleTableRef "t"]])
@ -297,16 +299,17 @@
> ,("select a from t u(b)"
> ,ms [JoinAlias (SimpleTableRef "t") "u" $ Just ["b"]])
> ,("select a from (t cross join u) as u"
> ,ms [JoinAlias (JoinParens $ JoinTableRef Cross (SimpleTableRef "t")
> (SimpleTableRef "u") Nothing) "u" Nothing])
> ,ms [JoinAlias (JoinParens $
> JoinTableRef (SimpleTableRef "t")
> JCross
> (SimpleTableRef "u") Nothing)
> "u" Nothing])
> -- todo: not sure if the associativity is correct
> ,("select a from t cross join u cross join v",
> ms [JoinTableRef Cross
> (JoinTableRef Cross (SimpleTableRef "t")
> (SimpleTableRef "u")
> Nothing)
> (SimpleTableRef "v")
> Nothing])
> ms [JoinTableRef
> (JoinTableRef (SimpleTableRef "t")
> JCross (SimpleTableRef "u") Nothing)
> JCross (SimpleTableRef "v") Nothing])
> ]
> where
> ms f = makeSelect {qeSelectList = [(Nothing,Iden "a")]
@ -317,7 +320,7 @@
> [("select a from t where a = 5"
> ,makeSelect {qeSelectList = [(Nothing,Iden "a")]
> ,qeFrom = [SimpleTableRef "t"]
> ,qeWhere = Just $ BinOp "=" (Iden "a") (NumLit "5")})
> ,qeWhere = Just $ BinOp (Iden "a") "=" (NumLit "5")})
> ]
> groupByClause :: TestItem
@ -344,7 +347,8 @@
> ,(Nothing, App "sum" [Iden "b"])]
> ,qeFrom = [SimpleTableRef "t"]
> ,qeGroupBy = [Iden "a"]
> ,qeHaving = Just $ BinOp ">" (App "sum" [Iden "b"]) (NumLit "5")
> ,qeHaving = Just $ BinOp (App "sum" [Iden "b"])
> ">" (NumLit "5")
> })
> ]
@ -437,13 +441,14 @@
> \ order by s"
> ,makeSelect
> {qeSelectList = [(Nothing, Iden "a")
> ,(Just "s", App "sum" [BinOp "+" (Iden "c")
> (Iden "d")])]
> ,(Just "s"
> ,App "sum" [BinOp (Iden "c")
> "+" (Iden "d")])]
> ,qeFrom = [SimpleTableRef "t", SimpleTableRef "u"]
> ,qeWhere = Just $ BinOp ">" (Iden "a") (NumLit "5")
> ,qeWhere = Just $ BinOp (Iden "a") ">" (NumLit "5")
> ,qeGroupBy = [Iden "a"]
> ,qeHaving = Just $ BinOp ">" (App "count" [NumLit "1"])
> (NumLit "5")
> ,qeHaving = Just $ BinOp (App "count" [NumLit "1"])
> ">" (NumLit "5")
> ,qeOrderBy = [(Iden "s", Asc)]
> }
> )