From e76aa2818b37c3fb963d0f3e38be569027217d4d Mon Sep 17 00:00:00 2001 From: Jake Wheat 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"]]}