From e76aa2818b37c3fb963d0f3e38be569027217d4d Mon Sep 17 00:00:00 2001
From: Jake Wheat <jakewheat@tutanota.com>
Date: Wed, 10 Jan 2024 11:41:38 +0000
Subject: [PATCH] all tests passing, switch to megaparsec provisionally
complete
---
Language/SQL/SimpleSQL/Parse.hs | 32 +++++++------------
changelog | 2 ++
.../SQL/SimpleSQL/QueryExprComponents.hs | 19 +++++------
3 files changed, 22 insertions(+), 31 deletions(-)
diff --git a/Language/SQL/SimpleSQL/Parse.hs b/Language/SQL/SimpleSQL/Parse.hs
index 6d2b2ad..468bf83 100644
--- a/Language/SQL/SimpleSQL/Parse.hs
+++ b/Language/SQL/SimpleSQL/Parse.hs
@@ -1175,13 +1175,13 @@ 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]
+ [postfix $ try quantifiedComparisonSuffix
+ ,postfix matchPredicateSuffix]
,[binarySymL "."]
- ,[E.Postfix arraySuffix
- ,E.Postfix collateSuffix]
+ ,[postfix arraySuffix
+ ,postfix collateSuffix]
,[prefixSym "+", prefixSym "-"]
@@ -1206,8 +1206,8 @@ opTable bExpr =
-- with 'in' in position function, and not between
-- between also has a try in it to deal with 'not'
-- ambiguity
- ,E.Postfix $ try inSuffix
- ,E.Postfix betweenSuffix]
+ ,postfix $ try inSuffix
+ ,postfix betweenSuffix]
-- todo: figure out where to put the try?
++ [binaryKeywordsN $ makeKeywordTree
["not like"
@@ -1250,8 +1250,8 @@ opTable bExpr =
binaryKeywordN nm = E.InfixN (mkBinOp nm <$ keyword_ nm)
binaryKeywordL nm = E.InfixL (mkBinOp nm <$ keyword_ nm)
mkBinOp nm a b = BinOp a (mkNm nm) b
- prefixSym nm = E.Prefix (PrefixOp (mkNm nm) <$ symbol_ nm)
- prefixKeyword nm = E.Prefix (PrefixOp (mkNm nm) <$ keyword_ nm)
+ prefixSym nm = prefix (PrefixOp (mkNm nm) <$ symbol_ nm)
+ prefixKeyword nm = prefix (PrefixOp (mkNm nm) <$ keyword_ nm)
mkNm nm = [Name Nothing nm]
binaryKeywordsN p =
E.InfixN (do
@@ -1265,20 +1265,12 @@ opTable bExpr =
d <- option SQDefault duplicates
pure (\a b -> MultisetBinOp a o d b))
postfixKeywords p =
- E.Postfix $ do
+ 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
- -- I don't think this will be enough for all cases
- -- at least it works for 'not not a'
- -- ok: "x is not true is not true"
- -- no work: "x is not true is not null"
- prefix' p = E.Prefix . chainl1 p $ pure (.)
- postfix' p = E.Postfix . chainl1 p $ pure (flip (.))-}
+ -- parse repeated prefix or postfix operators
+ postfix p = E.Postfix $ foldr1 (flip (.)) <$> some p
+ prefix p = E.Prefix $ foldr1 (.) <$> some p
{-
== scalar expression top level
diff --git a/changelog b/changelog
index dd647a2..bbc7cc2 100644
--- a/changelog
+++ b/changelog
@@ -3,6 +3,8 @@
support table constraints without separating comma for sqlite
switch source from literate to regular haskell
use prettyprinter lib instead of pretty
+ nested block comments regressed - post a bug if you need this
+ fixed fixity parsing of union, except and intersect (matches postgres docs now)
0.6.1 added odbc handling to sqlsqerver dialect
added sqlserver dialect case for convert function
0.6.0
diff --git a/tools/Language/SQL/SimpleSQL/QueryExprComponents.hs b/tools/Language/SQL/SimpleSQL/QueryExprComponents.hs
index 8a558a8..7930fc7 100644
--- a/tools/Language/SQL/SimpleSQL/QueryExprComponents.hs
+++ b/tools/Language/SQL/SimpleSQL/QueryExprComponents.hs
@@ -147,30 +147,27 @@ offsetFetch = Group "offsetFetch" $ map (uncurry (TestQueryExpr ansi2011))
combos :: TestItem
combos = Group "combos" $ map (uncurry (TestQueryExpr ansi2011))
[("select a from t union select b from u"
- ,QueryExprSetOp ms1 Union SQDefault Respectively ms2)
+ ,QueryExprSetOp mst Union SQDefault Respectively msu)
,("select a from t intersect select b from u"
- ,QueryExprSetOp ms1 Intersect SQDefault Respectively ms2)
+ ,QueryExprSetOp mst Intersect SQDefault Respectively msu)
,("select a from t except all select b from u"
- ,QueryExprSetOp ms1 Except All Respectively ms2)
+ ,QueryExprSetOp mst Except All Respectively msu)
,("select a from t union distinct corresponding \
\select b from u"
- ,QueryExprSetOp ms1 Union Distinct Corresponding ms2)
+ ,QueryExprSetOp mst Union Distinct Corresponding msu)
,("select a from t union select a from t union select a from t"
- -- TODO: union should be left associative. I think the others also
- -- so this needs to be fixed (new optionSuffix variation which
- -- handles this)
- ,QueryExprSetOp ms1 Union SQDefault Respectively
- (QueryExprSetOp ms1 Union SQDefault Respectively ms1))
+ ,QueryExprSetOp (QueryExprSetOp mst Union SQDefault Respectively mst)
+ Union SQDefault Respectively mst)
]
where
- ms1 = makeSelect
+ mst = makeSelect
{qeSelectList = [(Iden [Name Nothing "a"],Nothing)]
,qeFrom = [TRSimple [Name Nothing "t"]]}
- ms2 = makeSelect
+ msu = makeSelect
{qeSelectList = [(Iden [Name Nothing "b"],Nothing)]
,qeFrom = [TRSimple [Name Nothing "u"]]}