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

split the Op ctor into binop,prefixop, postfixop and specialop

Browse source 
add support for is null
This commit is contained in:
Jake Wheat 2013-12-13 21:26:14 +02:00
parent 955658c41f
commit 4f73f4ec44
4 changed files with 67 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -198,7 +198,7 @@ to be.
> opName = try $ choice > opName = try $ choice
> ["between" <$ keyword_ "between" > ["between" <$ keyword_ "between"
> ,"not between" <$ keyword_ "not" <* keyword_ "between"] > ,"not between" <$ keyword_ "not" <* keyword_ "between"]
> makeOp n a b c = Op n [a,b,c] > makeOp n a b c = SpecialOp n [a,b,c]
> subquery :: P ScalarExpr > subquery :: P ScalarExpr
> subquery = > subquery =
@ -234,20 +234,25 @@ used for between parsing
> binOpKeywordNamesNoAnd :: [String] > binOpKeywordNamesNoAnd :: [String]
> binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames > binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames
> unOpKeywordNames :: [String] > prefixUnOpKeywordNames :: [String]
> unOpKeywordNames = ["not"] > prefixUnOpKeywordNames = ["not"]
> unOpSymbolNames :: [String] > prefixUnOpSymbolNames :: [String]
> unOpSymbolNames = ["+", "-"] > prefixUnOpSymbolNames = ["+", "-"]
> unaryOp :: P ScalarExpr > prefixUnaryOp :: P ScalarExpr
> unaryOp = > prefixUnaryOp =
> makeOp <$> opSymbol <*> scalarExpr' > makeOp <$> opSymbol <*> scalarExpr'
> where > where
> makeOp nm e = Op nm [e] > makeOp nm e = PrefixOp nm e
> opSymbol = choice (map (try . symbol) unOpSymbolNames > opSymbol = choice (map (try . symbol) prefixUnOpSymbolNames
> ++ map (try . keyword) unOpKeywordNames) > ++ map (try . keyword) prefixUnOpKeywordNames)
> postfixOp :: ScalarExpr -> P ScalarExpr
> postfixOp e =
> try $ choice
> [PostfixOp "is null" e <$ keyword_ "is" <* keyword_ "null"]
> scalarExpr' :: P ScalarExpr > scalarExpr' :: P ScalarExpr
> scalarExpr' = scalarExpr'' False > scalarExpr' = scalarExpr'' False
@ -265,23 +270,23 @@ postgresql handles this
> ,scase > ,scase
> ,cast > ,cast
> ,subquery > ,subquery
> ,unaryOp > ,prefixUnaryOp
> ,try app > ,try app
> ,try dottedIden > ,try dottedIden
> ,identifier > ,identifier
> ,sparens] > ,sparens]
> trysuffix e = try (suffix e) <|> return e > trysuffix e = try (suffix e) <|> return e
> suffix e0 = choice > suffix e0 = choice
> [makeOp e0 <$> opSymbol <*> factor > [BinOp <$> opSymbol <*> return e0 <*> factor
> ,inSuffix e0 > ,inSuffix e0
> ,betweenSuffix e0 > ,betweenSuffix e0
> ,postfixOp e0
> ] >>= trysuffix > ] >>= trysuffix
> opSymbol = choice (map (try . symbol) binOpSymbolNames > opSymbol = choice (map (try . symbol) binOpSymbolNames
> ++ map (try . keyword) > ++ map (try . keyword)
> (if bExpr > (if bExpr
> then binOpKeywordNamesNoAnd > then binOpKeywordNamesNoAnd
> else binOpKeywordNames)) > else binOpKeywordNames))
> makeOp e0 op e1 = Op op [e0,e1]
> sparens :: P ScalarExpr > sparens :: P ScalarExpr
> sparens = Parens <$> parens scalarExpr' > sparens = Parens <$> parens scalarExpr'
@ -296,11 +301,11 @@ attempt to fix the precedence and associativity. Doesn't work
> App n es -> HSE.App (toHaskell $ Iden n) $ ltoh es > App n es -> HSE.App (toHaskell $ Iden n) $ ltoh es
> Cast e0 (TypeName tn) -> toHaskell $ App ("cast:" ++ tn) [e0] > Cast e0 (TypeName tn) -> toHaskell $ App ("cast:" ++ tn) [e0]
> CastOp (TypeName tn) s -> toHaskell $ App ("castop:" ++ tn) [StringLit s] > CastOp (TypeName tn) s -> toHaskell $ App ("castop:" ++ tn) [StringLit s]
> Op n [e0,e1] -> HSE.InfixApp (toHaskell e0) > --Op n [e0,e1] -> HSE.InfixApp (toHaskell e0)
> (HSE.QVarOp $ HSE.UnQual $ HSE.Ident n) > -- (HSE.QVarOp $ HSE.UnQual $ HSE.Ident n)
> (toHaskell e1) > -- (toHaskell e1)
> Op o [e0] -> toHaskell $ App ("unary:" ++ o) [e0] > --Op o [e0] -> toHaskell $ App ("unary:" ++ o) [e0]
> Op {} -> error $ "bad args to operator " ++ groom e > --Op {} -> error $ "bad args to operator " ++ groom e
> Star -> HSE.Var $ HSE.UnQual $ HSE.Ident "*" > Star -> HSE.Var $ HSE.UnQual $ HSE.Ident "*"
> Iden2 a b -> HSE.Var $ HSE.Qual (HSE.ModuleName a) (HSE.Ident b) > Iden2 a b -> HSE.Var $ HSE.Qual (HSE.ModuleName a) (HSE.Ident b)
> Star2 q -> HSE.Var $ HSE.Qual (HSE.ModuleName q) (HSE.Ident "*") > Star2 q -> HSE.Var $ HSE.Qual (HSE.ModuleName q) (HSE.Ident "*")
@ -324,20 +329,20 @@ attempt to fix the precedence and associativity. Doesn't work
> HSE.Lit (HSE.String ('n':l)) -> NumLit l > HSE.Lit (HSE.String ('n':l)) -> NumLit l
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) (HSE.List [v,ts,el]) -> > HSE.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) (HSE.List [v,ts,el]) ->
> Case (ltom v) (pairs ts) (ltom el) > Case (ltom v) (pairs ts) (ltom el)
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident x))) > {-HSE.App (HSE.Var (HSE.UnQual (HSE.Ident x)))
> (HSE.List [ea]) > (HSE.List [ea])
> | "unary:" `isPrefixOf` x -> > | "unary:" `isPrefixOf` x ->
> Op (drop 6 x) [toSql ea] > Op (drop 6 x) [toSql ea]
> | "cast:" `isPrefixOf` x -> > | "cast:" `isPrefixOf` x ->
> Cast (toSql ea) (TypeName $ drop 5 x) > Cast (toSql ea) (TypeName $ drop 5 x)-}
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident x))) > HSE.App (HSE.Var (HSE.UnQual (HSE.Ident x)))
> (HSE.List [HSE.Lit (HSE.String ('s':ea))]) > (HSE.List [HSE.Lit (HSE.String ('s':ea))])
> | "castop:" `isPrefixOf` x -> > | "castop:" `isPrefixOf` x ->
> CastOp (TypeName $ drop 7 x) ea > CastOp (TypeName $ drop 7 x) ea
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i))) > HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i)))
> (HSE.List es) -> App i $ map toSql es > (HSE.List es) -> App i $ map toSql es
> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Ident n))) e1 -> > {-HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Ident n))) e1 ->
> Op n [toSql e0, toSql e1] > Op n [toSql e0, toSql e1]-}
> HSE.Paren e0 -> Parens $ toSql e0 > HSE.Paren e0 -> Parens $ toSql e0
> _ -> error $ "unsupported haskell " ++ groom e > _ -> error $ "unsupported haskell " ++ groom e
> where > where

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

@ -30,22 +30,19 @@ back into SQL source text. It attempts to format the output nicely.
> scalarExpr (App f es) = text f <> parens (commaSep (map scalarExpr es)) > scalarExpr (App f es) = text f <> parens (commaSep (map scalarExpr es))
special cases > scalarExpr (SpecialOp nm [a,b,c]) | nm `elem` ["between", "not between"] =
> scalarExpr (Op nm [a,b,c]) | nm `elem` ["between", "not between"] =
> sep [scalarExpr a > sep [scalarExpr a
> ,text nm <+> scalarExpr b > ,text nm <+> scalarExpr b
> ,text "and" <+> scalarExpr c] > ,text "and" <+> scalarExpr c]
> scalarExpr (SpecialOp nm es) =
> text nm <+> parens (commaSep $ map scalarExpr es)
> scalarExpr (Op f [e]) = text f <+> scalarExpr e > scalarExpr (PrefixOp f e) = text f <+> scalarExpr e
> scalarExpr (Op f [e0,e1]) = > scalarExpr (PostfixOp f e) = scalarExpr e <+> text f
> scalarExpr (BinOp f e0 e1) =
> sep [scalarExpr e0, text f, scalarExpr e1] > sep [scalarExpr e0, text f, scalarExpr e1]
> scalarExpr (Op f es) =
> -- TODO: how to handle this? error or either seems poor
> text f <> parens (commaSep (map scalarExpr es))
> scalarExpr (Case t ws els) = > scalarExpr (Case t ws els) =
> sep [text "case" <+> (maybe empty scalarExpr t) > sep [text "case" <+> (maybe empty scalarExpr t)
> ,nest 4 (sep ((map w ws) > ,nest 4 (sep ((map w ws)

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

@ -21,7 +21,13 @@
> | Star > | Star
> | Star2 String > | Star2 String
> | App String [ScalarExpr] > | App String [ScalarExpr]
> | Op String [ScalarExpr] > -- the binop, prefixop and postfix op
> -- are used for symbol and keyword operators
> | BinOp String ScalarExpr ScalarExpr
> | PrefixOp String ScalarExpr
> | PostfixOp String ScalarExpr
> -- the special op is used for ternary, mixfix and other non orthodox operators
> | SpecialOp String [ScalarExpr]
> | Case (Maybe ScalarExpr) -- test value > | Case (Maybe ScalarExpr) -- test value
> [(ScalarExpr,ScalarExpr)] -- when branches > [(ScalarExpr,ScalarExpr)] -- when branches
> (Maybe ScalarExpr) -- else value > (Maybe ScalarExpr) -- else value

46
Tests.lhs
View file

@ -75,8 +75,8 @@
> ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2") > ,Case (Just $ Iden "a") [(NumLit "1", NumLit "2")
> ,(NumLit "3", NumLit "4")] (Just $ NumLit "5")) > ,(NumLit "3", NumLit "4")] (Just $ NumLit "5"))
> ,("case when a=1 then 2 when a=3 then 4 else 5 end" > ,("case when a=1 then 2 when a=3 then 4 else 5 end"
> ,Case Nothing [(Op "=" [Iden "a", NumLit "1"], NumLit "2") > ,Case Nothing [(BinOp "=" (Iden "a") (NumLit "1"), NumLit "2")
> ,(Op "=" [Iden "a",NumLit "3"], NumLit "4")] > ,(BinOp "=" (Iden "a") (NumLit "3"), NumLit "4")]
> (Just $ NumLit "5")) > (Just $ NumLit "5"))
> ] > ]
@ -89,7 +89,7 @@
> binaryOperators :: TestItem > binaryOperators :: TestItem
> binaryOperators = Group "binaryOperators" $ map (uncurry TestScalarExpr) > binaryOperators = Group "binaryOperators" $ map (uncurry TestScalarExpr)
> [("a + b", Op "+" [Iden "a", Iden "b"]) > [("a + b", BinOp "+" (Iden "a") (Iden "b"))
> -- sanity check fixities > -- sanity check fixities
> -- todo: add more fixity checking > -- todo: add more fixity checking
> {-,("a + b * c" > {-,("a + b * c"
@ -103,10 +103,10 @@
> unaryOperators :: TestItem > unaryOperators :: TestItem
> unaryOperators = Group "unaryOperators" $ map (uncurry TestScalarExpr) > unaryOperators = Group "unaryOperators" $ map (uncurry TestScalarExpr)
> [("not a", Op "not" [Iden "a"]) > [("not a", PrefixOp "not" $ Iden "a")
> ,("not not a", Op "not" [Op "not" [Iden "a"]]) > ,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")
> ,("+a", Op "+" [Iden "a"]) > ,("+a", PrefixOp "+" $ Iden "a")
> ,("-a", Op "-" [Iden "a"]) > ,("-a", PrefixOp "-" $ Iden "a")
> ] > ]
@ -131,11 +131,11 @@
> ,("a not in (select a from t)" > ,("a not in (select a from t)"
> ,In False (Iden "a") (InQueryExpr ms)) > ,In False (Iden "a") (InQueryExpr ms))
> ,("a > all (select a from t)" > ,("a > all (select a from t)"
> ,Op ">" [Iden "a", SubQueryExpr SqAll ms]) > ,BinOp ">" (Iden "a") (SubQueryExpr SqAll ms))
> ,("a = some (select a from t)" > ,("a = some (select a from t)"
> ,Op "=" [Iden "a", SubQueryExpr SqSome ms]) > ,BinOp "=" (Iden "a") (SubQueryExpr SqSome ms))
> ,("a <= any (select a from t)" > ,("a <= any (select a from t)"
> ,Op "<=" [Iden "a", SubQueryExpr SqAny ms]) > ,BinOp "<=" (Iden "a") (SubQueryExpr SqAny ms))
> ] > ]
> where > where
> ms = makeSelect > ms = makeSelect
@ -147,13 +147,13 @@
> miscOps = Group "unaryOperators" $ map (uncurry TestScalarExpr) > miscOps = Group "unaryOperators" $ map (uncurry TestScalarExpr)
> [("a in (1,2,3)" > [("a in (1,2,3)"
> ,In True (Iden "a") $ InList $ map NumLit ["1","2","3"]) > ,In True (Iden "a") $ InList $ map NumLit ["1","2","3"])
> ,("a between b and c", Op "between" [Iden "a" > ,("a between b and c", SpecialOp "between" [Iden "a"
> ,Iden "b" > ,Iden "b"
> ,Iden "c"]) > ,Iden "c"])
> ,("a not between b and c", Op "not between" [Iden "a" > ,("a not between b and c", SpecialOp "not between" [Iden "a"
> ,Iden "b" > ,Iden "b"
> ,Iden "c"]) > ,Iden "c"])
> --,("a is null", Op "not" []) > ,("a is null", PostfixOp "is null" (Iden "a"))
> --,("a is not null", Op "not" []) > --,("a is not null", Op "not" [])
> --,("a is distinct from b", Op "not" []) > --,("a is distinct from b", Op "not" [])
> --,("a is not distinct from b", Op "not" []) > --,("a is not distinct from b", Op "not" [])
@ -194,7 +194,7 @@
> parens :: TestItem > parens :: TestItem
> parens = Group "parens" $ map (uncurry TestScalarExpr) > parens = Group "parens" $ map (uncurry TestScalarExpr)
> [("(a)", Parens (Iden "a")) > [("(a)", Parens (Iden "a"))
> ,("(a + b)", Parens (Op "+" [Iden "a", Iden "b"])) > ,("(a + b)", Parens (BinOp "+" (Iden "a") (Iden "b")))
> ] > ]
> queryExprParserTests :: TestItem > queryExprParserTests :: TestItem
@ -236,8 +236,8 @@
> ,(Nothing,Iden "b")]}) > ,(Nothing,Iden "b")]})
> ,("select 1+2,3+4" > ,("select 1+2,3+4"
> ,makeSelect {qeSelectList = > ,makeSelect {qeSelectList =
> [(Nothing,Op "+" [NumLit "1",NumLit "2"]) > [(Nothing,BinOp "+" (NumLit "1") (NumLit "2"))
> ,(Nothing,Op "+" [NumLit "3",NumLit "4"])]}) > ,(Nothing,BinOp "+" (NumLit "3") (NumLit "4"))]})
> ,("select a as a, /*comment*/ b as b" > ,("select a as a, /*comment*/ b as b"
> ,makeSelect {qeSelectList = [(Just "a", Iden "a") > ,makeSelect {qeSelectList = [(Just "a", Iden "a")
> ,(Just "b", Iden "b")]}) > ,(Just "b", Iden "b")]})
@ -292,7 +292,7 @@
> [("select a from t where a = 5" > [("select a from t where a = 5"
> ,makeSelect {qeSelectList = [(Nothing,Iden "a")] > ,makeSelect {qeSelectList = [(Nothing,Iden "a")]
> ,qeFrom = [SimpleTableRef "t"] > ,qeFrom = [SimpleTableRef "t"]
> ,qeWhere = Just $ Op "=" [Iden "a", NumLit "5"]}) > ,qeWhere = Just $ BinOp "=" (Iden "a") (NumLit "5")})
> ] > ]
> groupByClause :: TestItem > groupByClause :: TestItem
@ -319,7 +319,7 @@
> ,(Nothing, App "sum" [Iden "b"])] > ,(Nothing, App "sum" [Iden "b"])]
> ,qeFrom = [SimpleTableRef "t"] > ,qeFrom = [SimpleTableRef "t"]
> ,qeGroupBy = [Iden "a"] > ,qeGroupBy = [Iden "a"]
> ,qeHaving = Just $ Op ">" [App "sum" [Iden "b"], NumLit "5"] > ,qeHaving = Just $ BinOp ">" (App "sum" [Iden "b"]) (NumLit "5")
> }) > })
> ] > ]
@ -379,13 +379,13 @@
> \ order by s" > \ order by s"
> ,makeSelect > ,makeSelect
> {qeSelectList = [(Nothing, Iden "a") > {qeSelectList = [(Nothing, Iden "a")
> ,(Just "s", App "sum" [Op "+" [Iden "c" > ,(Just "s", App "sum" [BinOp "+" (Iden "c")
> ,Iden "d"]])] > (Iden "d")])]
> ,qeFrom = [SimpleTableRef "t", SimpleTableRef "u"] > ,qeFrom = [SimpleTableRef "t", SimpleTableRef "u"]
> ,qeWhere = Just $ Op ">" [Iden "a", NumLit "5"] > ,qeWhere = Just $ BinOp ">" (Iden "a") (NumLit "5")
> ,qeGroupBy = [Iden "a"] > ,qeGroupBy = [Iden "a"]
> ,qeHaving = Just $ Op ">" [App "count" [NumLit "1"] > ,qeHaving = Just $ BinOp ">" (App "count" [NumLit "1"])
> ,NumLit "5"] > (NumLit "5")
> ,qeOrderBy = [(Iden "s", Asc)] > ,qeOrderBy = [(Iden "s", Asc)]
> } > }
> ) > )