From 4f73f4ec4431525ca683ae589a945ac9fc950c7d Mon Sep 17 00:00:00 2001 From: Jake Wheat 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)] > } > )