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
> ["between" <$ 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 =
@ -234,20 +234,25 @@ used for between parsing
> binOpKeywordNamesNoAnd :: [String]
> binOpKeywordNamesNoAnd = filter (/="and") binOpKeywordNames
> unOpKeywordNames :: [String]
> unOpKeywordNames = ["not"]
> prefixUnOpKeywordNames :: [String]
> prefixUnOpKeywordNames = ["not"]
> unOpSymbolNames :: [String]
> unOpSymbolNames = ["+", "-"]
> prefixUnOpSymbolNames :: [String]
> prefixUnOpSymbolNames = ["+", "-"]
> unaryOp :: P ScalarExpr
> unaryOp =
> prefixUnaryOp :: P ScalarExpr
> prefixUnaryOp =
> makeOp <$> opSymbol <*> scalarExpr'
> where
> makeOp nm e = Op nm [e]
> opSymbol = choice (map (try . symbol) unOpSymbolNames
> ++ map (try . keyword) unOpKeywordNames)
> makeOp nm e = PrefixOp nm e
> opSymbol = choice (map (try . symbol) prefixUnOpSymbolNames
> ++ map (try . keyword) prefixUnOpKeywordNames)
> postfixOp :: ScalarExpr -> P ScalarExpr
> postfixOp e =
> try $ choice
> [PostfixOp "is null" e <$ keyword_ "is" <* keyword_ "null"]
> scalarExpr' :: P ScalarExpr
> scalarExpr' = scalarExpr'' False
@ -265,23 +270,23 @@ postgresql handles this
> ,scase
> ,cast
> ,subquery
> ,unaryOp
> ,prefixUnaryOp
> ,try app
> ,try dottedIden
> ,identifier
> ,sparens]
> trysuffix e = try (suffix e) <|> return e
> suffix e0 = choice
> [makeOp e0 <$> opSymbol <*> factor
> [BinOp <$> opSymbol <*> return e0 <*> factor
> ,inSuffix e0
> ,betweenSuffix e0
> ,postfixOp e0
> ] >>= trysuffix
> opSymbol = choice (map (try . symbol) binOpSymbolNames
> ++ map (try . keyword)
> (if bExpr
> then binOpKeywordNamesNoAnd
> else binOpKeywordNames))
> makeOp e0 op e1 = Op op [e0,e1]
> sparens :: P 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
> Cast e0 (TypeName tn) -> toHaskell $ App ("cast:" ++ tn) [e0]
> CastOp (TypeName tn) s -> toHaskell $ App ("castop:" ++ tn) [StringLit s]
> Op n [e0,e1] -> HSE.InfixApp (toHaskell e0)
> (HSE.QVarOp $ HSE.UnQual $ HSE.Ident n)
> (toHaskell e1)
> Op o [e0] -> toHaskell $ App ("unary:" ++ o) [e0]
> Op {} -> error $ "bad args to operator " ++ groom e
> --Op n [e0,e1] -> HSE.InfixApp (toHaskell e0)
> -- (HSE.QVarOp $ HSE.UnQual $ HSE.Ident n)
> -- (toHaskell e1)
> --Op o [e0] -> toHaskell $ App ("unary:" ++ o) [e0]
> --Op {} -> error $ "bad args to operator " ++ groom e
> Star -> HSE.Var $ HSE.UnQual $ HSE.Ident "*"
> Iden2 a b -> HSE.Var $ HSE.Qual (HSE.ModuleName a) (HSE.Ident b)
> 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.App (HSE.Var (HSE.UnQual (HSE.Ident "$case"))) (HSE.List [v,ts,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])
> | "unary:" `isPrefixOf` x ->
> Op (drop 6 x) [toSql ea]
> | "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.List [HSE.Lit (HSE.String ('s':ea))])
> | "castop:" `isPrefixOf` x ->
> CastOp (TypeName $ drop 7 x) ea
> HSE.App (HSE.Var (HSE.UnQual (HSE.Ident i)))
> (HSE.List es) -> App i $ map toSql es
> HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Ident n))) e1 ->
> Op n [toSql e0, toSql e1]
> {-HSE.InfixApp e0 (HSE.QVarOp (HSE.UnQual (HSE.Ident n))) e1 ->
> Op n [toSql e0, toSql e1]-}
> HSE.Paren e0 -> Parens $ toSql e0
> _ -> error $ "unsupported haskell " ++ groom e
> 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))
special cases
> scalarExpr (Op nm [a,b,c]) | nm `elem` ["between", "not between"] =
> scalarExpr (SpecialOp nm [a,b,c]) | nm `elem` ["between", "not between"] =
> sep [scalarExpr a
> ,text nm <+> scalarExpr b
> ,text "and" <+> scalarExpr c]
> scalarExpr (SpecialOp nm es) =
> text nm <+> parens (commaSep $ map scalarExpr es)
> scalarExpr (Op f [e]) = text f <+> scalarExpr e
> scalarExpr (Op f [e0,e1]) =
> scalarExpr (PrefixOp f e) = text f <+> scalarExpr e
> scalarExpr (PostfixOp f e) = scalarExpr e <+> text f
> scalarExpr (BinOp f e0 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) =
> sep [text "case" <+> (maybe empty scalarExpr t)
> ,nest 4 (sep ((map w ws)

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

@ -21,7 +21,13 @@
> | Star
> | Star2 String
> | 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
> [(ScalarExpr,ScalarExpr)] -- when branches
> (Maybe ScalarExpr) -- else value

54
Tests.lhs
View file

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