From 8cc475240b1b4e47cc65d0767ebdff45e6e203f2 Mon Sep 17 00:00:00 2001
From: Jake Wheat <jakewheat@tutanota.com>
Date: Wed, 10 Jan 2024 09:18:07 +0000
Subject: [PATCH] fix the scalar expression operator parsing, use expression
operator parsing for set operations too
---
Language/SQL/SimpleSQL/Parse.hs | 126 ++++++++++++++++----------------
1 file changed, 63 insertions(+), 63 deletions(-)
diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs
index 62b6a61..b5721d5 100644
--- a/Language/SQL/SimpleSQL/Parse.hs
+++ b/Language/SQL/SimpleSQL/Parse.hs
@@ -1165,38 +1165,37 @@ messages, but both of these are too important.
-}
opTable :: Bool -> [[E.Operator Parser ScalarExpr]]
-opTable bExpr = [] {-
+opTable bExpr =
[-- parse match and quantified comparisons as postfix ops
-- todo: left factor the quantified comparison with regular
-- binary comparison, somehow
[E.Postfix $ try quantifiedComparisonSuffix
- ,E.Postfix matchPredicateSuffix
- ]
+ ,E.Postfix matchPredicateSuffix]
- ,[binarySym "." E.AssocLeft]
+ ,[binarySymL "."]
- ,[postfix' arraySuffix
- ,postfix' collateSuffix]
+ ,[E.Postfix arraySuffix
+ ,E.Postfix collateSuffix]
,[prefixSym "+", prefixSym "-"]
- ,[binarySym "^" E.AssocLeft]
+ ,[binarySymL "^"]
- ,[binarySym "*" E.AssocLeft
- ,binarySym "/" E.AssocLeft
- ,binarySym "%" E.AssocLeft]
+ ,[binarySymL "*"
+ ,binarySymL "/"
+ ,binarySymL "%"]
- ,[binarySym "+" E.AssocLeft
- ,binarySym "-" E.AssocLeft]
+ ,[binarySymL "+"
+ ,binarySymL "-"]
- ,[binarySym "||" E.AssocRight
+ ,[binarySymR "||"
,prefixSym "~"
- ,binarySym "&" E.AssocRight
- ,binarySym "|" E.AssocRight]
+ ,binarySymR "&"
+ ,binarySymR "|"]
- ,[binaryKeyword "overlaps" E.AssocNone]
+ ,[binaryKeywordN "overlaps"]
- ,[binaryKeyword "like" E.AssocNone
+ ,[binaryKeywordN "like"
-- have to use try with inSuffix because of a conflict
-- with 'in' in position function, and not between
-- between also has a try in it to deal with 'not'
@@ -1204,19 +1203,19 @@ opTable bExpr = [] {-
,E.Postfix $ try inSuffix
,E.Postfix betweenSuffix]
-- todo: figure out where to put the try?
- ++ [binaryKeywords $ makeKeywordTree
+ ++ [binaryKeywordsN $ makeKeywordTree
["not like"
,"is similar to"
,"is not similar to"]]
- ++ [multisetBinOp]
+ ++ [multisetBinOp]
- ,[binarySym "<" E.AssocNone
- ,binarySym ">" E.AssocNone
- ,binarySym ">=" E.AssocNone
- ,binarySym "<=" E.AssocNone
- ,binarySym "!=" E.AssocRight
- ,binarySym "<>" E.AssocRight
- ,binarySym "=" E.AssocRight]
+ ,[binarySymN "<"
+ ,binarySymN ">"
+ ,binarySymN ">="
+ ,binarySymN "<="
+ ,binarySymR "!="
+ ,binarySymR "<>"
+ ,binarySymR "="]
,[postfixKeywords $ makeKeywordTree
["is null"
@@ -1227,42 +1226,44 @@ opTable bExpr = [] {-
,"is not false"
,"is unknown"
,"is not unknown"]]
- ++ [binaryKeywords $ makeKeywordTree
+ ++ [binaryKeywordsN $ makeKeywordTree
["is distinct from"
,"is not distinct from"]]
,[prefixKeyword "not"]
- ,if bExpr then [] else [binaryKeyword "and" E.AssocLeft]
+ ,if bExpr then [] else [binaryKeywordL "and"]
- ,[binaryKeyword "or" E.AssocLeft]
+ ,[binaryKeywordL "or"]
]
where
- binarySym nm assoc = binary (symbol_ nm) nm assoc
- binaryKeyword nm assoc = binary (keyword_ nm) nm assoc
- binaryKeywords p =
- E.Infix (do
+ binarySymL name = E.InfixL (mkBinOp name <$ symbol_ name)
+ binarySymR name = E.InfixR (mkBinOp name <$ symbol_ name)
+ binarySymN name = E.InfixN (mkBinOp name <$ symbol_ name)
+ binaryKeywordN name = E.InfixN (mkBinOp name <$ keyword_ name)
+ binaryKeywordL name = E.InfixL (mkBinOp name <$ keyword_ name)
+ mkBinOp nm a b = BinOp a (mkName nm) b
+ prefixSym name = E.Prefix (PrefixOp (mkName name) <$ symbol_ name)
+ prefixKeyword name = E.Prefix (PrefixOp (mkName name) <$ keyword_ name)
+ mkName nm = [Name Nothing nm]
+ binaryKeywordsN p =
+ E.InfixN (do
o <- try p
- pure (\a b -> BinOp a [Name Nothing $ unwords o] b))
- E.AssocNone
- postfixKeywords p =
- postfix' $ do
- o <- try p
- pure $ PostfixOp [Name Nothing $ unwords o]
- binary p nm assoc =
- E.Infix (p >> pure (\a b -> BinOp a [Name Nothing nm] b)) assoc
- multisetBinOp = E.Infix (do
+ pure (\a b -> BinOp a [Name Nothing $ T.unwords o] b))
+ multisetBinOp = E.InfixL (do
keyword_ "multiset"
o <- choice [Union <$ keyword_ "union"
,Intersect <$ keyword_ "intersect"
,Except <$ keyword_ "except"]
d <- option SQDefault duplicates
pure (\a b -> MultisetBinOp a o d b))
- E.AssocLeft
- prefixKeyword nm = prefix (keyword_ nm) nm
- prefixSym nm = prefix (symbol_ nm) nm
- prefix p nm = prefix' (p >> pure (PrefixOp [Name Nothing nm]))
+ postfixKeywords p =
+ E.Postfix $ do
+ o <- try p
+ pure $ PostfixOp [Name Nothing $ T.unwords o]
+
+ {-
-- hack from here
-- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported
-- not implemented properly yet
@@ -1524,10 +1525,10 @@ and union, etc..
-}
queryExpr :: Parser QueryExpr
-queryExpr = select {-choice
- [with
- ,undefined {-chainr1-} (choice [values,table, select]) setOp]-}
+queryExpr = E.makeExprParser qeterm qeOpTable
where
+ qeterm = with <|> select <|> table <|> values
+
select = keyword_ "select" >>
mkSelect
<$> option SQDefault duplicates
@@ -1541,6 +1542,19 @@ queryExpr = select {-choice
>> Values <$> commaSep (parens (commaSep scalarExpr))
table = keyword_ "table" >> Table <$> names
+ qeOpTable =
+ [[E.InfixL $ setOp Intersect "intersect"]
+ ,[E.InfixL $ setOp Except "except"
+ ,E.InfixL $ setOp Union "union"]]
+ setOp :: SetOperatorName -> Text -> Parser (QueryExpr -> QueryExpr -> QueryExpr)
+ setOp ctor opName = cq
+ <$> (ctor <$ keyword_ opName)
+ <*> option SQDefault duplicates
+ <*> corr
+ cq o d c q0 q1 = QueryExprSetOp q0 o d c q1
+ corr = option Respectively (Corresponding <$ keyword_ "corresponding")
+
+
{-
local data type to help with parsing the bit after the select list,
called 'table expression' in the ansi sql grammar. Maybe this should
@@ -1568,20 +1582,6 @@ tableExpression = mkTe <$> from
mkTe f w g h od (ofs,fe) =
TableExpression f w g h od ofs fe
-setOp :: Parser (QueryExpr -> QueryExpr -> QueryExpr)
-setOp = cq
- <$> setOpK
- <*> option SQDefault duplicates
- <*> corr
- where
- cq o d c q0 q1 = QueryExprSetOp q0 o d c q1
- setOpK = choice [Union <$ keyword_ "union"
- ,Intersect <$ keyword_ "intersect"
- ,Except <$ keyword_ "except"]
- <?> "set operator"
- corr = option Respectively (Corresponding <$ keyword_ "corresponding")
-
-
{-
wrapper for query expr which ignores optional trailing semicolon.