From 4f73f4ec4431525ca683ae589a945ac9fc950c7d Mon Sep 17 00:00:00 2001
From: Jake Wheat <jakewheatmail@gmail.com>
Date: Fri, 13 Dec 2013 21:26:14 +0200
Subject: [PATCH] split the Op ctor into binop,prefixop, postfixop and
specialop add support for is null
---
Language/SQL/SimpleSQL/Parser.lhs | 49 +++++++++++++++-------------
Language/SQL/SimpleSQL/Pretty.lhs | 15 ++++-----
Language/SQL/SimpleSQL/Syntax.lhs | 8 ++++-
Tests.lhs | 54 +++++++++++++++----------------
4 files changed, 67 insertions(+), 59 deletions(-)
diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs
index 4fc7678..70b4628 100644
--- a/Language/SQL/SimpleSQL/Parser.lhs
+++ b/Language/SQL/SimpleSQL/Parser.lhs
@@ -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
diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs
index e680137..6e2a957 100644
--- a/Language/SQL/SimpleSQL/Pretty.lhs
+++ b/Language/SQL/SimpleSQL/Pretty.lhs
@@ -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)
diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs
index db259e1..a7e9ea1 100644
--- a/Language/SQL/SimpleSQL/Syntax.lhs
+++ b/Language/SQL/SimpleSQL/Syntax.lhs
@@ -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
diff --git a/Tests.lhs b/Tests.lhs
index 233f71a..192cc3e 100644
--- a/Tests.lhs
+++ b/Tests.lhs
@@ -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)]
> }
> )