postgresql-syntax 0.4.3.2 → 0.4.4.0

raw patch · 6 files changed

+326/−17 lines, 6 filesdep +clockdep +deepseqdep ~rerebasePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: clock, deepseq

Dependency ranges changed: rerebase

API changes (from Hackage documentation)

Files

• hedgehog-test/Main/Gen.hs +22/−1
• library/PostgresqlSyntax/Parsing.hs +151/−15
• library/PostgresqlSyntax/Prelude.hs +1/−0
• nesting-bench/Main.hs +83/−0
• postgresql-syntax.cabal +16/−1
• tasty-test/Main.hs +53/−0

@@ -99,8 +99,29 @@ selectNoParens =   frequency     [ (90, SelectNoParens <$> maybe withClause <*> (Left <$> simpleSelect) <*> maybe sortClause <*> maybe selectLimit <*> maybe forLockingClause),-      (10, SelectNoParens <$> fmap Just withClause <*> selectClause <*> fmap Just sortClause <*> fmap Just selectLimit <*> fmap Just forLockingClause)+      (10, clausePlusSurroundingsSelectNoParens)     ]++-- |+-- A 'SelectNoParens' with at least one of its surrounding clauses present.+--+-- The restriction matters for the @Right@ (parenthesised select) shape of the+-- inner clause: @SelectNoParens Nothing (Right x) Nothing Nothing Nothing@+-- renders to exactly the same text as @WithParensSelectWithParens x@, and the+-- parser canonicalises that text to the latter — see the \"Canonical shape\"+-- note on @PostgresqlSyntax.Parsing.selectWithParensBody@. So the degenerate+-- combination is excluded here deliberately, rather than by accident of the+-- generator's shape: it is the one tree in this family that the round-trip+-- property cannot hold for.+clausePlusSurroundingsSelectNoParens = do+  clause <- selectClause+  -- At least one surrounding clause, so the SelectNoParens wrapper is+  -- load-bearing.+  (with, sort, limit, forLocking) <-+    filter+      (\(a, b, c, d) -> any not [null a, null b, null c, null d])+      ((,,,) <$> maybe withClause <*> maybe sortClause <*> maybe selectLimit <*> maybe forLockingClause)+  return (SelectNoParens with clause sort limit forLocking)  terminalSelectNoParens =   SelectNoParens <$> pure Nothing <*> (Left <$> terminalSimpleSelect) <*> pure Nothing <*> pure Nothing <*> pure Nothing

@@ -329,12 +329,68 @@ -- Reserved keyword "as" used as an identifier. If that's what you intend, you have to wrap it in double quotes. selectStmt = Left <$> selectNoParens <|> Right <$> selectWithParens -selectWithParens = inParens (WithParensSelectWithParens <$> selectWithParens <|> NoParensSelectWithParens <$> selectNoParens)+selectWithParens = inParens selectWithParensBody +-- |+-- The content of a @select_with_parens@, after the opening paren.+--+-- @gram.y@ gives two productions, @'(' select_with_parens ')'@ and+-- @'(' select_no_parens ')'@, and they overlap: a @select_no_parens@ may+-- itself be nothing but a @select_clause@, and a @select_clause@ may itself be+-- a @select_with_parens@. Transcribed literally as two alternatives, that+-- overlap makes every nested paren group get parsed twice — once down the+-- @select_with_parens@ branch and once down the @select_no_parens@ branch —+-- so the cost doubles with each level of nesting. That was the dominant term+-- in the exponential blowup this parser used to exhibit on parenthesised+-- input, including input that is not a select at all (the two branches both+-- have to descend the whole nest before either can fail).+--+-- So the shared prefix is parsed once and classified afterwards.+--+-- ==== Canonical shape+--+-- Because the productions overlap, @((select 1))@ has two representations:+-- @WithParensSelectWithParens@ wrapping the inner parenthesised select, or+-- @NoParensSelectWithParens@ of a @SelectNoParens@ whose clause is that same+-- inner parenthesised select. Both render back to the same text.+--+-- __The first is canonical.__ A parenthesised select with nothing else+-- attached to it is a @WithParensSelectWithParens@; the+-- @NoParensSelectWithParens@ form is produced only when the parens are+-- actually carrying something — a set operation (@union@ and friends), a sort+-- clause, a limit, or a locking clause. That is the collapse performed by the+-- @case@ below, and it is what the property-test generators are aligned with.+selectWithParensBody =+  asum+    [ do+        a <- wrapToHead selectWithParens+        b <- selectNoParensAfterClause Nothing (Right a)+        return $ case b of+          SelectNoParens Nothing (Right c) Nothing Nothing Nothing -> WithParensSelectWithParens c+          _ -> NoParensSelectWithParens b,+      NoParensSelectWithParens <$> unparenthesizedSelectNoParens+    ]+ selectNoParens = withSelectNoParens <|> simpleSelectNoParens -sharedSelectNoParens with = do-  select <- selectClause+-- |+-- 'selectNoParens' restricted to the forms that do not begin with @(@.+--+-- Used by 'selectWithParensBody', where the paren-leading form is already+-- covered by the branch that shares the nested 'selectWithParens' parse.+-- Admitting it here again is what would reintroduce the doubling.+unparenthesizedSelectNoParens =+  withSelectNoParens+    <|> (baseSimpleSelect >>= selectNoParensAfterClause Nothing . Left)++sharedSelectNoParens with = selectClauseBase >>= selectNoParensAfterClause with++-- |+-- The remainder of 'sharedSelectNoParens', resumed from an already parsed+-- 'selectClauseBase'. Split out so that callers which have had to parse that+-- base themselves can continue without parsing it again.+selectNoParensAfterClause with clauseBase = do+  select <- extendMany selectClauseSuffix clauseBase   sort <- optional (space1 *> sortClause)   (limit, forLocking) <- limitFirst <|> forLockingFirst <|> pure (Nothing, Nothing)   return (SelectNoParens with select sort limit forLocking)@@ -365,15 +421,16 @@   space1   sharedSelectNoParens (Just with) -selectClause = suffixRec base suffix-  where-    base =-      asum-        [ Right <$> selectWithParens,-          Left <$> baseSimpleSelect-        ]-    suffix a = Left <$> extensionSimpleSelect a+selectClause = selectClauseBase >>= extendMany selectClauseSuffix +selectClauseBase =+  asum+    [ Right <$> selectWithParens,+      Left <$> baseSimpleSelect+    ]++selectClauseSuffix a = Left <$> extensionSimpleSelect a+ baseSimpleSelect =   asum     [ do@@ -997,7 +1054,6 @@       asum         [ DefaultAExpr <$ keyword "default",           UniqueAExpr <$> (keyword "unique" *> space1 *> selectWithParens),-          OverlapsAExpr <$> wrapToHead row <*> (space1 *> keyword "overlaps" *> space1 *> endHead *> row),           qualOpExpr aExpr PrefixQualOpAExpr,           PlusAExpr <$> plusedExpr aExpr,           MinusAExpr <$> minusedExpr aExpr,@@ -1006,7 +1062,8 @@         ]     suffix a =       asum-        [ do+        [ overlapsSuffix a,+          do             space1             b <- wrapToHead subqueryOp             space1@@ -1081,6 +1138,39 @@           NotnullAExpr a <$ (space1 *> keyword "notnull")         ] +-- |+-- The @OVERLAPS@ operator, as a suffix of an already parsed left operand.+--+-- @gram.y@ specifies it as @row OVERLAPS row@, and the straightforward+-- transcription of that is to parse a @row@ speculatively in the base position+-- of 'customizedAExpr'. That is what this parser replaces, and the reason it+-- exists: a speculative @row@ parse consumes and then discards a whole+-- parenthesised group, so every group in the input got parsed once for+-- @OVERLAPS@ and again for the alternative that actually matched — one of the+-- factors that made parsing exponential in nesting depth.+--+-- Instead we let the ordinary base parser consume the left operand exactly+-- once and reinterpret its result here. The two 'CExpr' shapes below are+-- precisely the two 'Row' shapes, so no input that used to parse stops+-- parsing, and the constructed tree is identical.+--+-- >>> testParser aExpr "(1, 2) overlaps (3, 4)"+-- OverlapsAExpr (ImplicitRowRow (ImplicitRow (CExprAExpr (AexprConstCExpr (IAexprConst 1)) :| []) (CExprAExpr (AexprConstCExpr (IAexprConst 2))))) (ImplicitRowRow (ImplicitRow (CExprAExpr (AexprConstCExpr (IAexprConst 3)) :| []) (CExprAExpr (AexprConstCExpr (IAexprConst 4)))))+overlapsSuffix :: AExpr -> Parser AExpr+overlapsSuffix a = do+  b <- maybe empty pure (aExprRow a)+  space1+  keyword "overlaps"+  endHead+  space1+  c <- row+  return (OverlapsAExpr b c)+  where+    aExprRow = \case+      CExprAExpr (ExplicitRowCExpr x) -> Just (ExplicitRowRow x)+      CExprAExpr (ImplicitRowCExpr x) -> Just (ImplicitRowRow x)+      _ -> Nothing+ bExpr = customizedBExpr cExpr  customizedBExpr cExpr = suffixRec base suffix@@ -1118,7 +1208,6 @@   asum     [ ParamCExpr <$> (char '$' *> decimal <* endHead) <*> optional (space *> indirection),       CaseCExpr <$> caseExpr,-      ImplicitRowCExpr <$> implicitRow,       ExplicitRowCExpr <$> explicitRow,       inParensWithClause (keyword "grouping") (GroupingCExpr <$> sep1 commaSeparator aExpr),       keyword "exists" *> space *> (ExistsCExpr <$> selectWithParens),@@ -1135,10 +1224,57 @@         endHead         b <- optional (space *> indirection)         return (SelectWithParensCExpr a b),-      InParensCExpr <$> (inParens aExpr <* endHead) <*> optional (space *> indirection),+      parenthesizedExprCExpr,       AexprConstCExpr <$> wrapToHead aexprConst,       FuncCExpr <$> funcExpr,       ColumnrefCExpr <$> columnref+    ]++-- |+-- The two @cExpr@ forms that consist of an expression in parentheses:+-- a parenthesised expression (@InParensCExpr@) and an implicit row+-- (@ImplicitRowCExpr@).+--+-- They are parsed together, and deliberately so. Written as two alternatives+-- of the surrounding 'asum' — which is how they used to be written — the+-- implicit-row alternative parses the whole first expression of the group+-- before it can discover that no comma follows, and then the parenthesised-+-- expression alternative parses that same text over again. Nest that and the+-- work doubles per level. Sharing the single @aExpr@ parse between the two and+-- deciding on the character that follows it removes the duplication, which is+-- what makes parsing linear rather than exponential in nesting depth.+--+-- The @(@ is not committed to with 'endHead' here: 'selectWithParens' is tried+-- before this parser and other parenthesised forms exist elsewhere in the+-- grammar, so the group must stay backtrackable. Commitment happens on the+-- comma or the closing paren, once the form is unambiguous.+--+-- >>> testParser cExpr "(a + b)"+-- InParensCExpr (SymbolicBinOpAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing))) (MathSymbolicExprBinOp PlusMathOp) (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing)))) Nothing+--+-- >>> testParser cExpr "(a, b)"+-- ImplicitRowCExpr (ImplicitRow (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing)) :| []) (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing))))+parenthesizedExprCExpr :: Parser CExpr+parenthesizedExprCExpr = do+  char '('+  space+  a <- aExpr+  space+  asum+    [ do+        char ','+        endHead+        space+        b <- exprList+        space+        char ')'+        return $ ImplicitRowCExpr $ case NonEmpty.consAndUnsnoc a b of+          (c, d) -> ImplicitRow c d,+      do+        char ')'+        endHead+        b <- optional (space *> indirection)+        return (InParensCExpr a b)     ]  subqueryOp =

@@ -2,6 +2,7 @@   ( module Exports,     showAsText,     suffixRec,+    extendMany,   ) where 

@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-}++-- |+-- Repeatable timing harness for the nesting-depth blowup described in+-- @docs/tasks/parser-exponential-time-on-nesting.md@.+--+-- Run with @cabal run nesting-bench@. Prints a table of parse times so the+-- before\/after effect of a fix is measurable rather than asserted.+--+-- Each case is given a wall-clock budget; a case that exceeds it is reported+-- as a timeout instead of hanging the run.+module Main where++import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified PostgresqlSyntax.Parsing as Parsing+import System.Clock+import Prelude++-- * Inputs++-- | Case 1: @((((a + b))))@ with @n@ layers of redundant parentheses.+nestedParens :: Int -> Text+nestedParens n =+  Text.replicate n "(" <> "a + b" <> Text.replicate n ")"++-- | Case 2: the user-reported shape — a sum of @COALESCE@ terms, split into+-- two parenthesised groups subtracted from one another, wrapped in a few+-- redundant parentheses.+coalesceSum :: Int -> Int -> Text+coalesceSum terms wrap =+  Text.replicate wrap "("+    <> group 0+    <> " - "+    <> group terms+    <> Text.replicate wrap ")"+  where+    group off =+      "(" <> Text.intercalate " + " [term (off + i) | i <- [1 .. terms]] <> ")"+    term i =+      "coalesce(c" <> Text.pack (show i) <> ", 0)"++-- * Timing++-- | Run an action under a wall-clock budget. 'Nothing' on timeout.+withTimeout :: Int -> IO a -> IO (Maybe a)+withTimeout micros action = do+  slot <- newEmptyMVar+  _ <- forkIO (action >>= \x -> putMVar slot (Just x))+  _ <- forkIO (threadDelay micros >> putMVar slot Nothing)+  takeMVar slot++-- | Parse and fully force the result, returning elapsed seconds.+time :: Text -> IO Double+time input = do+  start <- getTime Monotonic+  _ <- evaluate (force (either (const "err") (const "ok") (Parsing.run Parsing.aExpr input) :: String))+  end <- getTime Monotonic+  pure (fromIntegral (toNanoSecs (diffTimeSpec end start)) / 1e9)++budgetSeconds :: Double+budgetSeconds = 10++measure :: String -> Text -> IO ()+measure label input = do+  result <- withTimeout (round (budgetSeconds * 1e6)) (time input)+  putStrLn $ case result of+    Nothing -> pad label <> "  TIMEOUT (>" <> show (round budgetSeconds :: Int) <> "s), " <> show (Text.length input) <> " chars"+    Just seconds -> pad label <> "  " <> show seconds <> "s, " <> show (Text.length input) <> " chars"+  where+    pad s = s <> replicate (max 0 (28 - length s)) ' '++main :: IO ()+main = do+  putStrLn "Case 1: ((((a + b)))) at increasing nesting depth"+  mapM_ (\n -> measure ("  depth " <> show n) (nestedParens n)) [1, 2, 4, 6, 8, 10, 12, 14, 16, 20, 30, 50, 100, 500]+  putStrLn ""+  putStrLn "Case 2: sum-of-COALESCE, two groups, 6 redundant wraps"+  mapM_ (\t -> measure ("  " <> show (2 * t) <> " terms") (coalesceSum t 6)) [4, 8, 12, 16, 20, 24]

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-syntax-version: 0.4.3.2+version: 0.4.4.0 category: Database, PostgreSQL, Parsing synopsis: PostgreSQL AST parsing and rendering description:@@ -133,5 +133,20 @@     headed-megaparsec >=0.2.0.1 && <0.3,     hedgehog >=1.0.1 && <2,     megaparsec >=9.2 && <10,+    postgresql-syntax,+    rerebase >=1.6.1 && <2,++benchmark nesting-bench+  import: base-settings+  type: exitcode-stdio-1.0+  hs-source-dirs: nesting-bench+  main-is: Main.hs+  ghc-options:+    -O2+    -threaded++  build-depends:+    clock >=0.8 && <1,+    deepseq >=1.4 && <2,     postgresql-syntax,     rerebase >=1.6.1 && <2,

@@ -2,7 +2,9 @@  import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text+import PostgresqlSyntax.Ast import qualified PostgresqlSyntax.Parsing as Parsing+import qualified PostgresqlSyntax.Rendering as Rendering import Test.Tasty import Test.Tasty.HUnit import Prelude hiding (assert)@@ -76,6 +78,7 @@                       "$x$it's good$x$"                     ]                 ],+        testGroup "Nesting depth" nestingTests,         testGroup "Error reporting"           $ let testParserOnAllInputs parserName parser inputs res =                   testCase parserName@@ -102,3 +105,53 @@                     "(51,\"offset=51:\\nexpecting white space\\n\")"                 ]       ]++-- |+-- Regression tests for the parser's behaviour on deeply nested parentheses.+--+-- The parser used to take time exponential in the nesting depth, because+-- several grammar alternatives each parsed the content of a parenthesised+-- group before discovering they did not apply. Every input here is trivial in+-- size; before the fix, all of them ran for longer than a person will wait.+--+-- Each case is given a generous wall-clock budget. The point is not to measure+-- performance — 'nesting-bench' does that — but to fail loudly if the+-- exponential behaviour ever comes back.+nestingTests :: [TestTree]+nestingTests =+  [ parsesWithin "redundant parens, depth 50" 5 Parsing.aExpr+      $ Text.replicate 50 "("+      <> "a + b"+      <> Text.replicate 50 ")",+    parsesWithin "redundant parens around a select, depth 50" 5 Parsing.preparableStmt+      $ "select "+      <> Text.replicate 50 "("+      <> "a + b"+      <> Text.replicate 50 ")",+    parsesWithin "sum of COALESCE terms in two wrapped groups" 5 Parsing.aExpr+      $ let terms off = Text.intercalate " + " ["coalesce(c" <> Text.pack (show (off + i)) <> ", 0)" | i <- [1 .. 24 :: Int]]+         in Text.replicate 6 "(" <> "(" <> terms 0 <> ") - (" <> terms 24 <> ")" <> Text.replicate 6 ")",+    -- The parenthesised sub-select has two possible representations; see the+    -- "Canonical shape" note on 'PostgresqlSyntax.Parsing.selectWithParensBody'.+    testCase "redundant parens around a sub-select are canonicalised" $ do+      let expected =+            WithParensSelectWithParens+              . NoParensSelectWithParens+              <$> Parsing.run Parsing.selectNoParens "select 1"+      Parsing.run Parsing.selectWithParens "((select 1))" @?= expected,+    testCase "OVERLAPS still parses" $ do+      let render = Rendering.toText . Rendering.aExpr+      fmap render (Parsing.run Parsing.aExpr "(1, 2) overlaps (3, 4)")+        @?= Right "(1, 2) OVERLAPS (3, 4)"+      fmap render (Parsing.run Parsing.aExpr "row(1, 2) overlaps row(3, 4)")+        @?= Right "ROW (1, 2) OVERLAPS ROW (3, 4)"+  ]+  where+    parsesWithin name seconds parser input =+      testCase name $ do+        result <- timeout (seconds * 1000000) $ case Parsing.run parser input of+          Left err -> assertFailure (err <> "\ninput: " <> Text.unpack input)+          Right _ -> return ()+        case result of+          Nothing -> assertFailure ("Did not finish parsing within " <> show seconds <> "s")+          Just () -> return ()