diff --git a/hedgehog-test/Main/Gen.hs b/hedgehog-test/Main/Gen.hs --- a/hedgehog-test/Main/Gen.hs +++ b/hedgehog-test/Main/Gen.hs @@ -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 diff --git a/library/PostgresqlSyntax/Parsing.hs b/library/PostgresqlSyntax/Parsing.hs --- a/library/PostgresqlSyntax/Parsing.hs +++ b/library/PostgresqlSyntax/Parsing.hs @@ -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 = diff --git a/library/PostgresqlSyntax/Prelude.hs b/library/PostgresqlSyntax/Prelude.hs --- a/library/PostgresqlSyntax/Prelude.hs +++ b/library/PostgresqlSyntax/Prelude.hs @@ -2,6 +2,7 @@ ( module Exports, showAsText, suffixRec, + extendMany, ) where diff --git a/nesting-bench/Main.hs b/nesting-bench/Main.hs new file mode 100644 --- /dev/null +++ b/nesting-bench/Main.hs @@ -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] diff --git a/postgresql-syntax.cabal b/postgresql-syntax.cabal --- a/postgresql-syntax.cabal +++ b/postgresql-syntax.cabal @@ -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, diff --git a/tasty-test/Main.hs b/tasty-test/Main.hs --- a/tasty-test/Main.hs +++ b/tasty-test/Main.hs @@ -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 ()