diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +-- | +-- Benchmark for the "keyword allocation cost in wide alternations" concern +-- raised in . +-- +-- Compares the shipped, cheap 'PostgresqlSyntax.Parsing.keyword' +-- (a bare 'empty' on mismatch, no allocation beyond the consumed text) +-- against a richer alternative that reports a proper \"expected one of ...\" +-- error via 'Text.Megaparsec.failure' (as PR #20 proposed), the way it would +-- behave sitting inside a wide 'asum'\/'choice' of keyword alternatives. +-- +-- Both implementations here pin the reported error offset via +-- 'Megaparsec.setOffset', matching the fix applied to the shipped +-- 'PostgresqlSyntax.Parsing.keyword' to stay correct under megaparsec +-- >=9.8's stricter '(<|>)' error-merging. That fix is what makes the rich +-- variant produce complete "expecting ..." lists at all under current +-- megaparsec; see 'PostgresqlSyntax.Parsing.keyword''s haddock. +module Main where + +import Criterion.Main +import qualified Data.Char as Char +import qualified Data.HashSet as HashSet +import qualified Data.Set as Set +import qualified Data.Text as Text +import HeadedMegaparsec (HeadedParsec, parse, toParsec) +import qualified Hedgehog.Gen as Gen +import qualified Main.Gen as SynGen +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import qualified PostgresqlSyntax.Parsing as Parsing +import qualified PostgresqlSyntax.Rendering as Rendering +import qualified Text.Megaparsec as Megaparsec +import Prelude + +-- * Shared token scanner (mirrors 'PostgresqlSyntax.Parsing.anyKeyword') + +firstIdentifierChar :: Char -> Bool +firstIdentifierChar x = Char.isAlpha x || x == '_' || x >= '\200' && x <= '\377' + +notFirstIdentifierChar :: Char -> Bool +notFirstIdentifierChar x = Char.isAlphaNum x || x == '_' || x == '$' || x >= '\200' && x <= '\377' + +anyKeywordRaw :: Megaparsec.Parsec Void Text.Text Text.Text +anyKeywordRaw = + Megaparsec.label "keyword" $ do + firstChar <- Megaparsec.satisfy firstIdentifierChar + remainder <- Megaparsec.takeWhileP Nothing notFirstIdentifierChar + return (Text.toLower (Text.cons firstChar remainder)) + +-- * The two candidate implementations + +-- | Shipped implementation: fails with a bare, unlabeled 'empty' on mismatch. +cheapKeyword :: Text.Text -> HeadedParsec Void Text.Text Text.Text +cheapKeyword expected = parse $ do + off <- Megaparsec.getOffset + parsed <- anyKeywordRaw + if expected == parsed then return parsed else Megaparsec.setOffset off *> empty + +-- | PR #20-style implementation: fails with an explicit chunk expectation, +-- so failed alternatives can be unioned into a readable "expecting one of +-- ..." message. Allocates a 'NonEmpty' 'Char' and a 'Set' per failed branch. +richKeyword :: Text.Text -> HeadedParsec Void Text.Text Text.Text +richKeyword expected = parse $ do + off <- Megaparsec.getOffset + parsed <- anyKeywordRaw + if expected == parsed then return parsed else Megaparsec.setOffset off *> chunkFailure expected parsed + where + chunkFailure expectedTxt givenTxt = + Megaparsec.failure + (Just (errorItemConverter givenTxt)) + (Set.fromList (pure (errorItemConverter expectedTxt))) + errorItemConverter t = Megaparsec.Tokens $ case Text.uncons t of + Just (h, rest) -> h :| Text.unpack rest + Nothing -> ' ' :| [] + +runHeaded :: HeadedParsec Void Text.Text a -> Text.Text -> Either (Megaparsec.ParseErrorBundle Text.Text Void) a +runHeaded p = Megaparsec.runParser (toParsec p <* Megaparsec.eof) "" + +-- * Wide-alternation scenarios + +-- | An alternation over every element of the given keyword list, dispatched +-- via the given per-keyword implementation. This is the shape 'keyword' +-- actually sits in throughout the grammar: many 'HeadedParsec' alternatives +-- tried in sequence via '(<|>)'\/'asum'. +wideAlternation :: (Text.Text -> HeadedParsec Void Text.Text Text.Text) -> [Text.Text] -> HeadedParsec Void Text.Text Text.Text +wideAlternation impl kws = asum (map impl kws) + +main :: IO () +main = do + let reservedWords = HashSet.toList KeywordSet.reservedKeyword -- ~90 words: the size of a typical mid-size dispatch + allWords = HashSet.toList KeywordSet.keyword -- ~440 words: the full reserved-word set, worst case + lastOf xs = last xs + noMatchToken = "zzzznotakeyword" :: Text.Text + + corpus <- replicateM 500 (Gen.sample (Gen.resize 15 SynGen.preparableStmt)) + let corpusTexts = map (Rendering.toText . Rendering.preparableStmt) corpus + + defaultMain + [ bgroup + "keyword in wide alternation" + [ bgroup + (label <> ", " <> scenario) + [ bench "cheap" $ whnf (runHeaded (wideAlternation cheapKeyword kws)) token, + bench "rich" $ whnf (runHeaded (wideAlternation richKeyword kws)) token + ] + | (label, kws) <- [("~90 words", reservedWords), ("~440 words", allWords)], + (scenario, token) <- + [ ("first match", head kws), + ("last match", lastOf kws), + ("no match", noMatchToken) + ] + ], + bgroup + "full grammar on generated corpus (reference, shipped keyword only)" + [bench "500 generated preparableStmt" $ nf (map (either (const False) (const True) . Parsing.run Parsing.preparableStmt)) corpusTexts] + ] 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 @@ -879,8 +879,6 @@ ident = identWithSet mempty -typeName = identWithSet KeywordSet.typeFunctionName - name = identWithSet KeywordSet.colId cursorName = name @@ -915,7 +913,7 @@ attrName = colLabel -typeFunctionName = name +typeFunctionName = identWithSet KeywordSet.typeFunctionName funcName = choice diff --git a/library/PostgresqlSyntax/Parsing.hs b/library/PostgresqlSyntax/Parsing.hs --- a/library/PostgresqlSyntax/Parsing.hs +++ b/library/PostgresqlSyntax/Parsing.hs @@ -1367,7 +1367,14 @@ ExprListTrimList <$> exprList ] -funcApplication = inParensWithLabel FuncApplication funcName (optional funcApplicationParams) +-- | +-- \"operator\" immediately followed by \"(\" is always parsed as the start +-- of a qualified operator (@OPERATOR(...)@), never as a call to a function +-- literally named \"operator\", mirroring how real PostgreSQL's grammar +-- resolves the conflict between these two productions in favor of qual_op. +funcApplication = + notFollowedBy (keyword "operator" *> space *> char '(') + *> inParensWithLabel FuncApplication funcName (optional funcApplicationParams) funcApplicationParams = asum @@ -2031,7 +2038,26 @@ return (Text.toLower (Text.cons firstChar remainder)) -- | Expected keyword -keyword a = mfilter (a ==) anyKeyword +-- +-- Wraps the head in 'Megaparsec.region' to pin the reported error offset to +-- where this keyword check began. Without this, megaparsec >=9.8's stricter +-- (and correct) '(<|>)' error-merging (fix for +-- ) normalizes any error +-- whose offset lands past the enclosing alternative's start back down to +-- that start, discarding its \"expecting\" set unless the offset already +-- matches exactly. Since every failed keyword branch consumes some +-- identifier text before comparing, its offset always landed past the +-- alternative's start, so wide 'asum'/'choice' chains of 'keyword' lost +-- their combined expected-token sets under 9.8. Pinning the offset up front +-- keeps every branch's offset aligned with the alternative's start, so +-- their expected sets still union correctly. +keyword a = parse $ do + off <- Megaparsec.getOffset + Megaparsec.region (Megaparsec.setErrorOffset off) $ do + firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar + remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar + let parsedKeyword = Text.toLower (Text.cons firstChar remainder) + if a == parsedKeyword then return parsedKeyword else empty -- | -- Consume a keyphrase, ignoring case and types of spaces between words. 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.1 +version: 0.4.3.2 category: Database, PostgreSQL, Parsing synopsis: PostgreSQL AST parsing and rendering description: @@ -114,5 +114,24 @@ other-modules: Main.Gen build-depends: hedgehog >=1.0.1 && <2, + postgresql-syntax, + rerebase >=1.6.1 && <2, + +benchmark keyword-bench + import: base-settings + type: exitcode-stdio-1.0 + hs-source-dirs: + bench + hedgehog-test + + main-is: Main.hs + ghc-options: -O2 + other-modules: Main.Gen + build-depends: + containers >=0.4 && <1, + criterion >=1.6 && <1.7, + headed-megaparsec >=0.2.0.1 && <0.3, + hedgehog >=1.0.1 && <2, + megaparsec >=9.2 && <10, 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 @@ -99,6 +99,6 @@ [ "select i :: int8 from auth.user as u\n\ \WHERE u.id IS NO NULL && TRUE" ] - "(53,\"offset=53:\\nexpecting white space\\n\")" + "(51,\"offset=51:\\nexpecting white space\\n\")" ] ]