diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,116 @@ +# v0.5.0.2 + +## Non-breaking + +- `PostgresqlSyntax.Algebra`'s `LeftRecursion base ext item` class (internal-library-only, not part of the public `PostgresqlSyntax` API) is now a single-method `Extends base ext` — drops the unread `item` type parameter: `extension`/`applyExtension`/`foldExtensions` are gone in favor of one `parseExtensions` method; `nonRecursiveParser` → `parseBase`; `parseLeftRecursive` → `parseMaybeExtended`; `leftRecursionProperties` → `extendedByProperties`. `JoinedTableExtension` is deleted (#33). +- `TableRef.hs` and `FuncApplicationParams.hs` now have explicit export lists, exporting only their types and instances (#30). + +## Fixes + +- Fixed the parsed tree shape of `UNION`/`INTERSECT`/`EXCEPT` chains to match Postgres's actual associativity and precedence (`gram.y`'s `%left UNION EXCEPT` / `%left INTERSECT`, INTERSECT binding tighter): `a EXCEPT b EXCEPT c` now nests left instead of right, and `a INTERSECT b UNION c` now roots at `UNION` instead of `INTERSECT`. Rendered text is unaffected; only `SimpleSelect`'s parsed/canonical tree shape for such chains changes (#30). +- Fixed a further associativity bug in the same fold: a run of two or more consecutive `INTERSECT`s (e.g. `a INTERSECT b INTERSECT c`) nested right instead of left, contradicting `gram.y`'s `%left INTERSECT`. Parsed/canonical tree shape changes for such chains; rendered text is unaffected (#34). +- Fixed `InsertRest` misparsing parenthesized `VALUES`/`SELECT` as a column list (#35). + +# v0.5.0.1 + +## Fixes + +- Added doc-files to the .cabal-file. README.md, LICENSE and CHANGELOG.md. + +# v0.5.0.0 + +## Breaking + +- `IsAst` class methods `parser`/`toTextBuilder` now take a `Settings` parameter + to control parse/render options (e.g. nullability `?` markers). Migration: + `parse x` -> `parse mempty x`, `toText x` -> `toText mempty x`, + `parseWithPosError x` -> `parseWithPosError mempty x`. New public module + `PostgresqlSyntax.Settings` provides the `Settings` type and the + `nullabilityMarkers` constructor. +- Nullability `?` markers in `Typename` are now opt-in via + `nullabilityMarkers True`. In standard mode (`mempty`) they are not + recognized - both flags parse as `False` and a literal `?` in their + position is a parse error. Markers no longer accept a preceding space: + `int ?` -> `int?`. Extended mode gives up one spelling of real Postgres: + `x::jsonb? 'b'` (unspaced jsonb key-existence operator); use + `x::jsonb ? 'b'` or `jsonb_exists(x, 'b')`. +- Removed `PostgresqlSyntax.Parsing` and `PostgresqlSyntax.Rendering`. Every + type's parser and renderer are now the `parser`/`toTextBuilder` methods of + its `IsAst` instance (exported from `PostgresqlSyntax`), and the top-level + entry points moved to the `PostgresqlSyntax` module: `Parsing.run`/`.runWithPosError` + became `PostgresqlSyntax.parse`/`.parseWithPosError`, generalized to work over + any `IsAst` type rather than taking an explicit parser argument. +- `PostgresqlSyntax.KeywordSet` and `PostgresqlSyntax.Validation` are no longer + part of the public API surface. +- Several former type aliases are now distinct ADTs/newtypes instead of bare + `Either`/`Maybe`/primitive aliases: `SelectStmt`, `SelectClause`, + `ExplicitRow`, and the primitive-wrapper newtypes `Sconst`, `Bconst`, + `Xconst`, `Iconst`, `Fconst`, `Op`, `OptVarying`, `Timezone`, + `IntervalSecond`, `OptOrdinality`. Code that pattern-matched these as + `Either`/`Maybe`/`Text`/`Bool` directly needs to match on the new + constructors instead. +- Removed the `SuffixQualOpAExpr` constructor of `AExpr`. It modelled the + postfix operator production (`a_expr qual_Op`), which Postgres removed in + version 14 - `x OPERATOR(pg_catalog.+#)` is a syntax error in every + supported server version, so the parser no longer accepts it and the + renderer can no longer emit it. Code pattern-matching or constructing + `SuffixQualOpAExpr` needs to drop those cases. This also removes a family + of round-trip failures: the rendering ` ` left the + operator without a right-hand side, so reparsing swallowed whatever + keyword followed (`PRECEDING`, `FOLLOWING`, `ROWS`, an implicit column + alias, or - in the postfix case specifically - the `?` of the `Typename` + nullability extension) as its operand. Only the postfix-triggered `?` + swallow is fixed by this; `Op "?"` colliding with the nullability + extension as a *binary* operator is a separate, still-open issue. + +## Fixes + +- Fix the `AExpr`/`BExpr` renderers (and related expression renderers) being + precedence-naive: operators were concatenated without parenthesization, so a + non-canonical but valid AST (e.g. `(NOT x) - y`) could render to SQL that + re-parses to a different tree (`NOT (x - y)`). Renderers now parenthesize + based on operator precedence, making render -> parse round-trip safe for the + full value space of each type, not just parser-canonical trees. + +# v0.4.5.0 + +## Non-breaking + +- Derive `Data` for every AST type in `PostgresqlSyntax.Ast` (#6). Enables + generic (SYB-style) traversals and transformations over the syntax tree, + e.g. for expression normalization. +- Add `parseWithSourcePosError`, like `parseWithPosError` but pairing each + error with a `Text.Megaparsec.SourcePos` instead of a raw `Int` byte + offset, so callers (e.g. `hasql-th`, see + [nikita-volkov/hasql-th#35](https://github.com/nikita-volkov/hasql-th/issues/35)) + can report line/column positions without recomputing them from the input. + +# v0.4.4.0 + +## Fixes + +- Fix parsing time growing exponentially with the nesting depth of an expression (#8). + Inputs as small as `((((((((((((a + b))))))))))))` previously did not finish parsing; + they now parse in well under a millisecond. Three grammar alternatives each parsed + the content of a parenthesised group before discovering they did not apply, tripling + the work per level of nesting; they are now left-factored so each group is parsed once. + Parsing time is linear in input size, with a quadratic term in nesting depth alone + (1000 characters of pure nesting take about a second; realistic input is unaffected). + +## Non-breaking + +- Redundant parentheses around a sub-select now parse to a canonical shape. + `((select 1))` produces `WithParensSelectWithParens`; the equivalent + `NoParensSelectWithParens` of a `SelectNoParens` carrying nothing but that same + parenthesised select is no longer produced. The two rendered identically, so this + only affects which of two equivalent trees you get back. Trees that carry a + set operation, sort clause, limit or locking clause around the parenthesised + select are unaffected. + +# v0.4.3.2 + +## Fixes + +- Fix keyword error reporting under megaparsec >=9.8 (#20) +- Fix OFFSET/aExpr round-trip failure for `OPERATOR(...)` prefix (#11, #22) +- Fix hedgehog generator for `type_function_name` to use its own keyword set diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# postgresql-syntax + +[![Hackage](https://img.shields.io/hackage/v/postgresql-syntax.svg)](https://hackage.haskell.org/package/postgresql-syntax) +[![Continuous Haddock](https://img.shields.io/badge/haddock-master-blue)](https://nikita-volkov.github.io/postgresql-syntax/) + +Postgres syntax tree and related utils extracted from [the "hasql-th" package](https://github.com/nikita-volkov/hasql-th). diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,7 +4,7 @@ -- Benchmark for the "keyword allocation cost in wide alternations" concern -- raised in . -- --- Compares the shipped, cheap 'PostgresqlSyntax.Parsing.keyword' +-- Compares the shipped, cheap 'PostgresqlSyntax.Helpers.Parsers.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 @@ -12,27 +12,23 @@ -- -- 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 +-- 'PostgresqlSyntax.Helpers.Parsers.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. +-- megaparsec; see 'PostgresqlSyntax.Helpers.Parsers.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 qualified PostgresqlSyntax import Prelude +import qualified Test.QuickCheck as Qc +import qualified Text.Megaparsec as Megaparsec --- * Shared token scanner (mirrors 'PostgresqlSyntax.Parsing.anyKeyword') +-- * Shared token scanner (mirrors 'PostgresqlSyntax.Helpers.Parsers.anyKeyword') firstIdentifierChar :: Char -> Bool firstIdentifierChar x = Char.isAlpha x || x == '_' || x >= '\200' && x <= '\377' @@ -76,6 +72,18 @@ runHeaded :: HeadedParsec Void Text.Text a -> Text.Text -> Either (Megaparsec.ParseErrorBundle Text.Text Void) a runHeaded p = Megaparsec.runParser (toParsec p <* Megaparsec.eof) "" +-- * Keyword word lists (sized to mirror the shipped keyword sets) + +-- | ~90 words: the size of a typical mid-size dispatch, mirroring +-- @PostgresqlSyntax.KeywordSet.reservedKeyword@. +reservedWords :: [Text.Text] +reservedWords = ["all", "analyse", "analyze", "and", "any", "array", "as", "asc", "asymmetric", "both", "case", "cast", "check", "collate", "column", "constraint", "create", "current_catalog", "current_date", "current_role", "current_time", "current_timestamp", "current_user", "default", "deferrable", "desc", "distinct", "do", "else", "end", "except", "false", "fetch", "for", "foreign", "from", "grant", "group", "having", "in", "initially", "intersect", "into", "lateral", "leading", "limit", "localtime", "localtimestamp", "not", "null", "offset", "on", "only", "or", "order", "placing", "primary", "references", "returning", "select", "session_user", "some", "symmetric", "table", "then", "to", "trailing", "true", "union", "unique", "user", "using", "variadic", "when", "where", "window", "with"] + +-- | ~440 words: the full reserved-word set, worst case, mirroring +-- @PostgresqlSyntax.KeywordSet.keyword@. +allWords :: [Text.Text] +allWords = ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "all", "also", "alter", "always", "analyse", "analyze", "and", "any", "array", "as", "asc", "assertion", "assignment", "asymmetric", "at", "attach", "attribute", "authorization", "backward", "before", "begin", "between", "bigint", "binary", "bit", "boolean", "both", "by", "cache", "call", "called", "cascade", "cascaded", "case", "cast", "catalog", "chain", "char", "character", "characteristics", "check", "checkpoint", "class", "close", "cluster", "coalesce", "collate", "collation", "column", "columns", "comment", "comments", "commit", "committed", "concurrently", "configuration", "conflict", "connection", "constraint", "constraints", "content", "continue", "conversion", "copy", "cost", "create", "cross", "csv", "cube", "current", "current_catalog", "current_date", "current_role", "current_schema", "current_time", "current_timestamp", "current_user", "cursor", "cycle", "data", "database", "day", "deallocate", "dec", "decimal", "declare", "default", "defaults", "deferrable", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "desc", "detach", "dictionary", "disable", "discard", "distinct", "do", "document", "domain", "double", "drop", "each", "else", "enable", "encoding", "encrypted", "end", "enum", "escape", "event", "except", "exclude", "excluding", "exclusive", "execute", "exists", "explain", "expression", "extension", "external", "extract", "false", "family", "fetch", "filter", "first", "float", "following", "for", "force", "foreign", "forward", "freeze", "from", "full", "function", "functions", "generated", "global", "grant", "granted", "greatest", "group", "grouping", "groups", "handler", "having", "header", "hold", "hour", "identity", "if", "ilike", "immediate", "immutable", "implicit", "import", "in", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "initially", "inline", "inner", "inout", "input", "insensitive", "insert", "instead", "int", "integer", "intersect", "interval", "into", "invoker", "is", "isnull", "isolation", "join", "key", "label", "language", "large", "last", "lateral", "leading", "leakproof", "least", "left", "level", "like", "limit", "listen", "load", "local", "localtime", "localtimestamp", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "national", "natural", "nchar", "new", "next", "nfc", "nfd", "nfkc", "nfkd", "no", "none", "normalize", "normalized", "not", "nothing", "notify", "notnull", "nowait", "null", "nullif", "nulls", "numeric", "object", "of", "off", "offset", "oids", "old", "on", "only", "operator", "option", "options", "or", "order", "ordinality", "others", "out", "outer", "over", "overlaps", "overlay", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "placing", "plans", "policy", "position", "preceding", "precision", "prepare", "prepared", "preserve", "primary", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "real", "reassign", "recheck", "recursive", "ref", "references", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returning", "returns", "revoke", "right", "role", "rollback", "rollup", "routine", "routines", "row", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "select", "sequence", "sequences", "serializable", "server", "session", "session_user", "set", "setof", "sets", "share", "show", "similar", "simple", "skip", "smallint", "snapshot", "some", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "substring", "support", "symmetric", "sysid", "system", "table", "tables", "tablesample", "tablespace", "temp", "template", "temporary", "text", "then", "ties", "time", "timestamp", "to", "trailing", "transaction", "transform", "treat", "trigger", "trim", "true", "truncate", "trusted", "type", "types", "uescape", "unbounded", "uncommitted", "unencrypted", "union", "unique", "unknown", "unlisten", "unlogged", "until", "update", "user", "using", "vacuum", "valid", "validate", "validator", "value", "values", "varchar", "variadic", "varying", "verbose", "version", "view", "views", "volatile", "when", "where", "whitespace", "window", "with", "within", "without", "work", "wrapper", "write", "xml", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable", "year", "yes", "zone"] + -- * Wide-alternation scenarios -- | An alternation over every element of the given keyword list, dispatched @@ -87,13 +95,13 @@ 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 + let lastOf xs = last xs + firstOf (x : _) = x + firstOf [] = error "empty keyword list" noMatchToken = "zzzznotakeyword" :: Text.Text - corpus <- replicateM 500 (Gen.sample (Gen.resize 15 SynGen.preparableStmt)) - let corpusTexts = map (Rendering.toText . Rendering.preparableStmt) corpus + corpus <- replicateM 500 (Qc.generate (Qc.resize 15 (Qc.arbitrary @PostgresqlSyntax.PreparableStmt))) + let corpusTexts = map (PostgresqlSyntax.toText mempty) corpus defaultMain [ bgroup @@ -105,12 +113,12 @@ ] | (label, kws) <- [("~90 words", reservedWords), ("~440 words", allWords)], (scenario, token) <- - [ ("first match", head kws), + [ ("first match", firstOf 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] + [bench "500 generated preparableStmt" $ nf (map (either (const False) (const True) . PostgresqlSyntax.parse @PostgresqlSyntax.PreparableStmt mempty)) corpusTexts] ] diff --git a/hedgehog-test/Main.hs b/hedgehog-test/Main.hs deleted file mode 100644 --- a/hedgehog-test/Main.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Main where - -import qualified Data.Text as Text -import Hedgehog -import Hedgehog.Main -import qualified Main.Gen as Gen -import qualified PostgresqlSyntax.Parsing as Parsing -import qualified PostgresqlSyntax.Rendering as Rendering -import Prelude - -main :: IO () -main = - defaultMain - [ checkParallel - $ Group "Parsing a rendered AST produces the same AST" - $ let p name amount gen parser renderer = - (,) name - $ withDiscards (fromIntegral amount * 200) - $ withTests amount - $ property - $ do - ast <- forAll gen - let sql = Rendering.toText (renderer ast) - in do - footnote ("SQL: " <> Text.unpack sql) - case Parsing.run parser sql of - Left err -> do - footnote err - failure - Right ast' -> ast === ast' - in [ p "typename" 10000 Gen.typename Parsing.typename Rendering.typename, - p "tableRef" 10000 Gen.tableRef Parsing.tableRef Rendering.tableRef, - p "aExpr" 60000 Gen.aExpr Parsing.aExpr Rendering.aExpr, - p "preparableStmt" 30000 Gen.preparableStmt Parsing.preparableStmt Rendering.preparableStmt - ] - ] diff --git a/hedgehog-test/Main/Gen.hs b/hedgehog-test/Main/Gen.hs deleted file mode 100644 --- a/hedgehog-test/Main/Gen.hs +++ /dev/null @@ -1,971 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-signatures #-} - -module Main.Gen where - -import qualified Data.HashSet as HashSet -import qualified Data.List as List -import qualified Data.Text as Text -import Hedgehog (Gen) -import Hedgehog.Gen -import qualified Hedgehog.Range as Range -import PostgresqlSyntax.Ast -import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import qualified PostgresqlSyntax.Validation as Validation -import Prelude hiding (bit, bool, filter, fromList, maybe, sortBy) - --- * Generic - -inSet set = filter (flip HashSet.member set) - -notInSet set = filter (not . flip HashSet.member set) - --- * Statements - -preparableStmt = - choice - [ SelectPreparableStmt <$> selectStmt, - InsertPreparableStmt <$> insertStmt, - UpdatePreparableStmt <$> updateStmt, - DeletePreparableStmt <$> deleteStmt, - CallPreparableStmt <$> callStmt - ] - --- * Call - -callStmt = CallStmt <$> funcApplication - --- * Insert - -insertStmt = InsertStmt <$> maybe withClause <*> insertTarget <*> insertRest <*> maybe onConflict <*> maybe returningClause - -insertTarget = InsertTarget <$> qualifiedName <*> maybe colId - -insertRest = - choice - [ SelectInsertRest <$> maybe insertColumnList <*> maybe overrideKind <*> selectStmt, - pure DefaultValuesInsertRest - ] - -overrideKind = enumBounded - -insertColumnList = nonEmpty (Range.exponential 1 7) insertColumnItem - -insertColumnItem = InsertColumnItem <$> colId <*> maybe indirection - -onConflict = OnConflict <$> maybe confExpr <*> onConflictDo - -onConflictDo = - choice - [ UpdateOnConflictDo <$> setClauseList <*> maybe whereClause, - pure NothingOnConflictDo - ] - -confExpr = - choice - [ WhereConfExpr <$> indexParams <*> maybe whereClause, - ConstraintConfExpr <$> name - ] - -returningClause = targetList - --- * Update - -updateStmt = UpdateStmt <$> maybe withClause <*> relationExprOptAlias <*> setClauseList <*> maybe fromClause <*> maybe whereOrCurrentClause <*> maybe returningClause - -setClauseList = nonEmpty (Range.exponential 1 10) setClause - -setClause = - choice - [ TargetSetClause <$> setTarget <*> aExpr, - TargetListSetClause <$> setTargetList <*> aExpr - ] - -setTarget = SetTarget <$> colId <*> maybe indirection - -setTargetList = nonEmpty (Range.exponential 1 10) setTarget - --- * Delete - -deleteStmt = DeleteStmt <$> maybe withClause <*> relationExprOptAlias <*> maybe usingClause <*> maybe whereOrCurrentClause <*> maybe returningClause - -usingClause = fromList - --- * Select - -selectStmt = Left <$> selectNoParens - --- ** selectNoParens - -selectNoParens = - frequency - [ (90, SelectNoParens <$> maybe withClause <*> (Left <$> simpleSelect) <*> maybe sortClause <*> maybe selectLimit <*> maybe 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 - --- ** selectWithParens - -selectWithParens = sized $ \size -> - if size <= 1 - then discard - else - frequency - [ (95, NoParensSelectWithParens <$> selectNoParens), - (5, WithParensSelectWithParens <$> selectWithParens) - ] - -terminalSelectWithParens = NoParensSelectWithParens <$> terminalSelectNoParens - --- ** selectClause - -selectClause = - choice - [ Left <$> simpleSelect, - Right <$> small selectWithParens - ] - -nonTrailingSelectClause = Left <$> nonTrailingSimpleSelect - --- ** simpleSelect - -simpleSelect = - choice - [ normalSimpleSelect, - tableSimpleSelect, - valuesSimpleSelect, - small nonTrailingSelectClause >>= binSimpleSelect - ] - -nonTrailingSimpleSelect = choice [normalSimpleSelect, valuesSimpleSelect, tableSimpleSelect] - -normalSimpleSelect = NormalSimpleSelect <$> maybe targeting <*> maybe intoClause <*> maybe fromClause <*> maybe whereClause <*> maybe groupClause <*> maybe havingClause <*> maybe windowClause - -tableSimpleSelect = TableSimpleSelect <$> relationExpr - -valuesSimpleSelect = ValuesSimpleSelect <$> valuesClause - -binSimpleSelect leftSelect = - BinSimpleSelect <$> selectBinOp <*> pure leftSelect <*> maybe allOrDistinct <*> small selectClause - -terminalSimpleSelect = pure (NormalSimpleSelect Nothing Nothing Nothing Nothing Nothing Nothing Nothing) - --- * Targeting - -targeting = - choice - [ NormalTargeting <$> targetList, - AllTargeting <$> maybe targetList, - DistinctTargeting <$> maybe (nonEmpty (Range.exponential 1 8) aExpr) <*> targetList - ] - -targetList = nonEmpty (Range.exponential 1 8) targetEl - -targetEl = - choice - [ pure AsteriskTargetEl, - AliasedExprTargetEl <$> aExpr <*> colLabel, - ImplicitlyAliasedExprTargetEl <$> prefixAExpr <*> ident, - ExprTargetEl <$> aExpr - ] - --- * BinSimpleSelect - -selectBinOp = element [UnionSelectBinOp, IntersectSelectBinOp, ExceptSelectBinOp] - --- * With Clause - -withClause = WithClause <$> bool <*> nonEmpty (Range.exponential 1 7) commonTableExpr - -commonTableExpr = CommonTableExpr <$> name <*> maybe (nonEmpty (Range.exponential 1 8) name) <*> maybe bool <*> small preparableStmt - --- * Into Clause - -intoClause = optTempTableName - -optTempTableName = - choice - [ TemporaryOptTempTableName <$> bool <*> qualifiedName, - TempOptTempTableName <$> bool <*> qualifiedName, - LocalTemporaryOptTempTableName <$> bool <*> qualifiedName, - LocalTempOptTempTableName <$> bool <*> qualifiedName, - GlobalTemporaryOptTempTableName <$> bool <*> qualifiedName, - GlobalTempOptTempTableName <$> bool <*> qualifiedName, - UnloggedOptTempTableName <$> bool <*> qualifiedName, - TableOptTempTableName <$> qualifiedName, - QualifedOptTempTableName <$> qualifiedName - ] - --- * From Clause - -fromList = nonEmpty (Range.exponential 1 8) tableRef - -fromClause = fromList - -tableRef = choice [relationExprTableRef, selectTableRef, joinTableRef] - -relationExprTableRef = RelationExprTableRef <$> relationExpr <*> maybe aliasClause <*> maybe tablesampleClause - -funcTableRef = FuncTableRef <$> bool <*> funcTable <*> maybe funcAliasClause - -selectTableRef = SelectTableRef <$> bool <*> small selectWithParens <*> maybe aliasClause - -joinTableRef = JoinTableRef <$> joinedTable <*> maybe aliasClause - -relationExpr = - choice - [ SimpleRelationExpr <$> qualifiedName <*> bool, - OnlyRelationExpr <$> qualifiedName <*> bool - ] - -relationExprOptAlias = RelationExprOptAlias <$> relationExpr <*> maybe ((,) <$> bool <*> colId) - -tablesampleClause = TablesampleClause <$> funcName <*> exprList <*> maybe repeatableClause - -repeatableClause = aExpr - -funcTable = - choice - [ FuncExprFuncTable <$> funcExprWindowless <*> optOrdinality, - RowsFromFuncTable <$> rowsfromList <*> optOrdinality - ] - -rowsfromItem = RowsfromItem <$> funcExprWindowless <*> maybe colDefList - -rowsfromList = nonEmpty (Range.exponential 1 8) rowsfromItem - -colDefList = tableFuncElementList - -optOrdinality = bool - -tableFuncElementList = nonEmpty (Range.exponential 1 7) tableFuncElement - -tableFuncElement = TableFuncElement <$> colId <*> typename <*> maybe collateClause - -collateClause = anyName - -aliasClause = AliasClause <$> bool <*> name <*> maybe (nonEmpty (Range.exponential 1 8) name) - -funcAliasClause = - choice - [ AliasFuncAliasClause <$> aliasClause, - AsFuncAliasClause <$> tableFuncElementList, - AsColIdFuncAliasClause <$> colId <*> tableFuncElementList, - ColIdFuncAliasClause <$> colId <*> tableFuncElementList - ] - -joinedTable = - frequency - [ (5,) $ InParensJoinedTable <$> joinedTable, - (95,) $ MethJoinedTable <$> joinMeth <*> tableRef <*> choice [relationExprTableRef, selectTableRef, funcTableRef] - ] - -joinMeth = - choice - [ pure CrossJoinMeth, - QualJoinMeth <$> maybe joinType <*> joinQual, - NaturalJoinMeth <$> maybe joinType - ] - -joinType = - choice - [ FullJoinType <$> bool, - LeftJoinType <$> bool, - RightJoinType <$> bool, - pure InnerJoinType - ] - -joinQual = - choice - [ UsingJoinQual <$> nonEmpty (Range.exponential 1 8) name, - OnJoinQual <$> aExpr - ] - --- * Group Clause - -groupClause = nonEmpty (Range.exponential 1 8) groupByItem - -groupByItem = - choice - [ ExprGroupByItem <$> aExpr, - pure EmptyGroupingSetGroupByItem, - RollupGroupByItem <$> nonEmpty (Range.exponential 1 8) aExpr, - CubeGroupByItem <$> nonEmpty (Range.exponential 1 8) aExpr, - GroupingSetsGroupByItem <$> nonEmpty (Range.exponential 1 3) groupByItem - ] - --- * Having Clause - -havingClause = aExpr - --- * Where Clause - -whereClause = aExpr - -whereOrCurrentClause = - choice - [ ExprWhereOrCurrentClause <$> aExpr, - CursorWhereOrCurrentClause <$> cursorName - ] - --- * Window Clause - -windowClause = nonEmpty (Range.exponential 1 8) windowDefinition - -windowDefinition = WindowDefinition <$> name <*> windowSpecification - -windowSpecification = WindowSpecification <$> maybe name <*> maybe (nonEmpty (Range.exponential 1 8) nonSuffixOpAExpr) <*> maybe sortClause <*> maybe frameClause - -frameClause = FrameClause <$> frameClauseMode <*> frameExtent <*> maybe windowExclusionClause - -frameClauseMode = element [RangeFrameClauseMode, RowsFrameClauseMode, GroupsFrameClauseMode] - -frameExtent = - choice - [ SingularFrameExtent <$> frameBound, - BetweenFrameExtent <$> frameBound <*> frameBound - ] - -frameBound = - choice - [ pure UnboundedPrecedingFrameBound, - pure UnboundedFollowingFrameBound, - pure CurrentRowFrameBound, - PrecedingFrameBound <$> prefixAExpr, - FollowingFrameBound <$> prefixAExpr - ] - -windowExclusionClause = element [CurrentRowWindowExclusionClause, GroupWindowExclusionClause, TiesWindowExclusionClause, NoOthersWindowExclusionClause] - --- * Values Clause - -valuesClause = nonEmpty (Range.exponential 1 8) (nonEmpty (Range.exponential 1 8) aExpr) - --- * Sort Clause - -sortClause = nonEmpty (Range.exponential 1 8) sortBy - -sortBy = - choice - [ UsingSortBy <$> nonSuffixOpAExpr <*> qualAllOp <*> maybe nullsOrder, - AscDescSortBy <$> nonSuffixOpAExpr <*> maybe ascDesc <*> maybe nullsOrder - ] - --- * All or distinct - -allOrDistinct = bool - --- * Limit - -selectLimit = - choice - [ LimitOffsetSelectLimit <$> limitClause <*> offsetClause, - OffsetLimitSelectLimit <$> offsetClause <*> limitClause, - LimitSelectLimit <$> limitClause, - OffsetSelectLimit <$> offsetClause - ] - -limitClause = - choice - [ LimitLimitClause <$> selectLimitValue <*> maybe aExpr, - FetchOnlyLimitClause <$> bool <*> maybe selectFetchFirstValue <*> bool - ] - -selectFetchFirstValue = - choice - [ ExprSelectFetchFirstValue <$> cExpr, - NumSelectFetchFirstValue <$> bool <*> iconstOrFconst - ] - -selectLimitValue = - choice - [ ExprSelectLimitValue <$> aExpr, - pure AllSelectLimitValue - ] - -offsetClause = - choice - [ ExprOffsetClause <$> aExpr, - FetchFirstOffsetClause <$> selectFetchFirstValue <*> bool - ] - --- * For Locking - -forLockingClause = - choice - [ ItemsForLockingClause <$> nonEmpty (Range.exponential 1 8) forLockingItem, - pure ReadOnlyForLockingClause - ] - -forLockingItem = ForLockingItem <$> forLockingStrength <*> maybe (nonEmpty (Range.exponential 1 8) qualifiedName) <*> maybe bool - -forLockingStrength = - element - [ UpdateForLockingStrength, - NoKeyUpdateForLockingStrength, - ShareForLockingStrength, - KeyForLockingStrength - ] - --- * Expressions - -exprList = nonEmpty (Range.exponential 1 7) aExpr - -aExpr = - recursive - choice - [ CExprAExpr <$> cExpr, - pure DefaultAExpr - ] - [ TypecastAExpr <$> prefixAExpr <*> typename, - CollateAExpr <$> prefixAExpr <*> anyName, - AtTimeZoneAExpr <$> prefixAExpr <*> aExpr, - PlusAExpr <$> aExpr, - MinusAExpr <$> aExpr, - SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> aExpr, - PrefixQualOpAExpr <$> qualOp <*> aExpr, - SuffixQualOpAExpr <$> prefixAExpr <*> qualOp, - AndAExpr <$> prefixAExpr <*> aExpr, - OrAExpr <$> prefixAExpr <*> aExpr, - NotAExpr <$> aExpr, - VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe aExpr, - ReversableOpAExpr <$> prefixAExpr <*> bool <*> aExprReversableOp, - IsnullAExpr <$> prefixAExpr, - NotnullAExpr <$> prefixAExpr, - OverlapsAExpr <$> row <*> row, - SubqueryAExpr <$> prefixAExpr <*> subqueryOp <*> subType <*> choice [Left <$> selectWithParens, Right <$> nonSelectAExpr], - UniqueAExpr <$> selectWithParens - ] - -prefixAExpr = - choice - [ CExprAExpr <$> cExpr, - pure DefaultAExpr, - UniqueAExpr <$> selectWithParens - ] - -nonSuffixOpAExpr = - recursive - choice - [ CExprAExpr <$> cExpr, - pure DefaultAExpr - ] - [ TypecastAExpr <$> prefixAExpr <*> typename, - CollateAExpr <$> prefixAExpr <*> anyName, - AtTimeZoneAExpr <$> prefixAExpr <*> nonSuffixOpAExpr, - PlusAExpr <$> nonSuffixOpAExpr, - MinusAExpr <$> nonSuffixOpAExpr, - SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> nonSuffixOpAExpr, - PrefixQualOpAExpr <$> qualOp <*> nonSuffixOpAExpr, - AndAExpr <$> prefixAExpr <*> nonSuffixOpAExpr, - OrAExpr <$> prefixAExpr <*> nonSuffixOpAExpr, - NotAExpr <$> nonSuffixOpAExpr, - VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe nonSuffixOpAExpr, - IsnullAExpr <$> prefixAExpr, - NotnullAExpr <$> prefixAExpr, - UniqueAExpr <$> selectWithParens - ] - -nonSelectAExpr = - choice - [ TypecastAExpr <$> prefixAExpr <*> typename, - CollateAExpr <$> prefixAExpr <*> anyName, - AtTimeZoneAExpr <$> prefixAExpr <*> aExpr, - PlusAExpr <$> aExpr, - MinusAExpr <$> aExpr, - SymbolicBinOpAExpr <$> prefixAExpr <*> symbolicExprBinOp <*> aExpr, - PrefixQualOpAExpr <$> qualOp <*> aExpr, - SuffixQualOpAExpr <$> prefixAExpr <*> qualOp, - AndAExpr <$> prefixAExpr <*> aExpr, - OrAExpr <$> prefixAExpr <*> aExpr, - NotAExpr <$> aExpr, - VerbalExprBinOpAExpr <$> prefixAExpr <*> bool <*> verbalExprBinOp <*> prefixAExpr <*> maybe aExpr, - ReversableOpAExpr <$> prefixAExpr <*> bool <*> aExprReversableOp, - IsnullAExpr <$> prefixAExpr, - NotnullAExpr <$> prefixAExpr, - OverlapsAExpr <$> row <*> row, - SubqueryAExpr <$> prefixAExpr <*> subqueryOp <*> subType <*> choice [Left <$> selectWithParens, Right <$> nonSelectAExpr], - UniqueAExpr <$> selectWithParens - ] - -bExpr = - recursive - choice - [ CExprBExpr <$> cExpr - ] - [ TypecastBExpr <$> prefixBExpr <*> typename, - PlusBExpr <$> bExpr, - MinusBExpr <$> bExpr, - SymbolicBinOpBExpr <$> prefixBExpr <*> symbolicExprBinOp <*> bExpr, - QualOpBExpr <$> qualOp <*> bExpr, - IsOpBExpr <$> prefixBExpr <*> bool <*> bExprIsOp - ] - -prefixBExpr = - choice - [ CExprBExpr <$> cExpr - ] - -cExpr = - recursive - choice - [ ColumnrefCExpr <$> columnref - ] - [ AexprConstCExpr <$> aexprConst, - ParamCExpr <$> integral (Range.linear 1 19) <*> maybe indirection, - InParensCExpr <$> nonSelectAExpr <*> maybe indirection, - CaseCExpr <$> caseExpr, - FuncCExpr <$> funcExpr, - SelectWithParensCExpr <$> selectWithParens <*> maybe indirection, - ExistsCExpr <$> selectWithParens, - ArrayCExpr <$> choice [Left <$> selectWithParens, Right <$> arrayExpr], - ExplicitRowCExpr <$> explicitRow, - ImplicitRowCExpr <$> implicitRow, - GroupingCExpr <$> exprList - ] - -caseExpr = CaseExpr <$> maybe aExpr <*> whenClauseList <*> maybe aExpr - -whenClauseList = nonEmpty (Range.exponential 1 7) whenClause - -whenClause = WhenClause <$> small aExpr <*> small aExpr - -inExpr = - choice - [ SelectInExpr <$> NoParensSelectWithParens <$> selectNoParens, - ExprListInExpr <$> exprList - ] - -arrayExpr = - small - $ choice - [ ExprListArrayExpr <$> exprList, - ArrayExprListArrayExpr <$> arrayExprList, - pure EmptyArrayExpr - ] - -arrayExprList = nonEmpty (Range.exponential 1 4) arrayExpr - -row = - choice - [ ExplicitRowRow <$> explicitRow, - ImplicitRowRow <$> implicitRow - ] - -explicitRow = maybe exprList - -implicitRow = ImplicitRow <$> exprList <*> aExpr - --- ** FuncExpr - -funcExpr = - choice - [ ApplicationFuncExpr <$> funcApplication <*> maybe withinGroupClause <*> maybe filterClause <*> maybe overClause, - SubexprFuncExpr <$> funcExprCommonSubexpr - ] - -funcExprWindowless = - choice - [ ApplicationFuncExprWindowless <$> funcApplication, - CommonSubexprFuncExprWindowless <$> funcExprCommonSubexpr - ] - -funcApplication = FuncApplication <$> funcName <*> maybe funcApplicationParams - -funcApplicationParams = - choice - [ NormalFuncApplicationParams <$> maybe allOrDistinct <*> nonEmpty (Range.exponential 1 8) funcArgExpr <*> maybe sortClause, - VariadicFuncApplicationParams <$> maybe (nonEmpty (Range.exponential 1 8) funcArgExpr) <*> funcArgExpr <*> maybe sortClause, - pure StarFuncApplicationParams - ] - -funcArgExpr = - choice - [ ExprFuncArgExpr <$> small aExpr, - ColonEqualsFuncArgExpr <$> name <*> small aExpr, - EqualsGreaterFuncArgExpr <$> name <*> small aExpr - ] - -withinGroupClause = sortClause - -filterClause = aExpr - -overClause = choice [WindowOverClause <$> windowSpecification, ColIdOverClause <$> colId] - -funcExprCommonSubexpr = - choice - [ CollationForFuncExprCommonSubexpr <$> aExpr, - pure CurrentDateFuncExprCommonSubexpr, - CurrentTimeFuncExprCommonSubexpr <$> maybe iconst, - CurrentTimestampFuncExprCommonSubexpr <$> maybe iconst, - LocalTimeFuncExprCommonSubexpr <$> maybe iconst, - LocalTimestampFuncExprCommonSubexpr <$> maybe iconst, - pure CurrentRoleFuncExprCommonSubexpr, - pure CurrentUserFuncExprCommonSubexpr, - pure SessionUserFuncExprCommonSubexpr, - pure UserFuncExprCommonSubexpr, - pure CurrentCatalogFuncExprCommonSubexpr, - pure CurrentSchemaFuncExprCommonSubexpr, - CastFuncExprCommonSubexpr <$> aExpr <*> typename, - ExtractFuncExprCommonSubexpr <$> maybe extractList, - OverlayFuncExprCommonSubexpr <$> overlayList, - PositionFuncExprCommonSubexpr <$> maybe positionList, - SubstringFuncExprCommonSubexpr <$> maybe substrList, - TreatFuncExprCommonSubexpr <$> aExpr <*> typename, - TrimFuncExprCommonSubexpr <$> maybe trimModifier <*> trimList, - NullIfFuncExprCommonSubexpr <$> aExpr <*> aExpr, - CoalesceFuncExprCommonSubexpr <$> exprList, - GreatestFuncExprCommonSubexpr <$> exprList, - LeastFuncExprCommonSubexpr <$> exprList - ] - -extractList = ExtractList <$> extractArg <*> aExpr - -extractArg = - choice - [ IdentExtractArg <$> ident, - pure YearExtractArg, - pure MonthExtractArg, - pure DayExtractArg, - pure HourExtractArg, - pure MinuteExtractArg, - pure SecondExtractArg, - SconstExtractArg <$> sconst - ] - -overlayList = OverlayList <$> aExpr <*> overlayPlacing <*> substrFrom <*> maybe substrFor - -overlayPlacing = aExpr - -positionList = PositionList <$> bExpr <*> bExpr - -substrList = - choice - [ ExprSubstrList <$> aExpr <*> substrListFromFor, - ExprListSubstrList <$> exprList - ] - -substrListFromFor = - choice - [ FromForSubstrListFromFor <$> substrFrom <*> substrFor, - ForFromSubstrListFromFor <$> substrFor <*> substrFrom, - FromSubstrListFromFor <$> substrFrom, - ForSubstrListFromFor <$> substrFor - ] - -substrFrom = aExpr - -substrFor = aExpr - -trimModifier = enumBounded - -trimList = - choice - [ ExprFromExprListTrimList <$> aExpr <*> exprList, - FromExprListTrimList <$> exprList, - ExprListTrimList <$> exprList - ] - --- * Operators - -qualOp = choice [OpQualOp <$> op, OperatorQualOp <$> anyOperator] - -qualAllOp = - choice - [ AllQualAllOp <$> allOp, - AnyQualAllOp <$> anyOperator - ] - -op = do - a <- text (Range.exponential 1 7) (listElement "+-*/<>=~!@#%^&|`?") - case Validation.op a of - Nothing -> return a - _ -> discard - -anyOperator = - recursive - choice - [ AllOpAnyOperator <$> allOp - ] - [ QualifiedAnyOperator <$> colId <*> anyOperator - ] - -allOp = choice [OpAllOp <$> op, MathAllOp <$> mathOp] - -mathOp = enumBounded - -symbolicExprBinOp = - choice - [ MathSymbolicExprBinOp <$> mathOp, - QualSymbolicExprBinOp <$> qualOp - ] - -binOp = element (toList KeywordSet.symbolicBinOp <> ["AND", "OR", "IS DISTINCT FROM", "IS NOT DISTINCT FROM"]) - -verbalExprBinOp = enumBounded - -aExprReversableOp = - choice - [ pure NullAExprReversableOp, - pure TrueAExprReversableOp, - pure FalseAExprReversableOp, - pure UnknownAExprReversableOp, - DistinctFromAExprReversableOp <$> aExpr, - OfAExprReversableOp <$> typeList, - BetweenAExprReversableOp <$> bool <*> bExpr <*> aExpr, - BetweenSymmetricAExprReversableOp <$> bExpr <*> aExpr, - InAExprReversableOp <$> inExpr, - pure DocumentAExprReversableOp - ] - -bExprIsOp = - choice - [ DistinctFromBExprIsOp <$> bExpr, - OfBExprIsOp <$> typeList, - pure DocumentBExprIsOp - ] - -subqueryOp = - choice - [ AllSubqueryOp <$> allOp, - AnySubqueryOp <$> anyOperator, - LikeSubqueryOp <$> bool, - IlikeSubqueryOp <$> bool - ] - --- * Constants - -aexprConst = - choice - [ IAexprConst <$> iconst, - FAexprConst <$> fconst, - SAexprConst <$> sconst, - BAexprConst <$> text (Range.exponential 1 100) (listElement "01"), - XAexprConst <$> text (Range.exponential 1 100) (listElement "0123456789abcdefABCDEF"), - FuncAexprConst <$> funcName <*> maybe funcConstArgs <*> sconst, - ConstTypenameAexprConst <$> constTypename <*> sconst, - StringIntervalAexprConst <$> sconst <*> maybe interval, - IntIntervalAexprConst <$> integral (Range.exponential 0 2309482309483029) <*> sconst, - BoolAexprConst <$> bool, - pure NullAexprConst - ] - -funcConstArgs = FuncConstArgs <$> nonEmpty (Range.exponential 1 7) funcArgExpr <*> maybe sortClause - -constTypename = - choice - [ NumericConstTypename <$> numeric, - ConstBitConstTypename <$> constBit, - ConstCharacterConstTypename <$> constCharacter, - ConstDatetimeConstTypename <$> constDatetime - ] - -numeric = - choice - [ pure IntNumeric, - pure IntegerNumeric, - pure SmallintNumeric, - pure BigintNumeric, - pure RealNumeric, - FloatNumeric <$> maybe iconst, - pure DoublePrecisionNumeric, - DecimalNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)), - DecNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)), - NumericNumeric <$> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)), - pure BooleanNumeric - ] - -bit = Bit <$> bool <*> maybe (nonEmpty (Range.exponential 1 7) (small aExpr)) - -constBit = bit - -constCharacter = ConstCharacter <$> character <*> maybe iconst - -character = - choice - [ CharacterCharacter <$> bool, - CharCharacter <$> bool, - pure VarcharCharacter, - NationalCharacterCharacter <$> bool, - NationalCharCharacter <$> bool, - NcharCharacter <$> bool - ] - -constDatetime = - choice - [ TimestampConstDatetime <$> maybe iconst <*> maybe bool, - TimeConstDatetime <$> maybe iconst <*> maybe bool - ] - -interval = - choice - [ pure YearInterval, - pure MonthInterval, - pure DayInterval, - pure HourInterval, - pure MinuteInterval, - SecondInterval <$> intervalSecond, - pure YearToMonthInterval, - pure DayToHourInterval, - pure DayToMinuteInterval, - DayToSecondInterval <$> intervalSecond, - pure HourToMinuteInterval, - HourToSecondInterval <$> intervalSecond, - MinuteToSecondInterval <$> intervalSecond - ] - -intervalSecond = maybe iconst - -sconst = text (Range.exponential 0 1000) unicode - -iconstOrFconst = choice [Left <$> iconst <|> Right <$> fconst] - -fconst = - filter (\a -> fromIntegral (round a :: Int) /= a) - $ realFrac_ (Range.exponentialFloat 0 309457394857984375983475943) - -iconst = integral (Range.exponential 0 maxBound) - --- * Types - -nullable = pure False - -arrayDimensionsAmount = int (Range.exponential 0 4) - --- ** Typename - -typename = Typename <$> bool <*> simpleTypename <*> pure False <*> maybe ((,) <$> typenameArrayDimensions <*> pure False) - -typenameArrayDimensions = - choice - [ BoundsTypenameArrayDimensions <$> arrayBounds, - ExplicitTypenameArrayDimensions <$> maybe iconst - ] - -arrayBounds = nonEmpty (Range.exponential 1 4) (maybe iconst) - -simpleTypename = - choice - [ GenericTypeSimpleTypename <$> genericType, - NumericSimpleTypename <$> numeric, - BitSimpleTypename <$> bit, - CharacterSimpleTypename <$> character, - ConstDatetimeSimpleTypename <$> constDatetime, - ConstIntervalSimpleTypename <$> choice [Left <$> maybe interval, Right <$> iconst] - ] - -genericType = GenericType <$> typeFunctionName <*> maybe attrs <*> maybe typeModifiers - -attrs = nonEmpty (Range.exponential 1 10) attrName - -typeModifiers = exprList - -typeList = nonEmpty (Range.exponential 1 7) typename - -subType = enumBounded - --- * Names - -columnref = Columnref <$> colId <*> maybe indirection - -keywordNotInSet = \set -> notInSet set $ do - a <- element startList - b <- text (Range.linear 1 29) (element contList) - return (Text.cons a b) - where - startList = "abcdefghijklmnopqrstuvwxyz_" <> List.filter isLower (enumFromTo '\200' '\377') - contList = startList <> "0123456789$" - -ident = identWithSet mempty - -name = identWithSet KeywordSet.colId - -cursorName = name - -identWithSet set = - frequency - [ (95,) $ UnquotedIdent <$> (keywordNotInSet . HashSet.difference KeywordSet.keyword) set, - (5,) $ QuotedIdent <$> text (Range.linear 1 30) quotedChar - ] - -qualifiedName = - choice - [ SimpleQualifiedName <$> name, - IndirectedQualifiedName <$> name <*> indirection - ] - -indirection = nonEmpty (Range.linear 1 3) indirectionEl - -indirectionEl = - choice - [ AttrNameIndirectionEl <$> name, - pure AllIndirectionEl, - ExprIndirectionEl <$> (small aExpr), - SliceIndirectionEl <$> maybe (small aExpr) <*> maybe (small aExpr) - ] - -quotedChar = filter (not . isControl) unicode - -colId = name - -colLabel = name - -attrName = colLabel - -typeFunctionName = identWithSet KeywordSet.typeFunctionName - -funcName = - choice - [ TypeFuncName <$> typeFunctionName, - IndirectedFuncName <$> colId <*> indirection - ] - -anyName = AnyName <$> colId <*> maybe attrs - --- * Indexes - -indexParams = nonEmpty (Range.exponential 1 5) indexElem - -indexElem = IndexElem <$> indexElemDef <*> maybe collate <*> maybe class_ <*> maybe ascDesc <*> maybe nullsOrder - -indexElemDef = - choice - [ IdIndexElemDef <$> colId, - FuncIndexElemDef <$> funcExprWindowless, - ExprIndexElemDef <$> aExpr - ] - -collate = anyName - -class_ = anyName - -ascDesc = enumBounded - -nullsOrder = enumBounded - --- * Helpers - -listElement :: [a] -> Gen a -listElement = element diff --git a/hspec-test/Ast/AExprReversableOpSpec.hs b/hspec-test/Ast/AExprReversableOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AExprReversableOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.AExprReversableOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AExprReversableOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AExprReversableOp + itSatisfiesArbitrary @AExprReversableOp diff --git a/hspec-test/Ast/AExprSpec.hs b/hspec-test/Ast/AExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AExprSpec.hs @@ -0,0 +1,78 @@ +module Ast.AExprSpec (spec) where + +import qualified Data.Text as Text +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AExpr +import PostgresqlSyntax.Ast.CExpr +import PostgresqlSyntax.Ast.Columnref +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import PostgresqlSyntax.Ast.VerbalExprBinOp +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AExpr + itSatisfiesCanonicalizes @AExpr + itSatisfiesRefines @SelectWithParens @AExpr + itSatisfiesArbitrary @AExpr + describe "Postgres grammar conformance" $ do + -- gram.y:15985,15987 have only @a_expr qual_Op a_expr@ and + -- @qual_Op a_expr@ — the postfix @a_expr qual_Op@ form was removed + -- from Postgres in v14. + describe "rejects postfix operators" $ do + itRejects @AExpr "1 +#" + itRejects @AExpr "1 OPERATOR(pg_catalog.+#)" + itRejects @AExpr "a +#" + describe "Nesting depth" $ do + itParsesWithin @AExpr 5 (Text.replicate 50 "(" <> "a + b" <> Text.replicate 50 ")") + let terms off = Text.intercalate " + " ["coalesce(c" <> Text.pack (show (off + i)) <> ", 0)" | i <- [1 .. 24 :: Int]] + coalesceSumInput = Text.replicate 6 "(" <> "(" <> terms 0 <> ") - (" <> terms 24 <> ")" <> Text.replicate 6 ")" + itParsesWithin @AExpr 5 coalesceSumInput + it "OVERLAPS still parses" $ do + let render :: AExpr -> Text + render = toText mempty + fmap render (parse @AExpr mempty "(1, 2) overlaps (3, 4)") `shouldBe` Right "(1, 2) OVERLAPS (3, 4)" + fmap render (parse @AExpr mempty "row(1, 2) overlaps row(3, 4)") `shouldBe` Right "ROW (1, 2) OVERLAPS ROW (3, 4)" + describe "LIKE/ILIKE/SIMILAR TO ESCAPE rhs" $ do + -- Regression for a bug introduced in 92a4d96: the ESCAPE-clause guard on + -- the LIKE/ILIKE/SIMILAR TO pattern operand (`d`) was applied whenever an + -- ESCAPE clause was present at all, instead of only when `d` is itself an + -- unbounded shape. That spuriously parenthesized bounded operands (a + -- plain column reference here), producing an extra 'InParensCExpr' layer + -- on reparse that the original AST never had. + let render :: AExpr -> Text + render = toText mempty + roundtrip sql = fmap render (parse @AExpr mempty sql) + it "does not add parens around a bounded column-reference rhs" $ do + roundtrip "a LIKE b ESCAPE 'x'" `shouldBe` Right "a LIKE b ESCAPE 'x'" + it "does not add parens around a bounded ILIKE rhs" $ do + roundtrip "a ILIKE b ESCAPE 'x'" `shouldBe` Right "a ILIKE b ESCAPE 'x'" + it "does not add parens around a bounded SIMILAR TO rhs" $ do + roundtrip "a SIMILAR TO b ESCAPE 'x'" `shouldBe` Right "a SIMILAR TO b ESCAPE 'x'" + it "still parenthesizes an unbounded (nested, escape-less LIKE) rhs" $ do + -- Constructed directly rather than by parsing a string: parsing + -- "a LIKE b LIKE c ESCAPE 'x'" greedily binds the ESCAPE to the + -- innermost LIKE (its own @d@ operand is unrestricted @a_expr@), so it + -- can't reach the shape below by parsing alone. The shape is real + -- though: an unbounded, escape-less nested 'VerbalExprBinOpAExpr' as + -- the rhs of an outer production that itself has an ESCAPE clause. Left + -- unparenthesized, rendering it bare would let a reparse of the outer + -- ESCAPE bind to the inner LIKE instead, changing the AST. + -- Reparsing always wraps a parenthesized operand in an explicit + -- 'InParensCExpr' (parens are themselves a production), so the + -- fixpoint of render/parse is the parenthesized form, not the bare + -- @outer@ below — that's expected and matches how + -- 'PostgresqlSyntax.Ast.AExpr.Qc.Arbitrary'\'s generator pre-wraps + -- this same shape. What matters here is that the parens are present at + -- all, and that the fixpoint is stable. + let colref name = CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent name) Nothing)) + innerD = VerbalExprBinOpAExpr (colref "b") False LikeVerbalExprBinOp (colref "c") Nothing + outer = VerbalExprBinOpAExpr (colref "a") False LikeVerbalExprBinOp innerD (Just (colref "e")) + wrappedOuter = VerbalExprBinOpAExpr (colref "a") False LikeVerbalExprBinOp (CExprAExpr (InParensCExpr innerD Nothing)) (Just (colref "e")) + sql = render outer + sql `shouldBe` "a LIKE (b LIKE c) ESCAPE e" + parse @AExpr mempty sql `shouldBe` Right wrappedOuter + fmap render (parse @AExpr mempty sql) `shouldBe` Right sql diff --git a/hspec-test/Ast/AexprConstSpec.hs b/hspec-test/Ast/AexprConstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AexprConstSpec.hs @@ -0,0 +1,10 @@ +module Ast.AexprConstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AexprConst +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AexprConst + itSatisfiesArbitrary @AexprConst diff --git a/hspec-test/Ast/AliasClauseSpec.hs b/hspec-test/Ast/AliasClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AliasClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.AliasClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AliasClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AliasClause + itSatisfiesArbitrary @AliasClause diff --git a/hspec-test/Ast/AllOpSpec.hs b/hspec-test/Ast/AllOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AllOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.AllOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AllOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AllOp + itSatisfiesArbitrary @AllOp diff --git a/hspec-test/Ast/AnyNameSpec.hs b/hspec-test/Ast/AnyNameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AnyNameSpec.hs @@ -0,0 +1,10 @@ +module Ast.AnyNameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AnyName +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AnyName + itSatisfiesArbitrary @AnyName diff --git a/hspec-test/Ast/AnyOperatorSpec.hs b/hspec-test/Ast/AnyOperatorSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AnyOperatorSpec.hs @@ -0,0 +1,10 @@ +module Ast.AnyOperatorSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AnyOperator +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AnyOperator + itSatisfiesArbitrary @AnyOperator diff --git a/hspec-test/Ast/ArrayBoundsSpec.hs b/hspec-test/Ast/ArrayBoundsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ArrayBoundsSpec.hs @@ -0,0 +1,10 @@ +module Ast.ArrayBoundsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ArrayBounds +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ArrayBounds + itSatisfiesArbitrary @ArrayBounds diff --git a/hspec-test/Ast/ArrayExprListSpec.hs b/hspec-test/Ast/ArrayExprListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ArrayExprListSpec.hs @@ -0,0 +1,10 @@ +module Ast.ArrayExprListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ArrayExprList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ArrayExprList + itSatisfiesArbitrary @ArrayExprList diff --git a/hspec-test/Ast/ArrayExprSpec.hs b/hspec-test/Ast/ArrayExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ArrayExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.ArrayExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ArrayExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ArrayExpr + itSatisfiesArbitrary @ArrayExpr diff --git a/hspec-test/Ast/AscDescSpec.hs b/hspec-test/Ast/AscDescSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AscDescSpec.hs @@ -0,0 +1,10 @@ +module Ast.AscDescSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.AscDesc +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @AscDesc + itSatisfiesArbitrary @AscDesc diff --git a/hspec-test/Ast/AttrsSpec.hs b/hspec-test/Ast/AttrsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/AttrsSpec.hs @@ -0,0 +1,10 @@ +module Ast.AttrsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Attrs +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Attrs + itSatisfiesArbitrary @Attrs diff --git a/hspec-test/Ast/BExprIsOpSpec.hs b/hspec-test/Ast/BExprIsOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/BExprIsOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.BExprIsOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.BExprIsOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @BExprIsOp + itSatisfiesArbitrary @BExprIsOp diff --git a/hspec-test/Ast/BExprSpec.hs b/hspec-test/Ast/BExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/BExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.BExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.BExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @BExpr + itSatisfiesArbitrary @BExpr diff --git a/hspec-test/Ast/BconstSpec.hs b/hspec-test/Ast/BconstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/BconstSpec.hs @@ -0,0 +1,10 @@ +module Ast.BconstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Bconst +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Bconst + itSatisfiesArbitrary @Bconst diff --git a/hspec-test/Ast/BitSpec.hs b/hspec-test/Ast/BitSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/BitSpec.hs @@ -0,0 +1,10 @@ +module Ast.BitSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Bit +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Bit + itSatisfiesArbitrary @Bit diff --git a/hspec-test/Ast/CExprSpec.hs b/hspec-test/Ast/CExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/CExprSpec.hs @@ -0,0 +1,11 @@ +module Ast.CExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.CExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @CExpr + itSatisfiesCanonicalizes @CExpr + itSatisfiesArbitrary @CExpr diff --git a/hspec-test/Ast/CallStmtSpec.hs b/hspec-test/Ast/CallStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/CallStmtSpec.hs @@ -0,0 +1,10 @@ +module Ast.CallStmtSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.CallStmt +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @CallStmt + itSatisfiesArbitrary @CallStmt diff --git a/hspec-test/Ast/CaseExprSpec.hs b/hspec-test/Ast/CaseExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/CaseExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.CaseExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.CaseExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @CaseExpr + itSatisfiesArbitrary @CaseExpr diff --git a/hspec-test/Ast/CharacterSpec.hs b/hspec-test/Ast/CharacterSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/CharacterSpec.hs @@ -0,0 +1,10 @@ +module Ast.CharacterSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Character +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Character + itSatisfiesArbitrary @Character diff --git a/hspec-test/Ast/ColumnrefSpec.hs b/hspec-test/Ast/ColumnrefSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ColumnrefSpec.hs @@ -0,0 +1,10 @@ +module Ast.ColumnrefSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Columnref +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Columnref + itSatisfiesArbitrary @Columnref diff --git a/hspec-test/Ast/CommonTableExprSpec.hs b/hspec-test/Ast/CommonTableExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/CommonTableExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.CommonTableExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.CommonTableExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @CommonTableExpr + itSatisfiesArbitrary @CommonTableExpr diff --git a/hspec-test/Ast/ConfExprSpec.hs b/hspec-test/Ast/ConfExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ConfExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.ConfExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ConfExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ConfExpr + itSatisfiesArbitrary @ConfExpr diff --git a/hspec-test/Ast/ConstCharacterSpec.hs b/hspec-test/Ast/ConstCharacterSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ConstCharacterSpec.hs @@ -0,0 +1,10 @@ +module Ast.ConstCharacterSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ConstCharacter +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ConstCharacter + itSatisfiesArbitrary @ConstCharacter diff --git a/hspec-test/Ast/ConstDatetimeSpec.hs b/hspec-test/Ast/ConstDatetimeSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ConstDatetimeSpec.hs @@ -0,0 +1,10 @@ +module Ast.ConstDatetimeSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ConstDatetime +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ConstDatetime + itSatisfiesArbitrary @ConstDatetime diff --git a/hspec-test/Ast/ConstTypenameSpec.hs b/hspec-test/Ast/ConstTypenameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ConstTypenameSpec.hs @@ -0,0 +1,10 @@ +module Ast.ConstTypenameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ConstTypename +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ConstTypename + itSatisfiesArbitrary @ConstTypename diff --git a/hspec-test/Ast/DeleteStmtSpec.hs b/hspec-test/Ast/DeleteStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/DeleteStmtSpec.hs @@ -0,0 +1,13 @@ +module Ast.DeleteStmtSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.DeleteStmt +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @DeleteStmt + itSatisfiesArbitrary @DeleteStmt + itParses @DeleteStmt "delete from foo as set" + itParses @DeleteStmt "delete from foo alias where 1" + itRejects @DeleteStmt "delete from foo set" diff --git a/hspec-test/Ast/ExplicitRowSpec.hs b/hspec-test/Ast/ExplicitRowSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ExplicitRowSpec.hs @@ -0,0 +1,10 @@ +module Ast.ExplicitRowSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ExplicitRow +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ExplicitRow + itSatisfiesArbitrary @ExplicitRow diff --git a/hspec-test/Ast/ExprListSpec.hs b/hspec-test/Ast/ExprListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ExprListSpec.hs @@ -0,0 +1,10 @@ +module Ast.ExprListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ExprList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ExprList + itSatisfiesArbitrary @ExprList diff --git a/hspec-test/Ast/ExtractArgSpec.hs b/hspec-test/Ast/ExtractArgSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ExtractArgSpec.hs @@ -0,0 +1,10 @@ +module Ast.ExtractArgSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ExtractArg +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ExtractArg + itSatisfiesArbitrary @ExtractArg diff --git a/hspec-test/Ast/ExtractListSpec.hs b/hspec-test/Ast/ExtractListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ExtractListSpec.hs @@ -0,0 +1,10 @@ +module Ast.ExtractListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ExtractList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ExtractList + itSatisfiesArbitrary @ExtractList diff --git a/hspec-test/Ast/FconstSpec.hs b/hspec-test/Ast/FconstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FconstSpec.hs @@ -0,0 +1,10 @@ +module Ast.FconstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Fconst +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Fconst + itSatisfiesArbitrary @Fconst diff --git a/hspec-test/Ast/ForLockingClauseSpec.hs b/hspec-test/Ast/ForLockingClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ForLockingClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.ForLockingClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ForLockingClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ForLockingClause + itSatisfiesArbitrary @ForLockingClause diff --git a/hspec-test/Ast/ForLockingItemSpec.hs b/hspec-test/Ast/ForLockingItemSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ForLockingItemSpec.hs @@ -0,0 +1,10 @@ +module Ast.ForLockingItemSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ForLockingItem +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ForLockingItem + itSatisfiesArbitrary @ForLockingItem diff --git a/hspec-test/Ast/ForLockingStrengthSpec.hs b/hspec-test/Ast/ForLockingStrengthSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ForLockingStrengthSpec.hs @@ -0,0 +1,10 @@ +module Ast.ForLockingStrengthSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ForLockingStrength +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ForLockingStrength + itSatisfiesArbitrary @ForLockingStrength diff --git a/hspec-test/Ast/FrameBoundSpec.hs b/hspec-test/Ast/FrameBoundSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FrameBoundSpec.hs @@ -0,0 +1,27 @@ +module Ast.FrameBoundSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FrameBound +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FrameBound + itSatisfiesArbitrary @FrameBound + describe "Postgres grammar conformance" $ do + -- gram.y:17567 frame_bound. UNBOUNDED is an unreserved keyword, so + -- @UNBOUNDED PRECEDING@ is ambiguous with @a_expr PRECEDING@ where + -- the a_expr is a column named "unbounded"; gram.y:915 resolves it by + -- giving UNBOUNDED lower precedence than PRECEDING, i.e. the keyword + -- reading wins and the column reading needs quoting. + it "frame_bound" $ do + let render :: FrameBound -> Text + render = toText mempty + fmap render (parse @FrameBound mempty "unbounded preceding") `shouldBe` Right "UNBOUNDED PRECEDING" + fmap render (parse @FrameBound mempty "unbounded following") `shouldBe` Right "UNBOUNDED FOLLOWING" + fmap render (parse @FrameBound mempty "current row") `shouldBe` Right "CURRENT ROW" + fmap render (parse @FrameBound mempty "1 preceding") `shouldBe` Right "1 PRECEDING" + fmap render (parse @FrameBound mempty "a following") `shouldBe` Right "a FOLLOWING" + fmap render (parse @FrameBound mempty "\"unbounded\" preceding") `shouldBe` Right "\"unbounded\" PRECEDING" diff --git a/hspec-test/Ast/FrameClauseModeSpec.hs b/hspec-test/Ast/FrameClauseModeSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FrameClauseModeSpec.hs @@ -0,0 +1,10 @@ +module Ast.FrameClauseModeSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FrameClauseMode +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FrameClauseMode + itSatisfiesArbitrary @FrameClauseMode diff --git a/hspec-test/Ast/FrameClauseSpec.hs b/hspec-test/Ast/FrameClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FrameClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.FrameClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FrameClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FrameClause + itSatisfiesArbitrary @FrameClause diff --git a/hspec-test/Ast/FrameExtentSpec.hs b/hspec-test/Ast/FrameExtentSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FrameExtentSpec.hs @@ -0,0 +1,10 @@ +module Ast.FrameExtentSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FrameExtent +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FrameExtent + itSatisfiesArbitrary @FrameExtent diff --git a/hspec-test/Ast/FromClauseSpec.hs b/hspec-test/Ast/FromClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FromClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.FromClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FromClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FromClause + itSatisfiesArbitrary @FromClause diff --git a/hspec-test/Ast/FromListSpec.hs b/hspec-test/Ast/FromListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FromListSpec.hs @@ -0,0 +1,10 @@ +module Ast.FromListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FromList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FromList + itSatisfiesArbitrary @FromList diff --git a/hspec-test/Ast/FuncAliasClauseSpec.hs b/hspec-test/Ast/FuncAliasClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncAliasClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncAliasClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncAliasClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncAliasClause + itSatisfiesArbitrary @FuncAliasClause diff --git a/hspec-test/Ast/FuncApplicationParamsSpec.hs b/hspec-test/Ast/FuncApplicationParamsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncApplicationParamsSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncApplicationParamsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncApplicationParams +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncApplicationParams + itSatisfiesArbitrary @FuncApplicationParams diff --git a/hspec-test/Ast/FuncApplicationSpec.hs b/hspec-test/Ast/FuncApplicationSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncApplicationSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncApplicationSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncApplication +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncApplication + itSatisfiesArbitrary @FuncApplication diff --git a/hspec-test/Ast/FuncArgExprSpec.hs b/hspec-test/Ast/FuncArgExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncArgExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncArgExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncArgExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncArgExpr + itSatisfiesArbitrary @FuncArgExpr diff --git a/hspec-test/Ast/FuncConstArgsSpec.hs b/hspec-test/Ast/FuncConstArgsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncConstArgsSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncConstArgsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncConstArgs +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncConstArgs + itSatisfiesArbitrary @FuncConstArgs diff --git a/hspec-test/Ast/FuncExprCommonSubexprSpec.hs b/hspec-test/Ast/FuncExprCommonSubexprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncExprCommonSubexprSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncExprCommonSubexprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncExprCommonSubexpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncExprCommonSubexpr + itSatisfiesArbitrary @FuncExprCommonSubexpr diff --git a/hspec-test/Ast/FuncExprSpec.hs b/hspec-test/Ast/FuncExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncExpr + itSatisfiesArbitrary @FuncExpr diff --git a/hspec-test/Ast/FuncExprWindowlessSpec.hs b/hspec-test/Ast/FuncExprWindowlessSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncExprWindowlessSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncExprWindowlessSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncExprWindowless +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncExprWindowless + itSatisfiesArbitrary @FuncExprWindowless diff --git a/hspec-test/Ast/FuncNameSpec.hs b/hspec-test/Ast/FuncNameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncNameSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncNameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncName +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncName + itSatisfiesArbitrary @FuncName diff --git a/hspec-test/Ast/FuncTableSpec.hs b/hspec-test/Ast/FuncTableSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/FuncTableSpec.hs @@ -0,0 +1,10 @@ +module Ast.FuncTableSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.FuncTable +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @FuncTable + itSatisfiesArbitrary @FuncTable diff --git a/hspec-test/Ast/GenericTypeSpec.hs b/hspec-test/Ast/GenericTypeSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/GenericTypeSpec.hs @@ -0,0 +1,10 @@ +module Ast.GenericTypeSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.GenericType +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @GenericType + itSatisfiesArbitrary @GenericType diff --git a/hspec-test/Ast/GroupByItemSpec.hs b/hspec-test/Ast/GroupByItemSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/GroupByItemSpec.hs @@ -0,0 +1,10 @@ +module Ast.GroupByItemSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.GroupByItem +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @GroupByItem + itSatisfiesArbitrary @GroupByItem diff --git a/hspec-test/Ast/GroupClauseSpec.hs b/hspec-test/Ast/GroupClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/GroupClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.GroupClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.GroupClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @GroupClause + itSatisfiesArbitrary @GroupClause diff --git a/hspec-test/Ast/HavingClauseSpec.hs b/hspec-test/Ast/HavingClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/HavingClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.HavingClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.HavingClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @HavingClause + itSatisfiesArbitrary @HavingClause diff --git a/hspec-test/Ast/IconstSpec.hs b/hspec-test/Ast/IconstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IconstSpec.hs @@ -0,0 +1,10 @@ +module Ast.IconstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Iconst +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Iconst + itSatisfiesArbitrary @Iconst diff --git a/hspec-test/Ast/IdentSpec.hs b/hspec-test/Ast/IdentSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IdentSpec.hs @@ -0,0 +1,10 @@ +module Ast.IdentSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Ident +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Ident + itSatisfiesArbitrary @Ident diff --git a/hspec-test/Ast/ImplicitRowSpec.hs b/hspec-test/Ast/ImplicitRowSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ImplicitRowSpec.hs @@ -0,0 +1,10 @@ +module Ast.ImplicitRowSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ImplicitRow +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ImplicitRow + itSatisfiesArbitrary @ImplicitRow diff --git a/hspec-test/Ast/InExprSpec.hs b/hspec-test/Ast/InExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InExprSpec.hs @@ -0,0 +1,11 @@ +module Ast.InExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InExpr + itSatisfiesCanonicalizes @InExpr + itSatisfiesArbitrary @InExpr diff --git a/hspec-test/Ast/IndexElemDefSpec.hs b/hspec-test/Ast/IndexElemDefSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IndexElemDefSpec.hs @@ -0,0 +1,10 @@ +module Ast.IndexElemDefSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.IndexElemDef +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IndexElemDef + itSatisfiesArbitrary @IndexElemDef diff --git a/hspec-test/Ast/IndexElemSpec.hs b/hspec-test/Ast/IndexElemSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IndexElemSpec.hs @@ -0,0 +1,24 @@ +module Ast.IndexElemSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.IndexElem +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IndexElem + itSatisfiesArbitrary @IndexElem + describe "Postgres grammar conformance" $ do + -- gram.y:8558 index_elem: ColId index_elem_options, and gram.y:8596 + -- opt_nulls_order. index_elem_options' operator-class name + -- (opt_qualified_name, gram.y:8525) is a bare ColId, so it is + -- directly ambiguous with the unreserved NULLS that follows it. + it "index_elem" $ do + let render :: IndexElem -> Text + render = toText mempty + fmap render (parse @IndexElem mempty "a") `shouldBe` Right "a" + fmap render (parse @IndexElem mempty "a nulls first") `shouldBe` Right "a NULLS FIRST" + fmap render (parse @IndexElem mempty "a text_ops nulls first") `shouldBe` Right "a text_ops NULLS FIRST" + fmap render (parse @IndexElem mempty "a collate \"C\" text_ops desc") `shouldBe` Right "a COLLATE \"C\" text_ops DESC" diff --git a/hspec-test/Ast/IndexParamsSpec.hs b/hspec-test/Ast/IndexParamsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IndexParamsSpec.hs @@ -0,0 +1,10 @@ +module Ast.IndexParamsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.IndexParams +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IndexParams + itSatisfiesArbitrary @IndexParams diff --git a/hspec-test/Ast/IndirectionElSpec.hs b/hspec-test/Ast/IndirectionElSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IndirectionElSpec.hs @@ -0,0 +1,10 @@ +module Ast.IndirectionElSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.IndirectionEl +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IndirectionEl + itSatisfiesArbitrary @IndirectionEl diff --git a/hspec-test/Ast/IndirectionSpec.hs b/hspec-test/Ast/IndirectionSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IndirectionSpec.hs @@ -0,0 +1,10 @@ +module Ast.IndirectionSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Indirection +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Indirection + itSatisfiesArbitrary @Indirection diff --git a/hspec-test/Ast/InsertColumnItemSpec.hs b/hspec-test/Ast/InsertColumnItemSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InsertColumnItemSpec.hs @@ -0,0 +1,10 @@ +module Ast.InsertColumnItemSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InsertColumnItem +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InsertColumnItem + itSatisfiesArbitrary @InsertColumnItem diff --git a/hspec-test/Ast/InsertColumnListSpec.hs b/hspec-test/Ast/InsertColumnListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InsertColumnListSpec.hs @@ -0,0 +1,10 @@ +module Ast.InsertColumnListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InsertColumnList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InsertColumnList + itSatisfiesArbitrary @InsertColumnList diff --git a/hspec-test/Ast/InsertRestSpec.hs b/hspec-test/Ast/InsertRestSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InsertRestSpec.hs @@ -0,0 +1,14 @@ +module Ast.InsertRestSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InsertRest +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InsertRest + itSatisfiesArbitrary @InsertRest + -- https://github.com/nikita-volkov/postgresql-syntax/issues/35 + itParses @InsertRest "(values (default))" + itParses @InsertRest "(select 1)" + itParses @InsertRest "(values) values (1)" diff --git a/hspec-test/Ast/InsertStmtSpec.hs b/hspec-test/Ast/InsertStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InsertStmtSpec.hs @@ -0,0 +1,12 @@ +module Ast.InsertStmtSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InsertStmt +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InsertStmt + itSatisfiesArbitrary @InsertStmt + -- https://github.com/nikita-volkov/postgresql-syntax/issues/35 + itParses @InsertStmt "insert into ta.xa (values (default))" diff --git a/hspec-test/Ast/InsertTargetSpec.hs b/hspec-test/Ast/InsertTargetSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/InsertTargetSpec.hs @@ -0,0 +1,10 @@ +module Ast.InsertTargetSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.InsertTarget +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @InsertTarget + itSatisfiesArbitrary @InsertTarget diff --git a/hspec-test/Ast/IntervalSecondSpec.hs b/hspec-test/Ast/IntervalSecondSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IntervalSecondSpec.hs @@ -0,0 +1,10 @@ +module Ast.IntervalSecondSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.IntervalSecond +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IntervalSecond + itSatisfiesArbitrary @IntervalSecond diff --git a/hspec-test/Ast/IntervalSpec.hs b/hspec-test/Ast/IntervalSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IntervalSpec.hs @@ -0,0 +1,10 @@ +module Ast.IntervalSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Interval +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Interval + itSatisfiesArbitrary @Interval diff --git a/hspec-test/Ast/IntoClauseSpec.hs b/hspec-test/Ast/IntoClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/IntoClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.IntoClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.IntoClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @IntoClause + itSatisfiesArbitrary @IntoClause diff --git a/hspec-test/Ast/JoinQualSpec.hs b/hspec-test/Ast/JoinQualSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/JoinQualSpec.hs @@ -0,0 +1,10 @@ +module Ast.JoinQualSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.JoinQual +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @JoinQual + itSatisfiesArbitrary @JoinQual diff --git a/hspec-test/Ast/JoinTypeSpec.hs b/hspec-test/Ast/JoinTypeSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/JoinTypeSpec.hs @@ -0,0 +1,10 @@ +module Ast.JoinTypeSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.JoinType +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @JoinType + itSatisfiesArbitrary @JoinType diff --git a/hspec-test/Ast/JoinedTableSpec.hs b/hspec-test/Ast/JoinedTableSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/JoinedTableSpec.hs @@ -0,0 +1,10 @@ +module Ast.JoinedTableSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.JoinedTable +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @JoinedTable + itSatisfiesArbitrary @JoinedTable diff --git a/hspec-test/Ast/LimitClauseSpec.hs b/hspec-test/Ast/LimitClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/LimitClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.LimitClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.LimitClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @LimitClause + itSatisfiesArbitrary @LimitClause diff --git a/hspec-test/Ast/MathOpSpec.hs b/hspec-test/Ast/MathOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/MathOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.MathOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.MathOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @MathOp + itSatisfiesArbitrary @MathOp diff --git a/hspec-test/Ast/NameListSpec.hs b/hspec-test/Ast/NameListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/NameListSpec.hs @@ -0,0 +1,10 @@ +module Ast.NameListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.NameList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @NameList + itSatisfiesArbitrary @NameList diff --git a/hspec-test/Ast/NullsOrderSpec.hs b/hspec-test/Ast/NullsOrderSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/NullsOrderSpec.hs @@ -0,0 +1,10 @@ +module Ast.NullsOrderSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.NullsOrder +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @NullsOrder + itSatisfiesArbitrary @NullsOrder diff --git a/hspec-test/Ast/NumericSpec.hs b/hspec-test/Ast/NumericSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/NumericSpec.hs @@ -0,0 +1,10 @@ +module Ast.NumericSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Numeric +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Numeric + itSatisfiesArbitrary @Numeric diff --git a/hspec-test/Ast/OffsetClauseSpec.hs b/hspec-test/Ast/OffsetClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OffsetClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.OffsetClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OffsetClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OffsetClause + itSatisfiesArbitrary @OffsetClause diff --git a/hspec-test/Ast/OnConflictDoSpec.hs b/hspec-test/Ast/OnConflictDoSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OnConflictDoSpec.hs @@ -0,0 +1,10 @@ +module Ast.OnConflictDoSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OnConflictDo +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OnConflictDo + itSatisfiesArbitrary @OnConflictDo diff --git a/hspec-test/Ast/OnConflictSpec.hs b/hspec-test/Ast/OnConflictSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OnConflictSpec.hs @@ -0,0 +1,10 @@ +module Ast.OnConflictSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OnConflict +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OnConflict + itSatisfiesArbitrary @OnConflict diff --git a/hspec-test/Ast/OpSpec.hs b/hspec-test/Ast/OpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OpSpec.hs @@ -0,0 +1,11 @@ +module Ast.OpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Op +import Prelude hiding (Op) +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Op + itSatisfiesArbitrary @Op diff --git a/hspec-test/Ast/OptOrdinalitySpec.hs b/hspec-test/Ast/OptOrdinalitySpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OptOrdinalitySpec.hs @@ -0,0 +1,10 @@ +module Ast.OptOrdinalitySpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OptOrdinality +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OptOrdinality + itSatisfiesArbitrary @OptOrdinality diff --git a/hspec-test/Ast/OptTempTableNameSpec.hs b/hspec-test/Ast/OptTempTableNameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OptTempTableNameSpec.hs @@ -0,0 +1,10 @@ +module Ast.OptTempTableNameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OptTempTableName +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OptTempTableName + itSatisfiesArbitrary @OptTempTableName diff --git a/hspec-test/Ast/OptVaryingSpec.hs b/hspec-test/Ast/OptVaryingSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OptVaryingSpec.hs @@ -0,0 +1,8 @@ +module Ast.OptVaryingSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OptVarying +import Test.Hspec + +spec :: Spec +spec = itSatisfiesArbitrary @OptVarying diff --git a/hspec-test/Ast/OverClauseSpec.hs b/hspec-test/Ast/OverClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OverClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.OverClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OverClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OverClause + itSatisfiesArbitrary @OverClause diff --git a/hspec-test/Ast/OverlayListSpec.hs b/hspec-test/Ast/OverlayListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OverlayListSpec.hs @@ -0,0 +1,10 @@ +module Ast.OverlayListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OverlayList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OverlayList + itSatisfiesArbitrary @OverlayList diff --git a/hspec-test/Ast/OverrideKindSpec.hs b/hspec-test/Ast/OverrideKindSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/OverrideKindSpec.hs @@ -0,0 +1,10 @@ +module Ast.OverrideKindSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.OverrideKind +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @OverrideKind + itSatisfiesArbitrary @OverrideKind diff --git a/hspec-test/Ast/PositionListSpec.hs b/hspec-test/Ast/PositionListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/PositionListSpec.hs @@ -0,0 +1,10 @@ +module Ast.PositionListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.PositionList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @PositionList + itSatisfiesArbitrary @PositionList diff --git a/hspec-test/Ast/PreparableStmtSpec.hs b/hspec-test/Ast/PreparableStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/PreparableStmtSpec.hs @@ -0,0 +1,60 @@ +module Ast.PreparableStmtSpec (spec) where + +import qualified Data.Text as Text +import Helpers.Specs +import PostgresqlSyntax.Ast.PreparableStmt +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @PreparableStmt + itSatisfiesArbitrary @PreparableStmt + describe "Parsers" $ do + itParses @PreparableStmt + "select i :: int8 from auth.user as u\n\ + \inner join edgenode.usere_provider as p\n\ + \on u.id = p.user_id\n\ + \inner join edgenode.provider_branch as b\n\ + \on b.provider_fk = p.provider_id" + itParses @PreparableStmt "select * from items for update limit 1" + itParses @PreparableStmt "select * from items limit 1 for update" + itParses @PreparableStmt "select * from items for share limit 10" + itParses @PreparableStmt "select * from items for no key update limit 1" + itParses @PreparableStmt "select * from items for key share limit 1" + itParses @PreparableStmt "select * from items for update of items nowait limit 1" + itParses @PreparableStmt "select * from items for update skip locked limit 1" + itParses @PreparableStmt "select * from items order by id for update limit 1" + itParses @PreparableStmt "select * from items for update offset 5 limit 10" + describe "Nesting depth" $ do + itParsesWithin @PreparableStmt 5 ("select " <> Text.replicate 50 "(" <> "a + b" <> Text.replicate 50 ")") + describe "Error reporting" $ do + itReportsError @PreparableStmt + "select i :: int8 fom auth.user as u\n\ + \inner join edgenode.usere_provider as p\n\ + \on u.id = p.user_id\n\ + \inner join edgenode.provider_branch as b\n\ + \on b.provider_fk = p.provider_id" + "(21,\"offset=21:\\nunexpected 'a'\\nexpecting end of input or white space\\n\")" + itReportsError @PreparableStmt + "select i :: int8 from auth.user as u\n\ + \WHERE u.id IS NO NULL && TRUE" + "(51,\"offset=51:\\nexpecting white space\\n\")" + describe "SourcePos error reporting" $ do + itReportsSourcePosError @PreparableStmt + "select i :: int8 fom auth.user as u\n\ + \inner join edgenode.usere_provider as p\n\ + \on u.id = p.user_id\n\ + \inner join edgenode.provider_branch as b\n\ + \on b.provider_fk = p.provider_id" + "1:22 unexpected 'a'\nexpecting end of input or white space\n" + itReportsSourcePosError @PreparableStmt + "select i :: int8 from auth.user as u\n\ + \WHERE u.id IS NO NULL && TRUE" + "2:15 expecting white space\n" + itReportsSourcePosError @PreparableStmt + "SLECT id FROM qsdqsd" + "1:1 unexpected 'S'\nexpecting '(' or white space\n" + itReportsSourcePosError @PreparableStmt + "SELECT id FROM as" + "1:18 Reserved keyword \"as\" used as an identifier. If that's what you intend, you have to wrap it in double quotes.\n" diff --git a/hspec-test/Ast/QualAllOpSpec.hs b/hspec-test/Ast/QualAllOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/QualAllOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.QualAllOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.QualAllOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @QualAllOp + itSatisfiesArbitrary @QualAllOp diff --git a/hspec-test/Ast/QualOpSpec.hs b/hspec-test/Ast/QualOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/QualOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.QualOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.QualOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @QualOp + itSatisfiesArbitrary @QualOp diff --git a/hspec-test/Ast/QualifiedNameSpec.hs b/hspec-test/Ast/QualifiedNameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/QualifiedNameSpec.hs @@ -0,0 +1,10 @@ +module Ast.QualifiedNameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.QualifiedName +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @QualifiedName + itSatisfiesArbitrary @QualifiedName diff --git a/hspec-test/Ast/RelationExprOptAliasSpec.hs b/hspec-test/Ast/RelationExprOptAliasSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/RelationExprOptAliasSpec.hs @@ -0,0 +1,10 @@ +module Ast.RelationExprOptAliasSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.RelationExprOptAlias +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @RelationExprOptAlias + itSatisfiesArbitrary @RelationExprOptAlias diff --git a/hspec-test/Ast/RelationExprSpec.hs b/hspec-test/Ast/RelationExprSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/RelationExprSpec.hs @@ -0,0 +1,10 @@ +module Ast.RelationExprSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.RelationExpr +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @RelationExpr + itSatisfiesArbitrary @RelationExpr diff --git a/hspec-test/Ast/ReturningClauseSpec.hs b/hspec-test/Ast/ReturningClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ReturningClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.ReturningClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ReturningClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ReturningClause + itSatisfiesArbitrary @ReturningClause diff --git a/hspec-test/Ast/RowSpec.hs b/hspec-test/Ast/RowSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/RowSpec.hs @@ -0,0 +1,10 @@ +module Ast.RowSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Row +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Row + itSatisfiesArbitrary @Row diff --git a/hspec-test/Ast/RowsfromItemSpec.hs b/hspec-test/Ast/RowsfromItemSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/RowsfromItemSpec.hs @@ -0,0 +1,10 @@ +module Ast.RowsfromItemSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.RowsfromItem +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @RowsfromItem + itSatisfiesArbitrary @RowsfromItem diff --git a/hspec-test/Ast/RowsfromListSpec.hs b/hspec-test/Ast/RowsfromListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/RowsfromListSpec.hs @@ -0,0 +1,10 @@ +module Ast.RowsfromListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.RowsfromList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @RowsfromList + itSatisfiesArbitrary @RowsfromList diff --git a/hspec-test/Ast/SconstSpec.hs b/hspec-test/Ast/SconstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SconstSpec.hs @@ -0,0 +1,15 @@ +module Ast.SconstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Sconst +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Sconst + itSatisfiesArbitrary @Sconst + describe "Parsers" $ do + itParses @Sconst "'it''s good'" + itParses @Sconst "$$it's good$$" + itParses @Sconst "$x$it's good$x$" diff --git a/hspec-test/Ast/SelectBinOpSpec.hs b/hspec-test/Ast/SelectBinOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectBinOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.SelectBinOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectBinOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectBinOp + itSatisfiesArbitrary @SelectBinOp diff --git a/hspec-test/Ast/SelectClauseSpec.hs b/hspec-test/Ast/SelectClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectClauseSpec.hs @@ -0,0 +1,12 @@ +module Ast.SelectClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectClause +import PostgresqlSyntax.Ast.SimpleSelect +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectClause + itSatisfiesExtends @SelectClause @SimpleSelect + itSatisfiesArbitrary @SelectClause diff --git a/hspec-test/Ast/SelectFetchFirstValueSpec.hs b/hspec-test/Ast/SelectFetchFirstValueSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectFetchFirstValueSpec.hs @@ -0,0 +1,10 @@ +module Ast.SelectFetchFirstValueSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectFetchFirstValue +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectFetchFirstValue + itSatisfiesArbitrary @SelectFetchFirstValue diff --git a/hspec-test/Ast/SelectLimitSpec.hs b/hspec-test/Ast/SelectLimitSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectLimitSpec.hs @@ -0,0 +1,10 @@ +module Ast.SelectLimitSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectLimit +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectLimit + itSatisfiesArbitrary @SelectLimit diff --git a/hspec-test/Ast/SelectLimitValueSpec.hs b/hspec-test/Ast/SelectLimitValueSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectLimitValueSpec.hs @@ -0,0 +1,10 @@ +module Ast.SelectLimitValueSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectLimitValue +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectLimitValue + itSatisfiesArbitrary @SelectLimitValue diff --git a/hspec-test/Ast/SelectNoParensSpec.hs b/hspec-test/Ast/SelectNoParensSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectNoParensSpec.hs @@ -0,0 +1,12 @@ +module Ast.SelectNoParensSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectNoParens +import PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectNoParens + itSatisfiesRefines @SelectWithParens @SelectNoParens + itSatisfiesArbitrary @SelectNoParens diff --git a/hspec-test/Ast/SelectStmtSpec.hs b/hspec-test/Ast/SelectStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectStmtSpec.hs @@ -0,0 +1,10 @@ +module Ast.SelectStmtSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SelectStmt +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectStmt + itSatisfiesArbitrary @SelectStmt diff --git a/hspec-test/Ast/SelectWithParensSpec.hs b/hspec-test/Ast/SelectWithParensSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SelectWithParensSpec.hs @@ -0,0 +1,19 @@ +module Ast.SelectWithParensSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SelectNoParens +import PostgresqlSyntax.Ast.SelectWithParens +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SelectWithParens + itSatisfiesCanonicalizes @SelectWithParens + itSatisfiesArbitrary @SelectWithParens + describe "Nesting depth" $ do + -- The parenthesised sub-select has two possible representations. + it "redundant parens around a sub-select are canonicalised" + $ parse @SelectWithParens mempty "((select 1))" + `shouldBe` (WithParensSelectWithParens . NoParensSelectWithParens <$> parse @SelectNoParens mempty "select 1") diff --git a/hspec-test/Ast/SetClauseListSpec.hs b/hspec-test/Ast/SetClauseListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SetClauseListSpec.hs @@ -0,0 +1,10 @@ +module Ast.SetClauseListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SetClauseList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SetClauseList + itSatisfiesArbitrary @SetClauseList diff --git a/hspec-test/Ast/SetClauseSpec.hs b/hspec-test/Ast/SetClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SetClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.SetClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SetClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SetClause + itSatisfiesArbitrary @SetClause diff --git a/hspec-test/Ast/SetTargetListSpec.hs b/hspec-test/Ast/SetTargetListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SetTargetListSpec.hs @@ -0,0 +1,10 @@ +module Ast.SetTargetListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SetTargetList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SetTargetList + itSatisfiesArbitrary @SetTargetList diff --git a/hspec-test/Ast/SetTargetSpec.hs b/hspec-test/Ast/SetTargetSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SetTargetSpec.hs @@ -0,0 +1,10 @@ +module Ast.SetTargetSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SetTarget +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SetTarget + itSatisfiesArbitrary @SetTarget diff --git a/hspec-test/Ast/SimpleSelectSpec.hs b/hspec-test/Ast/SimpleSelectSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SimpleSelectSpec.hs @@ -0,0 +1,46 @@ +module Ast.SimpleSelectSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.QualifiedName +import PostgresqlSyntax.Ast.RelationExpr +import PostgresqlSyntax.Ast.SelectBinOp +import PostgresqlSyntax.Ast.SelectClause +import PostgresqlSyntax.Ast.SimpleSelect +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SimpleSelect + itSatisfiesCanonicalizes @SimpleSelect + itSatisfiesArbitrary @SimpleSelect + describe "Precedence" precedenceSpec + +-- | +-- Reproduces the three parse-shape checks from +-- against +-- @gram.y@'s @%left UNION EXCEPT@ \/ @%left INTERSECT@ declarations +-- (gram.y:813-814): @INTERSECT@ binds tighter than @UNION@\/@EXCEPT@, and +-- all three are left-associative among themselves. +precedenceSpec :: Spec +precedenceSpec = do + it "a EXCEPT b EXCEPT c nests left" + $ parse mempty "TABLE a EXCEPT TABLE b EXCEPT TABLE c" + `shouldBe` Right (bin ExceptSelectBinOp (bin ExceptSelectBinOp (table "a") (table "b")) (table "c")) + it "a INTERSECT b UNION c roots at UNION" + $ parse mempty "TABLE a INTERSECT TABLE b UNION TABLE c" + `shouldBe` Right (bin UnionSelectBinOp (bin IntersectSelectBinOp (table "a") (table "b")) (table "c")) + it "a UNION b INTERSECT c is a UNION (b INTERSECT c)" + $ parse mempty "TABLE a UNION TABLE b INTERSECT TABLE c" + `shouldBe` Right (bin UnionSelectBinOp (table "a") (bin IntersectSelectBinOp (table "b") (table "c"))) + it "a INTERSECT b INTERSECT c nests left, not right (issue #34)" + $ parse mempty "TABLE a INTERSECT TABLE b INTERSECT TABLE c" + `shouldBe` Right (bin IntersectSelectBinOp (bin IntersectSelectBinOp (table "a") (table "b")) (table "c")) + it "a INTERSECT b INTERSECT c INTERSECT d nests fully left (issue #34)" + $ parse mempty "TABLE a INTERSECT TABLE b INTERSECT TABLE c INTERSECT TABLE d" + `shouldBe` Right (bin IntersectSelectBinOp (bin IntersectSelectBinOp (bin IntersectSelectBinOp (table "a") (table "b")) (table "c")) (table "d")) + where + table name = TableSimpleSelect (SimpleRelationExpr (SimpleQualifiedName (UnquotedIdent name)) False) + bin op lhs rhs = BinSimpleSelect op (SimpleSelectSelectClause lhs) Nothing (SimpleSelectSelectClause rhs) diff --git a/hspec-test/Ast/SimpleTypenameSpec.hs b/hspec-test/Ast/SimpleTypenameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SimpleTypenameSpec.hs @@ -0,0 +1,10 @@ +module Ast.SimpleTypenameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SimpleTypename +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SimpleTypename + itSatisfiesArbitrary @SimpleTypename diff --git a/hspec-test/Ast/SortBySpec.hs b/hspec-test/Ast/SortBySpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SortBySpec.hs @@ -0,0 +1,22 @@ +module Ast.SortBySpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SortBy +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SortBy + itSatisfiesArbitrary @SortBy + describe "Postgres grammar conformance" $ do + it "sortby" $ do + let render :: SortBy -> Text + render = toText mempty + fmap render (parse @SortBy mempty "a") `shouldBe` Right "a" + fmap render (parse @SortBy mempty "a asc") `shouldBe` Right "a ASC" + fmap render (parse @SortBy mempty "a desc nulls last") `shouldBe` Right "a DESC NULLS LAST" + fmap render (parse @SortBy mempty "a nulls first") `shouldBe` Right "a NULLS FIRST" + fmap render (parse @SortBy mempty "a using > nulls last") `shouldBe` Right "a USING > NULLS LAST" + fmap render (parse @SortBy mempty "nulls") `shouldBe` Right "nulls" diff --git a/hspec-test/Ast/SortClauseSpec.hs b/hspec-test/Ast/SortClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SortClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.SortClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SortClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SortClause + itSatisfiesArbitrary @SortClause diff --git a/hspec-test/Ast/SubTypeSpec.hs b/hspec-test/Ast/SubTypeSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SubTypeSpec.hs @@ -0,0 +1,10 @@ +module Ast.SubTypeSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SubType +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SubType + itSatisfiesArbitrary @SubType diff --git a/hspec-test/Ast/SubqueryOpSpec.hs b/hspec-test/Ast/SubqueryOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SubqueryOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.SubqueryOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SubqueryOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SubqueryOp + itSatisfiesArbitrary @SubqueryOp diff --git a/hspec-test/Ast/SubstrListFromForSpec.hs b/hspec-test/Ast/SubstrListFromForSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SubstrListFromForSpec.hs @@ -0,0 +1,10 @@ +module Ast.SubstrListFromForSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SubstrListFromFor +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SubstrListFromFor + itSatisfiesArbitrary @SubstrListFromFor diff --git a/hspec-test/Ast/SubstrListSpec.hs b/hspec-test/Ast/SubstrListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SubstrListSpec.hs @@ -0,0 +1,10 @@ +module Ast.SubstrListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SubstrList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SubstrList + itSatisfiesArbitrary @SubstrList diff --git a/hspec-test/Ast/SymbolicExprBinOpSpec.hs b/hspec-test/Ast/SymbolicExprBinOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/SymbolicExprBinOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.SymbolicExprBinOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.SymbolicExprBinOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @SymbolicExprBinOp + itSatisfiesArbitrary @SymbolicExprBinOp diff --git a/hspec-test/Ast/TableFuncElementListSpec.hs b/hspec-test/Ast/TableFuncElementListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TableFuncElementListSpec.hs @@ -0,0 +1,10 @@ +module Ast.TableFuncElementListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TableFuncElementList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TableFuncElementList + itSatisfiesArbitrary @TableFuncElementList diff --git a/hspec-test/Ast/TableFuncElementSpec.hs b/hspec-test/Ast/TableFuncElementSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TableFuncElementSpec.hs @@ -0,0 +1,10 @@ +module Ast.TableFuncElementSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TableFuncElement +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TableFuncElement + itSatisfiesArbitrary @TableFuncElement diff --git a/hspec-test/Ast/TableRefSpec.hs b/hspec-test/Ast/TableRefSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TableRefSpec.hs @@ -0,0 +1,12 @@ +module Ast.TableRefSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.JoinedTable +import PostgresqlSyntax.Ast.TableRef +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TableRef + itSatisfiesExtends @TableRef @JoinedTable + itSatisfiesArbitrary @TableRef diff --git a/hspec-test/Ast/TablesampleClauseSpec.hs b/hspec-test/Ast/TablesampleClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TablesampleClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.TablesampleClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TablesampleClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TablesampleClause + itSatisfiesArbitrary @TablesampleClause diff --git a/hspec-test/Ast/TargetElSpec.hs b/hspec-test/Ast/TargetElSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TargetElSpec.hs @@ -0,0 +1,10 @@ +module Ast.TargetElSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TargetEl +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TargetEl + itSatisfiesArbitrary @TargetEl diff --git a/hspec-test/Ast/TargetListSpec.hs b/hspec-test/Ast/TargetListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TargetListSpec.hs @@ -0,0 +1,10 @@ +module Ast.TargetListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TargetList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TargetList + itSatisfiesArbitrary @TargetList diff --git a/hspec-test/Ast/TargetingSpec.hs b/hspec-test/Ast/TargetingSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TargetingSpec.hs @@ -0,0 +1,10 @@ +module Ast.TargetingSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Targeting +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Targeting + itSatisfiesArbitrary @Targeting diff --git a/hspec-test/Ast/TimezoneSpec.hs b/hspec-test/Ast/TimezoneSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TimezoneSpec.hs @@ -0,0 +1,10 @@ +module Ast.TimezoneSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Timezone +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Timezone + itSatisfiesArbitrary @Timezone diff --git a/hspec-test/Ast/TrimListSpec.hs b/hspec-test/Ast/TrimListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TrimListSpec.hs @@ -0,0 +1,10 @@ +module Ast.TrimListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TrimList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TrimList + itSatisfiesArbitrary @TrimList diff --git a/hspec-test/Ast/TrimModifierSpec.hs b/hspec-test/Ast/TrimModifierSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TrimModifierSpec.hs @@ -0,0 +1,10 @@ +module Ast.TrimModifierSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TrimModifier +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TrimModifier + itSatisfiesArbitrary @TrimModifier diff --git a/hspec-test/Ast/TypeListSpec.hs b/hspec-test/Ast/TypeListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TypeListSpec.hs @@ -0,0 +1,10 @@ +module Ast.TypeListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TypeList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @TypeList + itSatisfiesArbitrary @TypeList diff --git a/hspec-test/Ast/TypenameArrayDimensionsSpec.hs b/hspec-test/Ast/TypenameArrayDimensionsSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TypenameArrayDimensionsSpec.hs @@ -0,0 +1,8 @@ +module Ast.TypenameArrayDimensionsSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.TypenameArrayDimensions +import Test.Hspec + +spec :: Spec +spec = itSatisfiesArbitrary @TypenameArrayDimensions diff --git a/hspec-test/Ast/TypenameSpec.hs b/hspec-test/Ast/TypenameSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/TypenameSpec.hs @@ -0,0 +1,46 @@ +module Ast.TypenameSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Typename +import PostgresqlSyntax.Settings (nullabilityMarkers) +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Typename + itSatisfiesArbitrary @Typename + describe "Parsers" $ do + itParses @Typename "int4" + itParses @Typename "int4[][]" + itParses @Typename "aa array" + itParses @Typename "DOUBLE PRECISION" + itParses @Typename "bool" + itParses @Typename "int2" + itParses @Typename "int4" + itParses @Typename "int8" + itParses @Typename "float4" + itParses @Typename "float8" + itParses @Typename "numeric" + itParses @Typename "char" + itParses @Typename "text" + itParses @Typename "bytea" + itParses @Typename "date" + itParses @Typename "timestamp" + itParses @Typename "timestamptz" + itParses @Typename "time" + itParses @Typename "timetz" + itParses @Typename "interval" + itParses @Typename "uuid" + itParses @Typename "inet" + itParses @Typename "json" + itParses @Typename "jsonb" + describe "extended" $ do + itParsesWith @Typename (nullabilityMarkers True) "text?" + itParsesWith @Typename (nullabilityMarkers True) "text[]?" + itParsesWith @Typename (nullabilityMarkers True) "text?[]?" + itParsesWith @Typename (nullabilityMarkers True) "text?[]" + itRejectsWith @Typename mempty "text?" + itRejectsWith @Typename mempty "text[]?" + itRejectsWith @Typename mempty "text?[]?" + itRejectsWith @Typename mempty "text?[]" diff --git a/hspec-test/Ast/UpdateStmtSpec.hs b/hspec-test/Ast/UpdateStmtSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/UpdateStmtSpec.hs @@ -0,0 +1,12 @@ +module Ast.UpdateStmtSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.UpdateStmt +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @UpdateStmt + itSatisfiesArbitrary @UpdateStmt + itParses @UpdateStmt "update foo as set set x = 1" + itRejects @UpdateStmt "update foo set set x = 1" diff --git a/hspec-test/Ast/UsingClauseSpec.hs b/hspec-test/Ast/UsingClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/UsingClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.UsingClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.UsingClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @UsingClause + itSatisfiesArbitrary @UsingClause diff --git a/hspec-test/Ast/ValuesClauseSpec.hs b/hspec-test/Ast/ValuesClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/ValuesClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.ValuesClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.ValuesClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @ValuesClause + itSatisfiesArbitrary @ValuesClause diff --git a/hspec-test/Ast/VerbalExprBinOpSpec.hs b/hspec-test/Ast/VerbalExprBinOpSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/VerbalExprBinOpSpec.hs @@ -0,0 +1,10 @@ +module Ast.VerbalExprBinOpSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.VerbalExprBinOp +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @VerbalExprBinOp + itSatisfiesArbitrary @VerbalExprBinOp diff --git a/hspec-test/Ast/WhenClauseListSpec.hs b/hspec-test/Ast/WhenClauseListSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WhenClauseListSpec.hs @@ -0,0 +1,10 @@ +module Ast.WhenClauseListSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WhenClauseList +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WhenClauseList + itSatisfiesArbitrary @WhenClauseList diff --git a/hspec-test/Ast/WhenClauseSpec.hs b/hspec-test/Ast/WhenClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WhenClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WhenClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WhenClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WhenClause + itSatisfiesArbitrary @WhenClause diff --git a/hspec-test/Ast/WhereClauseSpec.hs b/hspec-test/Ast/WhereClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WhereClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WhereClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WhereClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WhereClause + itSatisfiesArbitrary @WhereClause diff --git a/hspec-test/Ast/WhereOrCurrentClauseSpec.hs b/hspec-test/Ast/WhereOrCurrentClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WhereOrCurrentClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WhereOrCurrentClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WhereOrCurrentClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WhereOrCurrentClause + itSatisfiesArbitrary @WhereOrCurrentClause diff --git a/hspec-test/Ast/WindowClauseSpec.hs b/hspec-test/Ast/WindowClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WindowClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WindowClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WindowClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WindowClause + itSatisfiesArbitrary @WindowClause diff --git a/hspec-test/Ast/WindowDefinitionSpec.hs b/hspec-test/Ast/WindowDefinitionSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WindowDefinitionSpec.hs @@ -0,0 +1,10 @@ +module Ast.WindowDefinitionSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WindowDefinition +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WindowDefinition + itSatisfiesArbitrary @WindowDefinition diff --git a/hspec-test/Ast/WindowExclusionClauseSpec.hs b/hspec-test/Ast/WindowExclusionClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WindowExclusionClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WindowExclusionClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WindowExclusionClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WindowExclusionClause + itSatisfiesArbitrary @WindowExclusionClause diff --git a/hspec-test/Ast/WindowSpecificationSpec.hs b/hspec-test/Ast/WindowSpecificationSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WindowSpecificationSpec.hs @@ -0,0 +1,20 @@ +module Ast.WindowSpecificationSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WindowSpecification +import Prelude +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WindowSpecification + itSatisfiesArbitrary @WindowSpecification + describe "Postgres grammar conformance" $ do + -- gram.y:17428 window_specification: the sort clause and the + -- partition clause are both followed by opt_frame_clause, whose + -- leading keywords (RANGE/ROWS/GROUPS, kwlist.h:375,408,201) are + -- unreserved and therefore also legal ColIds. + itParses @WindowSpecification "(order by a rows unbounded preceding)" + itParses @WindowSpecification "(order by a range unbounded preceding)" + itParses @WindowSpecification "(partition by a groups unbounded preceding)" + itParses @WindowSpecification "(partition by a order by b rows 1 preceding)" diff --git a/hspec-test/Ast/WithClauseSpec.hs b/hspec-test/Ast/WithClauseSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/WithClauseSpec.hs @@ -0,0 +1,10 @@ +module Ast.WithClauseSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.WithClause +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @WithClause + itSatisfiesArbitrary @WithClause diff --git a/hspec-test/Ast/XconstSpec.hs b/hspec-test/Ast/XconstSpec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Ast/XconstSpec.hs @@ -0,0 +1,10 @@ +module Ast.XconstSpec (spec) where + +import Helpers.Specs +import PostgresqlSyntax.Ast.Xconst +import Test.Hspec + +spec :: Spec +spec = do + itSatisfiesIsAst @Xconst + itSatisfiesArbitrary @Xconst diff --git a/hspec-test/Helpers/Expectations.hs b/hspec-test/Helpers/Expectations.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Helpers/Expectations.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Helpers.Expectations + ( parsesTo, + rejects, + reportsError, + reportsSourcePosError, + parsesWithin, + parsesToWith, + rejectsWith, + ) +where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Settings (Settings) +import Prelude +import Test.Hspec +import Text.Megaparsec.Pos (sourcePosPretty) + +parsesTo :: forall a. (HasCallStack, IsAst a) => Text -> Expectation +parsesTo input = + case parse @a mempty input of + Left err -> expectationFailure (Text.unpack (err <> "\ninput: " <> input)) + Right _ -> pure () + +rejects :: forall a. (HasCallStack, IsAst a, Show a) => Text -> Expectation +rejects input = + case parse @a mempty input of + Left _ -> pure () + Right a -> + expectationFailure + ("expected a parse failure\ninput: " <> Text.unpack input <> "\nparsed: " <> show a) + +reportsError :: forall a. (HasCallStack, IsAst a) => Text -> String -> Expectation +reportsError input expected = + case parseWithPosError @a mempty input of + Left err -> show (NonEmpty.head err) `shouldBe` expected + Right _ -> expectationFailure "expected a parse error, but it succeeded" + +-- | Like 'reportsError' but checks 'parseWithSourcePosError''s +-- 'Text.Megaparsec.SourcePos'-based errors instead. +reportsSourcePosError :: forall a. (HasCallStack, IsAst a) => Text -> String -> Expectation +reportsSourcePosError input expected = + case parseWithSourcePosError @a mempty input of + Left err -> + let (pos, msg) = NonEmpty.head err + in (Text.unpack (Text.pack (sourcePosPretty pos) <> " " <> msg)) `shouldBe` expected + Right _ -> expectationFailure "expected a parse error, but it succeeded" + +parsesWithin :: forall a. (HasCallStack, IsAst a) => Int -> Text -> Expectation +parsesWithin seconds input = do + result <- + timeout (seconds * 1000000) + $ case parse @a mempty input of + Left err -> expectationFailure (Text.unpack (err <> "\ninput: " <> input)) + Right _ -> pure () + case result of + Nothing -> expectationFailure ("Did not finish parsing within " <> show seconds <> "s") + Just () -> pure () + +-- | Like 'parsesTo' but with a non-default 'Settings'. +parsesToWith :: forall a. (HasCallStack, IsAst a) => Settings -> Text -> Expectation +parsesToWith settings input = + case parse @a settings input of + Left err -> expectationFailure (Text.unpack (err <> "\ninput: " <> input)) + Right _ -> pure () + +-- | Like 'rejects' but with a non-default 'Settings'. +rejectsWith :: forall a. (HasCallStack, IsAst a, Show a) => Settings -> Text -> Expectation +rejectsWith settings input = + case parse @a settings input of + Left _ -> pure () + Right a -> + expectationFailure + ("expected a parse failure\ninput: " <> Text.unpack input <> "\nparsed: " <> show a) diff --git a/hspec-test/Helpers/Specs.hs b/hspec-test/Helpers/Specs.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Helpers/Specs.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Helpers.Specs + ( itSatisfiesIsAst, + itSatisfiesCanonicalizes, + itSatisfiesRefines, + itSatisfiesExtends, + itSatisfiesArbitrary, + itParses, + itRejects, + itReportsError, + itReportsSourcePosError, + itParsesWithin, + + -- * Settings-aware variants + itParsesWith, + itRejectsWith, + ) +where + +import qualified Data.Text as Text +import qualified Helpers.Expectations as Expectations +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Settings (Settings) +import Prelude +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import qualified Test.QuickCheck as Qc + +itSatisfiesIsAst :: forall a. (IsAst a, Eq a, Show a, Qc.Arbitrary a) => Spec +itSatisfiesIsAst = + describe "IsAst" $ for_ (isAstProperties @a) (uncurry prop) + +itSatisfiesCanonicalizes :: forall a. (Canonicalizes a, Eq a, Show a, Qc.Arbitrary a) => Spec +itSatisfiesCanonicalizes = + describe "Canonicalizes" $ for_ (canonicalizesProperties @a) (uncurry prop) + +itSatisfiesRefines :: forall sub sup. (Refines sub sup, IsAst sub, Eq sub, Show sub, Qc.Arbitrary sub) => Spec +itSatisfiesRefines = + describe "Refines" $ for_ (refinesProperties @sub @sup) (uncurry prop) + +itSatisfiesExtends :: forall base ext. (Extends base ext, IsAst base, Eq base, Show base, Qc.Arbitrary base) => Spec +itSatisfiesExtends = + describe "Extends" $ for_ (extendedByProperties @base @ext) (uncurry prop) + +itSatisfiesArbitrary :: forall a. (IsAst a, Show a, Qc.Arbitrary a) => Spec +itSatisfiesArbitrary = + describe "Arbitrary" $ do + prop "Terminates at size 0" terminatesAtZero + prop "Grows boundedly" growsBounded + where + terminatesAtZero = + Qc.forAll (Qc.resize 0 (Qc.arbitrary @a)) $ \x -> + let sql = toText mempty x + len = Text.length sql + in Qc.counterexample + ("rendered " <> show len <> " chars at size 0 (max " <> show zeroSizeMaxLen <> ")" <> "\n" <> Text.unpack sql) + (len <= zeroSizeMaxLen) + where + zeroSizeMaxLen = 500 :: Int + + growsBounded = + Qc.forAll (Qc.resize maxGenSize (Qc.arbitrary @a)) $ \x -> + let sql = toText mempty x + len = Text.length sql + in Qc.counterexample + ("rendered " <> show len <> " chars at size " <> show maxGenSize <> " (max " <> show maxGenSizeMaxLen <> ")") + (len <= maxGenSizeMaxLen) + where + maxGenSize = 100 :: Int + maxGenSizeMaxLen = 1000000 :: Int + +itParses :: forall a. (HasCallStack, IsAst a) => Text -> Spec +itParses sql = + describe (Text.unpack sql) $ do + it "Parses" (Expectations.parsesTo @a sql) + +itRejects :: forall a. (HasCallStack, IsAst a, Show a) => Text -> Spec +itRejects sql = + describe (Text.unpack sql) $ do + it "Rejects" (Expectations.rejects @a sql) + +itReportsError :: forall a. (HasCallStack, IsAst a) => Text -> String -> Spec +itReportsError sql expected = + describe (Text.unpack sql) $ do + it ("Reports error: " <> expected) (Expectations.reportsError @a sql expected) + +-- | Like 'itReportsError' but checks 'PostgresqlSyntax.Algebra.parseWithSourcePosError''s +-- 'Text.Megaparsec.SourcePos'-based errors instead. +itReportsSourcePosError :: forall a. (HasCallStack, IsAst a) => Text -> String -> Spec +itReportsSourcePosError sql expected = + describe (Text.unpack sql) $ do + it ("Reports error: " <> expected) (Expectations.reportsSourcePosError @a sql expected) + +itParsesWithin :: forall a. (HasCallStack, IsAst a) => Int -> Text -> Spec +itParsesWithin seconds sql = + describe (Text.unpack sql) $ do + it ("Parses within " <> show seconds <> " seconds") (Expectations.parsesWithin @a seconds sql) + +-- | Wraps 'Expectations.parsesToWith' as a standalone 'Spec'. +itParsesWith :: forall a. (HasCallStack, IsAst a) => Settings -> Text -> Spec +itParsesWith settings sql = + describe (Text.unpack sql) $ do + it "Parses" (Expectations.parsesToWith @a settings sql) + +-- | Wraps 'Expectations.rejectsWith' as a standalone 'Spec'. +itRejectsWith :: forall a. (HasCallStack, IsAst a, Show a) => Settings -> Text -> Spec +itRejectsWith settings sql = + describe (Text.unpack sql) $ do + it "Rejects" (Expectations.rejectsWith @a settings sql) diff --git a/hspec-test/Main.hs b/hspec-test/Main.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Prelude +import qualified Spec +import Test.Hspec + +main :: IO () +main = hspec $ parallel Spec.spec diff --git a/hspec-test/Spec.hs b/hspec-test/Spec.hs new file mode 100644 --- /dev/null +++ b/hspec-test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/library-internal/PostgresqlSyntax/Algebra.hs b/library-internal/PostgresqlSyntax/Algebra.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Algebra.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module PostgresqlSyntax.Algebra + ( IsAst (..), + toText, + parse, + parseWithPosError, + parseWithSourcePosError, + isAstProperties, + Canonicalizes (..), + canonicalizesProperties, + Refines (..), + refinesProperties, + LeftRecursive (..), + Extends (..), + extendedByProperties, + parseMaybeExtended, + parseExtended, + parseExtensionChain, + ) +where + +import qualified Data.Text as Text +import qualified HeadedMegaparsec as Parser +import qualified PostgresqlSyntax.Extras.HeadedMegaparsec as Extras +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc +import qualified Text.Megaparsec as Megaparsec +import qualified TextBuilder + +-- | +-- Class of AST types that can be rendered to SQL text and parsed back again. +-- +-- Laws: +-- +-- * __Roundtrips__: @parse settings (toText settings a) = Right a@ for every +-- 'Settings' — rendering and parsing are inverses. +-- * __Congruent rendering__: @a == b => toTextBuilder settings a == toTextBuilder settings b@ +-- for every 'Settings' — rendering only depends on the value, not on how it +-- was constructed. This is what makes it meaningful to say two structurally +-- different shapes can still render to identical text — the ambiguity that +-- 'Canonicalizes' exists to resolve. +class IsAst a where + -- | + -- Render an AST value to a 'TextBuilder' using the given 'Settings'. + -- This is the low-level rendering primitive; 'toText' wraps it. + toTextBuilder :: Settings -> a -> TextBuilder + + -- | + -- A parser for this AST type, parameterized by 'Settings'. + -- The parser must satisfy the roundtrip law documented on 'IsAst'. + parser :: Settings -> Parser a + +-- | +-- 'Qc.Property'-checkers for 'IsAst'\'s documented laws, keyed by name. +isAstProperties :: forall a. (IsAst a, Eq a, Show a, Qc.Arbitrary a) => [(String, Qc.Property)] +isAstProperties = + [ ( "Roundtrips", + Qc.property $ \(a :: a) -> + let sql = toText mempty a + in case parse mempty sql of + Left err -> + Qc.counterexample ("rendered: " <> Text.unpack sql <> "\nparse failed: " <> Text.unpack err) False + Right a' -> + Qc.counterexample + ("rendered: " <> Text.unpack sql <> "\nrestored: " <> Text.unpack (toText mempty a')) + (a' Qc.=== a) + ), + ( "Renders equal values equally", + Qc.property $ \(a :: a) (b :: a) -> + a /= b || toText mempty a == toText mempty b + ) + ] + +-- | +-- Render a value to 'Text' via its 'toTextBuilder' method. +toText :: (IsAst a) => Settings -> a -> Text +toText settings = TextBuilder.toText . toTextBuilder settings + +-- | +-- Parse a 'Text' input with the type's 'parser', returning either a +-- pretty-printed error or the parsed value. The parser is chosen by the +-- caller's type inference (via the 'IsAst' constraint), so callers no longer +-- pass an explicit parser argument. +parse :: (IsAst a) => Settings -> Text -> Either Text a +parse settings = first Text.pack . Extras.run (Extras.totally (parser settings)) + +-- | +-- Like 'parse' but returns the structured error list (each error paired with +-- its byte offset) instead of a single pretty-printed message. +parseWithPosError :: (IsAst a) => Settings -> Text -> Either (NonEmpty (Int, Text)) a +parseWithPosError settings = first (fmap (second Text.pack)) . Extras.runParserWithErrorPos (Extras.totally (parser settings)) + +-- | +-- Like 'parseWithPosError' but pairs each error with its +-- 'Text.Megaparsec.SourcePos' instead of a raw byte offset. +parseWithSourcePosError :: (IsAst a) => Settings -> Text -> Either (NonEmpty (Megaparsec.SourcePos, Text)) a +parseWithSourcePosError settings = first (fmap (second Text.pack)) . Extras.runParserWithSourcePosError (Extras.totally (parser settings)) + +-- | +-- Laws: +-- +-- * __Idempotent__: @canonicalize . canonicalize = canonicalize@ +-- * __Parse-agreement__ (the property this class exists to provide): +-- @parse settings . toText settings = Right . canonicalize@ for every +-- 'PostgresqlSyntax.Settings.Settings' +class (IsAst a) => Canonicalizes a where + canonicalize :: a -> a + canonicalize = id + +-- | +-- 'Qc.Property'-checkers for 'Canonicalizes'\'s documented laws, keyed by +-- name. \"Parse-agreement\" is tested at 'mempty' 'Settings', matching how +-- 'isAstProperties'\'s \"Renders equal values equally\" property handles \"for +-- every 'Settings'\" — no 'Qc.Arbitrary' 'Settings' instance exists or is +-- being added. +canonicalizesProperties :: forall a. (Canonicalizes a, Eq a, Show a, Qc.Arbitrary a) => [(String, Qc.Property)] +canonicalizesProperties = + [ ( "Idempotent", + Qc.property $ \(a :: a) -> + canonicalize (canonicalize a) Qc.=== canonicalize a + ), + ( "Parse-agreement", + Qc.property $ \(a :: a) -> + parse mempty (toText mempty a) Qc.=== Right (canonicalize a) + ) + ] + +-- | +-- Laws: +-- +-- * __Refinement law__: @project . embed = Just@ +-- +-- Expresses embedding relationships between AST node types across module +-- boundaries where cross-module pattern matching is unavailable. Instances +-- hold between two types when the 'sub' type can be trivially embedded into +-- 'sup', and trivial 'sup' values can be recognized as such a 'sub' and +-- extracted back out. +class Refines sub sup where + embed :: sub -> sup + project :: sup -> Maybe sub + +-- | +-- 'Qc.Property'-checkers for 'Refines'\'s documented laws, keyed by name. +refinesProperties :: forall sub sup. (Refines sub sup, IsAst sub, Eq sub, Show sub, Qc.Arbitrary sub) => [(String, Qc.Property)] +refinesProperties = + [ ( "Refinement law", + Qc.property $ \(a :: sub) -> + project (embed a :: sup) Qc.=== Just a + ) + ] + +-- | +-- A type some of whose grammar productions are left-recursive — i.e. there +-- is a larger recursive form built by extending a value of this type on its +-- left. 'parseBase' is everything that is /not/ one of those productions: +-- the @β@ of @A -> Aα | β@. +-- +-- This is a strictly weaker claim than 'Extends', which additionally +-- names the specific @ext@ of one such hub. A type can be 'LeftRecursive' +-- without being any hub's @base@ — 'PostgresqlSyntax.Ast.JoinedTable' and +-- 'PostgresqlSyntax.Ast.SimpleSelect' both are, since each is reached by +-- extending a /different/ type (@table_ref@ and @select_clause@ +-- respectively) yet still has non-left-recursive productions of its own. +-- +-- Separating this from 'Extends' is what lets each instance live with +-- the type it constructs: 'parseBase' mentions only its own type, so it +-- belongs to that type's module, while a hub's 'parseExtensions' belongs to +-- the module defining @ext@. Because both are class methods, either module +-- can reach the other's parser through an @hs-boot@ instance declaration +-- without exporting a bare helper. +-- +-- Note that \"non-recursive\" here means non-/left/-recursive only: a +-- production may still recurse, so long as it doesn't begin with the +-- recursive position (e.g. @'(' joined_table ')'@). +class (IsAst a) => LeftRecursive a where + -- | Parse only the productions that don't left-recurse (@β@). + parseBase :: Settings -> Parser a + +-- | +-- The two halves of a left-recursive grammar production, split apart by +-- left-recursion elimination (@A -> Aα | β@ becomes @A -> β α*@): 'base' is +-- @A@ (and supplies @β@ via its 'LeftRecursive' instance), and 'ext' is +-- what one or more @α@\'s, applied to a @base@, produce. +-- +-- Laws: +-- +-- * __Base-parser agreement__: @parser \@base = parseMaybeExtended \@base@ +-- * __Maximal munch__: 'parseExtensions' must not return while a further +-- extension is available — instances build this on 'parseExtensionChain' +-- where possible, which already guarantees it. +class (LeftRecursive base, Refines ext base) => Extends base ext | ext -> base where + -- | Parse one or more extensions onto an already-parsed left operand, + -- folding as it goes, and return the fully-extended result. + parseExtensions :: Settings -> base -> Parser ext + +-- | +-- 'Qc.Property'-checker for 'Extends'\'s \"Base-parser agreement\" law, +-- keyed by name. \"Maximal munch\" isn't checked here: it's a per-instance +-- parsing obligation, not something a generated 'base' value can exercise +-- through 'parser' alone. The agreement check is itself up to whether +-- parsing succeeds, ignoring error message text, since a base's 'parser' +-- may wrap 'parseMaybeExtended' in a 'HeadedMegaparsec.label' or similar +-- that changes failure messages without changing what's accepted. +extendedByProperties :: forall base ext. (Extends base ext, IsAst base, Eq base, Show base, Qc.Arbitrary base) => [(String, Qc.Property)] +extendedByProperties = + [ ( "Base-parser agreement", + Qc.property $ \(a :: base) -> + let sql = toText mempty a + run p = first (const ()) (Extras.run (Extras.totally p) sql) + in run (parser @base mempty) Qc.=== run (parseMaybeExtended @ext mempty) + ) + ] + +-- | +-- Parses zero or more extensions onto a 'parseBase', via 'parseExtensions'. +-- This is what @A -> β α*@ (the whole of @A@) means as a parser. +parseMaybeExtended :: forall ext base. (Extends base ext) => Settings -> Parser base +parseMaybeExtended settings = do + b <- parseBase @base settings + optional (parseExtensions @base settings b) >>= maybe (pure b) (pure . embed @ext @base) + +-- | +-- Like 'parseMaybeExtended', but requires at least one extension to follow +-- the base, and so returns the fully-applied 'ext' type directly rather +-- than 'base'. This is what a bare @α*@ (one or more) means as a parser, +-- for hubs where a chain of at least one extension is itself the +-- interesting type (e.g. a @joined_table@, which is never a bare +-- @table_ref@ with zero joins). +-- +-- Unlike 'parseMaybeExtended', 'parseBase' here is wrapped in +-- 'Parser.wrapToHead'. Without it, if 'parseBase' itself commits past an +-- internal 'Parser.endHead' (e.g. by matching a nested, fully-parenthesized +-- instance of the very thing this function's caller is one alternative +-- for), that commitment silently swallows the immediately-following "is +-- there at least one extension?" check: a missing extension would fail as +-- a hard, uncatchable error instead of a clean one this function's own +-- caller can backtrack from. 'wrapToHead' resets that, forcing the check +-- to fail cleanly. 'parseMaybeExtended' doesn't need this: its own +-- extension check already goes through 'optional', which independently +-- wraps in 'Megaparsec.try' regardless of what 'parseBase' committed to. +parseExtended :: forall base ext. (Extends base ext) => Settings -> Parser ext +parseExtended settings = do + b <- Parser.wrapToHead (parseBase @base settings) + parseExtensions @base settings b + +-- | +-- Parses one or more items back-to-back, wrapping each in +-- 'Parser.wrapToHead'\/'Parser.endHead' so that, once an item's own head has +-- matched, backtracking out of the whole chain (back to "there are no more +-- items") is no longer attempted — matching the hand-written +-- recursive-descent loops this replaces. This is the shared backtracking +-- protocol underlying 'Extends'\'s \"Maximal munch\" law: an instance +-- building 'parseExtensions' on top of this combinator gets the law for +-- free, since 'go' only stops once a further item genuinely isn't +-- available. +parseExtensionChain :: Parser item -> Parser (NonEmpty item) +parseExtensionChain item = go + where + go = do + i <- Parser.wrapToHead item + Parser.endHead + rest <- optional go + pure $ case rest of + Nothing -> i :| [] + Just (j :| js) -> i :| j : js diff --git a/library-internal/PostgresqlSyntax/Ast.hs b/library-internal/PostgresqlSyntax/Ast.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast.hs @@ -0,0 +1,380 @@ +-- | +-- Names for nodes mostly resemble the according definitions in the @gram.y@ +-- original Postgres parser file, except for the cases where we can optimize on that. +-- +-- For reasoning see the docs of the parsing module of this project. +module PostgresqlSyntax.Ast + ( -- * Nodes + AExpr (..), + AExprReversableOp (..), + AexprConst (..), + AliasClause (..), + AllOp (..), + AnyName (..), + AnyOperator (..), + ArrayBounds (..), + ArrayExpr (..), + ArrayExprList (..), + AscDesc (..), + Attrs (..), + BExpr (..), + BExprIsOp (..), + Bconst (..), + Bit (..), + CExpr (..), + CallStmt (..), + CaseExpr (..), + Character (..), + Columnref (..), + CommonTableExpr (..), + ConfExpr (..), + ConstCharacter (..), + ConstDatetime (..), + ConstTypename (..), + DeleteStmt (..), + ExplicitRow (..), + ExprList (..), + ExtractArg (..), + ExtractList (..), + Fconst (..), + ForLockingClause (..), + ForLockingItem (..), + ForLockingStrength (..), + FrameBound (..), + FrameClause (..), + FrameClauseMode (..), + FrameExtent (..), + FromClause (..), + FromList (..), + FuncAliasClause (..), + FuncApplication (..), + FuncApplicationParams (..), + FuncArgExpr (..), + FuncConstArgs (..), + FuncExpr (..), + FuncExprCommonSubexpr (..), + FuncExprWindowless (..), + FuncName (..), + FuncTable (..), + GenericType (..), + GroupByItem (..), + GroupClause (..), + HavingClause (..), + Iconst (..), + Ident (..), + ImplicitRow (..), + InExpr (..), + IndexElem (..), + IndexElemDef (..), + IndexParams (..), + Indirection (..), + IndirectionEl (..), + InsertColumnItem (..), + InsertColumnList (..), + InsertRest (..), + InsertStmt (..), + InsertTarget (..), + Interval (..), + IntervalSecond (..), + IntoClause (..), + JoinQual (..), + JoinType (..), + JoinedTable (..), + LimitClause (..), + MathOp (..), + NameList (..), + NullsOrder (..), + Numeric (..), + OffsetClause (..), + OnConflict (..), + OnConflictDo (..), + Op (..), + OptOrdinality (..), + OptTempTableName (..), + OptVarying (..), + OverClause (..), + OverlayList (..), + OverrideKind (..), + PositionList (..), + PreparableStmt (..), + QualAllOp (..), + QualOp (..), + QualifiedName (..), + RelationExpr (..), + RelationExprOptAlias (..), + ReturningClause (..), + Row (..), + RowsfromItem (..), + RowsfromList (..), + Sconst (..), + SelectBinOp (..), + SelectClause (..), + SelectFetchFirstValue (..), + SelectLimit (..), + SelectLimitValue (..), + SelectNoParens (..), + SelectStmt (..), + SelectWithParens (..), + SetClause (..), + SetClauseList (..), + SetTarget (..), + SetTargetList (..), + SimpleSelect (..), + SimpleTypename (..), + SortBy (..), + SortClause (..), + SubType (..), + SubqueryOp (..), + SubstrList (..), + SubstrListFromFor (..), + SymbolicExprBinOp (..), + TableFuncElement (..), + TableFuncElementList (..), + TableRef (..), + TablesampleClause (..), + TargetEl (..), + TargetList (..), + Targeting (..), + Timezone (..), + TrimList (..), + TrimModifier (..), + TypeList (..), + Typename (..), + TypenameArrayDimensions (..), + UpdateStmt (..), + UsingClause (..), + ValuesClause (..), + VerbalExprBinOp (..), + WhenClause (..), + WhenClauseList (..), + WhereClause (..), + WhereOrCurrentClause (..), + WindowClause (..), + WindowDefinition (..), + WindowExclusionClause (..), + WindowSpecification (..), + WithClause (..), + Xconst (..), + + -- * Bare aliases + ExistingWindowName, + PartitionClause, + RepeatableClause, + ColDefList, + CollateClause, + WithinGroupClause, + FilterClause, + OverlayPlacing, + SubstrFrom, + SubstrFor, + CaseArg, + CaseDefault, + ConstBit, + ColId, + ColLabel, + Name, + CursorName, + AttrName, + TypeModifiers, + Collate, + Class, + TypeFunctionName, + ) +where + +import PostgresqlSyntax.Ast.AExpr +import PostgresqlSyntax.Ast.AExprReversableOp +import PostgresqlSyntax.Ast.AexprConst +import PostgresqlSyntax.Ast.AliasClause +import PostgresqlSyntax.Ast.AllOp +import PostgresqlSyntax.Ast.AnyName +import PostgresqlSyntax.Ast.AnyOperator +import PostgresqlSyntax.Ast.ArrayBounds +import PostgresqlSyntax.Ast.ArrayExpr +import PostgresqlSyntax.Ast.ArrayExprList +import PostgresqlSyntax.Ast.AscDesc +import PostgresqlSyntax.Ast.Attrs +import PostgresqlSyntax.Ast.BExpr +import PostgresqlSyntax.Ast.BExprIsOp +import PostgresqlSyntax.Ast.Bconst +import PostgresqlSyntax.Ast.Bit +import PostgresqlSyntax.Ast.CExpr +import PostgresqlSyntax.Ast.CallStmt +import PostgresqlSyntax.Ast.CaseExpr +import PostgresqlSyntax.Ast.Character +import PostgresqlSyntax.Ast.Columnref +import PostgresqlSyntax.Ast.CommonTableExpr +import PostgresqlSyntax.Ast.ConfExpr +import PostgresqlSyntax.Ast.ConstCharacter +import PostgresqlSyntax.Ast.ConstDatetime +import PostgresqlSyntax.Ast.ConstTypename +import PostgresqlSyntax.Ast.DeleteStmt +import PostgresqlSyntax.Ast.ExplicitRow +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.ExtractArg +import PostgresqlSyntax.Ast.ExtractList +import PostgresqlSyntax.Ast.Fconst +import PostgresqlSyntax.Ast.ForLockingClause +import PostgresqlSyntax.Ast.ForLockingItem +import PostgresqlSyntax.Ast.ForLockingStrength +import PostgresqlSyntax.Ast.FrameBound +import PostgresqlSyntax.Ast.FrameClause +import PostgresqlSyntax.Ast.FrameClauseMode +import PostgresqlSyntax.Ast.FrameExtent +import PostgresqlSyntax.Ast.FromClause +import PostgresqlSyntax.Ast.FromList +import PostgresqlSyntax.Ast.FuncAliasClause +import PostgresqlSyntax.Ast.FuncApplication +import PostgresqlSyntax.Ast.FuncApplicationParams +import PostgresqlSyntax.Ast.FuncArgExpr +import PostgresqlSyntax.Ast.FuncConstArgs +import PostgresqlSyntax.Ast.FuncExpr +import PostgresqlSyntax.Ast.FuncExprCommonSubexpr +import PostgresqlSyntax.Ast.FuncExprWindowless +import PostgresqlSyntax.Ast.FuncName +import PostgresqlSyntax.Ast.FuncTable +import PostgresqlSyntax.Ast.GenericType +import PostgresqlSyntax.Ast.GroupByItem +import PostgresqlSyntax.Ast.GroupClause +import PostgresqlSyntax.Ast.HavingClause +import PostgresqlSyntax.Ast.Iconst +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.ImplicitRow +import PostgresqlSyntax.Ast.InExpr +import PostgresqlSyntax.Ast.IndexElem +import PostgresqlSyntax.Ast.IndexElemDef +import PostgresqlSyntax.Ast.IndexParams +import PostgresqlSyntax.Ast.Indirection +import PostgresqlSyntax.Ast.IndirectionEl +import PostgresqlSyntax.Ast.InsertColumnItem +import PostgresqlSyntax.Ast.InsertColumnList +import PostgresqlSyntax.Ast.InsertRest +import PostgresqlSyntax.Ast.InsertStmt +import PostgresqlSyntax.Ast.InsertTarget +import PostgresqlSyntax.Ast.Interval +import PostgresqlSyntax.Ast.IntervalSecond +import PostgresqlSyntax.Ast.IntoClause +import PostgresqlSyntax.Ast.JoinQual +import PostgresqlSyntax.Ast.JoinType +import PostgresqlSyntax.Ast.JoinedTable +import PostgresqlSyntax.Ast.LimitClause +import PostgresqlSyntax.Ast.MathOp +import PostgresqlSyntax.Ast.NameList +import PostgresqlSyntax.Ast.NullsOrder +import PostgresqlSyntax.Ast.Numeric +import PostgresqlSyntax.Ast.OffsetClause +import PostgresqlSyntax.Ast.OnConflict +import PostgresqlSyntax.Ast.OnConflictDo +import PostgresqlSyntax.Ast.Op +import PostgresqlSyntax.Ast.OptOrdinality +import PostgresqlSyntax.Ast.OptTempTableName +import PostgresqlSyntax.Ast.OptVarying +import PostgresqlSyntax.Ast.OverClause +import PostgresqlSyntax.Ast.OverlayList +import PostgresqlSyntax.Ast.OverrideKind +import PostgresqlSyntax.Ast.PositionList +import PostgresqlSyntax.Ast.PreparableStmt +import PostgresqlSyntax.Ast.QualAllOp +import PostgresqlSyntax.Ast.QualOp +import PostgresqlSyntax.Ast.QualifiedName +import PostgresqlSyntax.Ast.RelationExpr +import PostgresqlSyntax.Ast.RelationExprOptAlias +import PostgresqlSyntax.Ast.ReturningClause +import PostgresqlSyntax.Ast.Row +import PostgresqlSyntax.Ast.RowsfromItem +import PostgresqlSyntax.Ast.RowsfromList +import PostgresqlSyntax.Ast.Sconst +import PostgresqlSyntax.Ast.SelectBinOp +import PostgresqlSyntax.Ast.SelectClause +import PostgresqlSyntax.Ast.SelectFetchFirstValue +import PostgresqlSyntax.Ast.SelectLimit +import PostgresqlSyntax.Ast.SelectLimitValue +import PostgresqlSyntax.Ast.SelectNoParens +import PostgresqlSyntax.Ast.SelectStmt +import PostgresqlSyntax.Ast.SelectWithParens +import PostgresqlSyntax.Ast.SetClause +import PostgresqlSyntax.Ast.SetClauseList +import PostgresqlSyntax.Ast.SetTarget +import PostgresqlSyntax.Ast.SetTargetList +import PostgresqlSyntax.Ast.SimpleSelect +import PostgresqlSyntax.Ast.SimpleTypename +import PostgresqlSyntax.Ast.SortBy +import PostgresqlSyntax.Ast.SortClause +import PostgresqlSyntax.Ast.SubType +import PostgresqlSyntax.Ast.SubqueryOp +import PostgresqlSyntax.Ast.SubstrList +import PostgresqlSyntax.Ast.SubstrListFromFor +import PostgresqlSyntax.Ast.SymbolicExprBinOp +import PostgresqlSyntax.Ast.TableFuncElement +import PostgresqlSyntax.Ast.TableFuncElementList +import PostgresqlSyntax.Ast.TableRef +import PostgresqlSyntax.Ast.TablesampleClause +import PostgresqlSyntax.Ast.TargetEl +import PostgresqlSyntax.Ast.TargetList +import PostgresqlSyntax.Ast.Targeting +import PostgresqlSyntax.Ast.Timezone +import PostgresqlSyntax.Ast.TrimList +import PostgresqlSyntax.Ast.TrimModifier +import PostgresqlSyntax.Ast.TypeList +import PostgresqlSyntax.Ast.Typename +import PostgresqlSyntax.Ast.TypenameArrayDimensions +import PostgresqlSyntax.Ast.UpdateStmt +import PostgresqlSyntax.Ast.UsingClause +import PostgresqlSyntax.Ast.ValuesClause +import PostgresqlSyntax.Ast.VerbalExprBinOp +import PostgresqlSyntax.Ast.WhenClause +import PostgresqlSyntax.Ast.WhenClauseList +import PostgresqlSyntax.Ast.WhereClause +import PostgresqlSyntax.Ast.WhereOrCurrentClause +import PostgresqlSyntax.Ast.WindowClause +import PostgresqlSyntax.Ast.WindowDefinition +import PostgresqlSyntax.Ast.WindowExclusionClause +import PostgresqlSyntax.Ast.WindowSpecification +import PostgresqlSyntax.Ast.WithClause +import PostgresqlSyntax.Ast.Xconst + +-- * Bare aliases + +type ExistingWindowName = ColId + +type PartitionClause = ExprList + +type RepeatableClause = AExpr + +type ColDefList = TableFuncElementList + +type CollateClause = AnyName + +type WithinGroupClause = SortClause + +type FilterClause = AExpr + +type OverlayPlacing = AExpr + +type SubstrFrom = AExpr + +type SubstrFor = AExpr + +type CaseArg = AExpr + +type CaseDefault = AExpr + +type ConstBit = Bit + +type ColId = Ident + +type ColLabel = Ident + +type Name = ColId + +type CursorName = Name + +type AttrName = ColLabel + +type TypeModifiers = ExprList + +type Collate = AnyName + +type Class = AnyName + +type TypeFunctionName = Ident diff --git a/library-internal/PostgresqlSyntax/Ast/AExpr.hs b/library-internal/PostgresqlSyntax/Ast/AExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AExpr.hs @@ -0,0 +1,433 @@ +module PostgresqlSyntax.Ast.AExpr + ( AExpr (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AExprReversableOp +import PostgresqlSyntax.Ast.AnyName +import PostgresqlSyntax.Ast.CExpr (CExpr) +import qualified PostgresqlSyntax.Ast.CExpr as CExpr +import PostgresqlSyntax.Ast.QualOp +import PostgresqlSyntax.Ast.Row +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import PostgresqlSyntax.Ast.SubType +import PostgresqlSyntax.Ast.SubqueryOp +import PostgresqlSyntax.Ast.SymbolicExprBinOp +import PostgresqlSyntax.Ast.Typename +import PostgresqlSyntax.Ast.VerbalExprBinOp +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- a_expr: +-- | c_expr +-- | a_expr TYPECAST Typename +-- | a_expr COLLATE any_name +-- | a_expr AT TIME ZONE a_expr +-- | '+' a_expr +-- | '-' a_expr +-- | a_expr '+' a_expr +-- | a_expr '-' a_expr +-- | a_expr '*' a_expr +-- | a_expr '/' a_expr +-- | a_expr '%' a_expr +-- | a_expr '^' a_expr +-- | a_expr '<' a_expr +-- | a_expr '>' a_expr +-- | a_expr '=' a_expr +-- | a_expr LESS_EQUALS a_expr +-- | a_expr GREATER_EQUALS a_expr +-- | a_expr NOT_EQUALS a_expr +-- | a_expr qual_Op a_expr +-- | qual_Op a_expr +-- | a_expr AND a_expr +-- | a_expr OR a_expr +-- | NOT a_expr +-- | NOT_LA a_expr +-- | a_expr LIKE a_expr +-- | a_expr LIKE a_expr ESCAPE a_expr +-- | a_expr NOT_LA LIKE a_expr +-- | a_expr NOT_LA LIKE a_expr ESCAPE a_expr +-- | a_expr ILIKE a_expr +-- | a_expr ILIKE a_expr ESCAPE a_expr +-- | a_expr NOT_LA ILIKE a_expr +-- | a_expr NOT_LA ILIKE a_expr ESCAPE a_expr +-- | a_expr SIMILAR TO a_expr +-- | a_expr SIMILAR TO a_expr ESCAPE a_expr +-- | a_expr NOT_LA SIMILAR TO a_expr +-- | a_expr NOT_LA SIMILAR TO a_expr ESCAPE a_expr +-- | a_expr IS NULL_P +-- | a_expr ISNULL +-- | a_expr IS NOT NULL_P +-- | a_expr NOTNULL +-- | row OVERLAPS row +-- | a_expr IS TRUE_P +-- | a_expr IS NOT TRUE_P +-- | a_expr IS FALSE_P +-- | a_expr IS NOT FALSE_P +-- | a_expr IS UNKNOWN +-- | a_expr IS NOT UNKNOWN +-- | a_expr IS DISTINCT FROM a_expr +-- | a_expr IS NOT DISTINCT FROM a_expr +-- | a_expr IS OF '(' type_list ')' +-- | a_expr IS NOT OF '(' type_list ')' +-- | a_expr BETWEEN opt_asymmetric b_expr AND a_expr +-- | a_expr NOT_LA BETWEEN opt_asymmetric b_expr AND a_expr +-- | a_expr BETWEEN SYMMETRIC b_expr AND a_expr +-- | a_expr NOT_LA BETWEEN SYMMETRIC b_expr AND a_expr +-- | a_expr IN_P in_expr +-- | a_expr NOT_LA IN_P in_expr +-- | a_expr subquery_Op sub_type select_with_parens +-- | a_expr subquery_Op sub_type '(' a_expr ')' +-- | UNIQUE select_with_parens +-- | a_expr IS DOCUMENT_P +-- | a_expr IS NOT DOCUMENT_P +-- | DEFAULT +-- @ +data AExpr + = CExprAExpr CExpr + | TypecastAExpr AExpr Typename + | CollateAExpr AExpr AnyName + | AtTimeZoneAExpr AExpr AExpr + | PlusAExpr AExpr + | MinusAExpr AExpr + | SymbolicBinOpAExpr AExpr SymbolicExprBinOp AExpr + | PrefixQualOpAExpr QualOp AExpr + | AndAExpr AExpr AExpr + | OrAExpr AExpr AExpr + | NotAExpr AExpr + | VerbalExprBinOpAExpr AExpr Bool VerbalExprBinOp AExpr (Maybe AExpr) + | ReversableOpAExpr AExpr Bool AExprReversableOp + | IsnullAExpr AExpr + | NotnullAExpr AExpr + | OverlapsAExpr Row Row + | SubqueryAExpr AExpr SubqueryOp SubType (Either SelectWithParens AExpr) + | UniqueAExpr SelectWithParens + | DefaultAExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AExpr where + toTextBuilder settings = \case + CExprAExpr a -> toTextBuilder settings a + TypecastAExpr a b -> renderOperand a <> " :: " <> toTextBuilder settings b + CollateAExpr a b -> renderOperand a <> " COLLATE " <> toTextBuilder settings b + AtTimeZoneAExpr a b -> renderOperand a <> " AT TIME ZONE " <> toTextBuilder settings b + PlusAExpr a -> "+ " <> toTextBuilder settings a + MinusAExpr a -> "- " <> toTextBuilder settings a + SymbolicBinOpAExpr a b c -> renderOperand a <> " " <> toTextBuilder settings b <> " " <> toTextBuilder settings c + PrefixQualOpAExpr a b -> toTextBuilder settings a <> " " <> toTextBuilder settings b + AndAExpr a b -> renderOperand a <> " AND " <> toTextBuilder settings b + OrAExpr a b -> renderOperand a <> " OR " <> toTextBuilder settings b + NotAExpr a -> "NOT " <> toTextBuilder settings a + VerbalExprBinOpAExpr a b c d e -> renderOperand a <> " " <> bool "" "NOT " b <> toTextBuilder settings c <> " " <> renderVerbalRhs e d <> foldMap (mappend " ESCAPE " . toTextBuilder settings) e + ReversableOpAExpr a b c -> renderOperand a <> " " <> renderAExprReversableOp b c + IsnullAExpr a -> renderOperand a <> " ISNULL" + NotnullAExpr a -> renderOperand a <> " NOTNULL" + OverlapsAExpr a b -> toTextBuilder settings a <> " OVERLAPS " <> toTextBuilder settings b + SubqueryAExpr a b c d -> renderOperand a <> " " <> toTextBuilder settings b <> " " <> toTextBuilder settings c <> " " <> either (toTextBuilder settings) (TextBuilders.renderInParens . toTextBuilder settings) d + UniqueAExpr a -> "UNIQUE " <> toTextBuilder settings a + DefaultAExpr -> "DEFAULT" + where + -- Renders an operand sitting in the left\/accumulator position of a + -- suffix production (the @a@ that 'customizedParser'\'s @suffixRec@ + -- threads through). Every alternative in @suffix@ parses its + -- right-hand operand via an unrestricted recursive @a_expr@ call, so + -- rendering it plainly always reconstructs the same shape on reparse. + -- The *left* position is different: control only returns to + -- @suffixRec@'s loop after a __bounded__ production — one that + -- doesn't itself end in an unrestricted recursive @a_expr@. A value + -- shaped like 'PlusAExpr'\/'MinusAExpr'\/'NotAExpr'\/ + -- 'PrefixQualOpAExpr'\/'AtTimeZoneAExpr'\/'SymbolicBinOpAExpr'\/ + -- 'AndAExpr'\/'OrAExpr'\/'VerbalExprBinOpAExpr', or a 'ReversableOpAExpr' + -- whose 'PostgresqlSyntax.Ast.AExprReversableOp' ends in one too, is + -- unbounded — placed there bare, it would greedily re-absorb whatever + -- follows on reparse (e.g. rendering @SymbolicBinOpAExpr (NotAExpr x) + -- op y@ plainly as @NOT x op y@ reparses as @NotAExpr (SymbolicBinOpAExpr + -- x op y)@). Parenthesizing it, via the existing @'(' a_expr ')'@ + -- 'PostgresqlSyntax.Ast.CExpr' production, keeps rendering correct for + -- any 'AExpr' value, whether or not the parser itself could have + -- produced it in that position. + renderOperand a + | isBoundedAExprOperand a = toTextBuilder settings a + | otherwise = TextBuilders.renderInParens (toTextBuilder settings a) + -- The @d@ operand of a @LIKE@\/@ILIKE@\/@SIMILAR TO@ production, when + -- it has a trailing @ESCAPE@ clause of its own (@e@). Since @d@ is + -- parsed via an unrestricted recursive @a_expr@, rendering it bare + -- when it's unbounded (see 'isBoundedAExprOperand') — e.g. a dangling + -- operator, or an escape-less 'VerbalExprBinOpAExpr' whose own greedy + -- @optional escape@ check would otherwise swallow the text meant for + -- \*this* production's @ESCAPE@ — reparses differently. Bounded shapes + -- (a column reference, a constant, an already-parenthesized + -- expression, DEFAULT, …) always terminate cleanly and never need the + -- extra parens, exactly like @renderOperand@'s left position. + renderVerbalRhs e d = case e of + Nothing -> toTextBuilder settings d + Just _ + | isBoundedAExprOperand d -> toTextBuilder settings d + | otherwise -> TextBuilders.renderInParens (toTextBuilder settings d) + -- Distinct from 'PostgresqlSyntax.Ast.AExprReversableOp'\'s own + -- @toTextBuilder@ (which bakes in the "positive" @IS@\/@BETWEEN@\/@IN@ + -- Parsers.keyword but not the negation) — this one threads the external + -- @Bool@ (@NOT@) in, mirroring the pre-extraction top-level + -- @aExprReversableOp@ renderer. + renderAExprReversableOp a = \case + NullAExprReversableOp -> bool "IS " "IS NOT " a <> "NULL" + TrueAExprReversableOp -> bool "IS " "IS NOT " a <> "TRUE" + FalseAExprReversableOp -> bool "IS " "IS NOT " a <> "FALSE" + UnknownAExprReversableOp -> bool "IS " "IS NOT " a <> "UNKNOWN" + DistinctFromAExprReversableOp b -> bool "IS " "IS NOT " a <> "DISTINCT FROM " <> toTextBuilder settings b + OfAExprReversableOp b -> bool "IS " "IS NOT " a <> "OF " <> TextBuilders.renderInParens (toTextBuilder settings b) + BetweenAExprReversableOp b c d -> bool "" "NOT " a <> bool "BETWEEN " "BETWEEN ASYMMETRIC " b <> toTextBuilder settings c <> " AND " <> toTextBuilder settings d + BetweenSymmetricAExprReversableOp b c -> bool "" "NOT " a <> "BETWEEN SYMMETRIC " <> toTextBuilder settings b <> " AND " <> toTextBuilder settings c + InAExprReversableOp b -> bool "" "NOT " a <> "IN " <> toTextBuilder settings b + DocumentAExprReversableOp -> bool "IS " "IS NOT " a <> "DOCUMENT" + parser settings = customizedParser settings (parser settings) + +-- | +-- Parameterized over the 'PostgresqlSyntax.Ast.CExpr' parser embedded at the +-- base case — the only axis 'filteredParser' needs to customize (via +-- 'PostgresqlSyntax.Ast.CExpr.customizedParser'). Every other occurrence of +-- @a_expr@\/@b_expr@\/@select_with_parens@ in the grammar below uses the +-- ordinary, unfiltered parsers, exactly as the pre-extraction +-- @customizedAExpr@ did (its @bExpr@\/@selectWithParens@ references were +-- never threaded through the @cExpr@ parameter either). +customizedParser :: Settings -> Parser CExpr -> Parser AExpr +customizedParser settings cExpr = suffixRec base suffix + where + aExpr = customizedParser settings cExpr + base = + asum + [ DefaultAExpr <$ Parsers.keyword "default", + UniqueAExpr <$> (Parsers.keyword "unique" *> Parsers.space1 *> parser settings), + Parsers.qualOpExpr settings aExpr PrefixQualOpAExpr, + PlusAExpr <$> Parsers.plusedExpr aExpr, + MinusAExpr <$> Parsers.minusedExpr aExpr, + NotAExpr <$> (Parsers.keyword "not" *> Parsers.space1 *> aExpr), + CExprAExpr <$> cExpr + ] + suffix a = + asum + [ overlapsSuffix settings a, + do + Parsers.space1 + b <- Parser.wrapToHead (parser settings) + Parsers.space1 + c <- Parser.wrapToHead (parser settings) + Parsers.space + d <- Left <$> Parser.wrapToHead (parser settings) <|> Right <$> Parsers.inParens aExpr + return (SubqueryAExpr a b c d), + Parsers.typecastExpr settings a TypecastAExpr, + CollateAExpr a <$> (Parsers.space1 *> Parsers.keyword "collate" *> Parsers.space1 *> Parser.endHead *> parser settings), + AtTimeZoneAExpr a <$> (Parsers.space1 *> Parsers.keyphrase "at time zone" *> Parsers.space1 *> Parser.endHead *> aExpr), + Parsers.symbolicBinOpExpr settings a aExpr SymbolicBinOpAExpr, + AndAExpr a <$> (Parsers.space1 *> Parsers.keyword "and" *> Parsers.space1 *> Parser.endHead *> aExpr), + OrAExpr a <$> (Parsers.space1 *> Parsers.keyword "or" *> Parsers.space1 *> Parser.endHead *> aExpr), + do + Parsers.space1 + b <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + c <- parser settings + Parsers.space1 + Parser.endHead + d <- aExpr + e <- optional (Parsers.space1 *> Parsers.keyword "escape" *> Parsers.space1 *> Parser.endHead *> aExpr) + return (VerbalExprBinOpAExpr a b c d e), + do + Parsers.space1 + Parsers.keyword "is" + Parsers.space1 + Parser.endHead + b <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + c <- + asum + [ NullAExprReversableOp <$ Parsers.keyword "null", + TrueAExprReversableOp <$ Parsers.keyword "true", + FalseAExprReversableOp <$ Parsers.keyword "false", + UnknownAExprReversableOp <$ Parsers.keyword "unknown", + DistinctFromAExprReversableOp <$> (Parsers.keyword "distinct" *> Parsers.space1 *> Parsers.keyword "from" *> Parsers.space1 *> Parser.endHead *> aExpr), + OfAExprReversableOp <$> (Parsers.keyword "of" *> Parsers.space1 *> Parser.endHead *> Parsers.inParens (parser settings)), + DocumentAExprReversableOp <$ Parsers.keyword "document" + ] + return (ReversableOpAExpr a b c), + do + Parsers.space1 + b <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + Parsers.keyword "between" + Parsers.space1 + Parser.endHead + c <- + asum + [ BetweenSymmetricAExprReversableOp <$ (Parsers.keyword "symmetric" *> Parsers.space1), + BetweenAExprReversableOp True <$ (Parsers.keyword "asymmetric" *> Parsers.space1), + pure (BetweenAExprReversableOp False) + ] + d <- parser settings + Parsers.space1 + Parsers.keyword "and" + Parsers.space1 + e <- aExpr + return (ReversableOpAExpr a b (c d e)), + do + Parsers.space1 + b <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + Parsers.keyword "in" + Parsers.space + c <- InAExprReversableOp <$> parser settings + return (ReversableOpAExpr a b c), + IsnullAExpr a <$ (Parsers.space1 *> Parsers.keyword "isnull"), + NotnullAExpr a <$ (Parsers.space1 *> Parsers.keyword "notnull") + ] + +-- | +-- The @OVERLAPS@ operator, as a suffix of an already parsed left operand. +-- Reinterprets the already-parsed base 'AExpr' as a 'Row' rather than +-- speculatively parsing a @row@ on top of it — see the original +-- @overlapsSuffix@ in the pre-extraction @PostgresqlSyntax.Parsing@ for the +-- exponential-blowup rationale this avoids. +overlapsSuffix :: Settings -> AExpr -> Parser AExpr +overlapsSuffix settings a = do + b <- maybe empty pure (aExprRow a) + Parsers.space1 + Parsers.keyword "overlaps" + Parser.endHead + Parsers.space1 + c <- parser settings + return (OverlapsAExpr b c) + where + aExprRow = \case + CExprAExpr (CExpr.ExplicitRowCExpr x) -> Just (ExplicitRowRow x) + CExprAExpr (CExpr.ImplicitRowCExpr x) -> Just (ImplicitRowRow x) + _ -> Nothing + +-- | +-- Whether the given 'AExpr' is safe to place in the left\/accumulator +-- position of a suffix production without parenthesizing it — see +-- @renderOperand@ in the 'IsAst' instance above for why that position is +-- special. A shape is bounded when parsing it can never end in an +-- unrestricted recursive @a_expr@ call, i.e. control is guaranteed to +-- return to @suffixRec@'s loop once it's done. +-- +-- Note this predicate is purely about operator precedence and +-- associativity: an unbounded shape is one whose own rendering ends in an +-- unrestricted recursive @a_expr@, so placed bare in the left position it +-- would re-absorb the suffix that follows (e.g. rendering +-- @SymbolicBinOpAExpr (NotAExpr x) op y@ plainly as @NOT x op y@ reparses +-- as @NotAExpr (SymbolicBinOpAExpr x op y)@). It is /not/ a general +-- terminator-keyword guard — it isn't a general-purpose mechanism against +-- an expression swallowing a keyword that terminates an enclosing +-- production; the only shape that ever created that hazard by construction +-- was the postfix @a_expr qual_Op@ production, which no longer exists here +-- or in @references/gram.y@ (see gram.y:15985,15987; Postgres removed +-- postfix operators in v14). It does incidentally get reused for that +-- purpose in "PostgresqlSyntax.Ast.TargetEl" (to stop an @OrAExpr@'s right +-- operand from absorbing a following implicit alias) — that's just one +-- call site's use of it, not evidence of general applicability. +isBoundedAExprOperand :: AExpr -> Bool +isBoundedAExprOperand = \case + PlusAExpr {} -> False + MinusAExpr {} -> False + NotAExpr {} -> False + PrefixQualOpAExpr {} -> False + AtTimeZoneAExpr {} -> False + SymbolicBinOpAExpr {} -> False + AndAExpr {} -> False + OrAExpr {} -> False + VerbalExprBinOpAExpr {} -> False + ReversableOpAExpr _ _ c -> case c of + DistinctFromAExprReversableOp {} -> False + BetweenAExprReversableOp {} -> False + BetweenSymmetricAExprReversableOp {} -> False + _ -> True + _ -> True + +-- | +-- A generator for the left\/accumulator position of a suffix production +-- (see 'isBoundedAExprOperand'): whatever the given generator produces gets +-- wrapped in an explicit @'(' a_expr ')'@ (via 'CExpr.InParensCExpr') when +-- it wouldn't otherwise be reachable there, so the result always round-trips +-- through 'parser'. +safeAExprOperand :: Qc.Gen AExpr -> Qc.Gen AExpr +safeAExprOperand gen = do + a <- gen + pure $ + if isBoundedAExprOperand a + then a + else CExprAExpr (CExpr.InParensCExpr a Nothing) + +instance Refines SelectWithParens AExpr where + embed a = CExprAExpr (CExpr.SelectWithParensCExpr a Nothing) + project = \case + CExprAExpr (CExpr.SelectWithParensCExpr a Nothing) -> Just a + _ -> Nothing + +-- | +-- Collapses the non-canonical @Right@-wrapping-a-bare-@select_with_parens@ +-- shape of 'SubqueryAExpr'\'s final field to the @Left@ shape the parser +-- actually produces for it. +-- +-- @a_expr subquery_Op sub_type select_with_parens@ (i.e. @Left@) and +-- @a_expr subquery_Op sub_type '(' a_expr ')'@ (i.e. @Right@) overlap +-- whenever the parenthesized @a_expr@ is itself nothing but a bare, +-- indirection-less @select_with_parens@: both parse @x = ANY ((select 1))@. +-- @suffix@ tries the @select_with_parens@ alternative before the +-- parenthesized @a_expr@ one (see the @d <- Left <$> ... <|> Right <$> ...@ +-- line above), so that's always what the parser returns — never @Right@ — +-- making the latter non-canonical for this shape. Both 'arbitrary' and +-- 'shrink' can otherwise construct it, which renders fine but parses back to +-- a different, canonical value and so breaks the roundtrip property. +instance Canonicalizes AExpr where + canonicalize = \case + SubqueryAExpr a b c (Right d) + | Just inner <- project d -> SubqueryAExpr a b c (Left inner) + other -> other + +instance Qc.Arbitrary AExpr where + shrink = fmap canonicalize . Qc.genericShrink + arbitrary = + fmap canonicalize $ Qc.sized $ \n -> + if n <= 1 + then pure DefaultAExpr + else + Qc.oneof + [ CExprAExpr <$> Qc.arbitrary, + pure DefaultAExpr, + TypecastAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary, + CollateAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary, + AtTimeZoneAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Gens.downscale Qc.arbitrary, + PlusAExpr <$> Gens.downscale Qc.arbitrary, + MinusAExpr <$> Gens.downscale Qc.arbitrary, + SymbolicBinOpAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + PrefixQualOpAExpr <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + AndAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Gens.downscale Qc.arbitrary, + OrAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Gens.downscale Qc.arbitrary, + NotAExpr <$> Gens.downscale Qc.arbitrary, + ( do + a <- safeAExprOperand (Gens.downscale Qc.arbitrary) + b <- Qc.arbitrary + c <- Qc.arbitrary + e <- Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) + -- See @renderVerbalRhs@ in the 'IsAst' instance above: + -- whenever there's an escape clause, an unbounded @d@ must + -- be pre-wrapped in parens so the generated value already + -- matches what parsing the (necessarily parenthesized) + -- rendering reconstructs — the same rule 'safeAExprOperand' + -- applies for the left/accumulator position. + d <- case e of + Nothing -> Gens.downscale Qc.arbitrary + Just _ -> safeAExprOperand (Gens.downscale Qc.arbitrary) + pure (VerbalExprBinOpAExpr a b c d e) + ), + ReversableOpAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary <*> Qc.arbitrary, + IsnullAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary), + NotnullAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary), + OverlapsAExpr <$> Qc.arbitrary <*> Qc.arbitrary, + SubqueryAExpr <$> safeAExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + UniqueAExpr <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/AExpr.hs-boot b/library-internal/PostgresqlSyntax/Ast/AExpr.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AExpr.hs-boot @@ -0,0 +1,22 @@ +module PostgresqlSyntax.Ast.AExpr where + +import PostgresqlSyntax.Algebra (IsAst, Refines) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import Test.QuickCheck (Arbitrary) + +data AExpr + +instance Show AExpr + +instance Eq AExpr + +instance Ord AExpr + +instance Data AExpr + +instance IsAst AExpr + +instance Arbitrary AExpr + +instance Refines SelectWithParens AExpr diff --git a/library-internal/PostgresqlSyntax/Ast/AExprReversableOp.hs b/library-internal/PostgresqlSyntax/Ast/AExprReversableOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AExprReversableOp.hs @@ -0,0 +1,113 @@ +module PostgresqlSyntax.Ast.AExprReversableOp where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import {-# SOURCE #-} PostgresqlSyntax.Ast.BExpr (BExpr) +import PostgresqlSyntax.Ast.InExpr +import PostgresqlSyntax.Ast.TypeList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- The part of the following productions that follows @a_expr [NOT]@ / +-- @b_expr [NOT]@ — the leading @IS@\/@NOT@ toggle itself is external to this +-- type (it lives alongside it, e.g. in @ReversableOpAExpr AExpr Bool +-- AExprReversableOp@), mirroring how 'PostgresqlSyntax.Ast.VerbalExprBinOp' +-- keeps @NOT_LA@ external. Only the @IS@\/@BETWEEN@\/@IN@ Parsers.keyword that's +-- intrinsic to each specific alternative (as opposed to the shared negation) +-- is captured here. +-- +-- ==== References +-- @ +-- | a_expr IS NULL_P +-- | a_expr IS TRUE_P +-- | a_expr IS FALSE_P +-- | a_expr IS UNKNOWN +-- | a_expr IS DISTINCT FROM a_expr +-- | a_expr IS OF '(' type_list ')' +-- | a_expr BETWEEN opt_asymmetric b_expr AND a_expr +-- | a_expr BETWEEN SYMMETRIC b_expr AND a_expr +-- | a_expr IN_P in_expr +-- | a_expr IS DOCUMENT_P +-- @ +data AExprReversableOp + = NullAExprReversableOp + | TrueAExprReversableOp + | FalseAExprReversableOp + | UnknownAExprReversableOp + | DistinctFromAExprReversableOp AExpr + | OfAExprReversableOp TypeList + | BetweenAExprReversableOp Bool BExpr AExpr + | BetweenSymmetricAExprReversableOp BExpr AExpr + | InAExprReversableOp InExpr + | DocumentAExprReversableOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AExprReversableOp where + toTextBuilder settings = \case + NullAExprReversableOp -> "IS NULL" + TrueAExprReversableOp -> "IS TRUE" + FalseAExprReversableOp -> "IS FALSE" + UnknownAExprReversableOp -> "IS UNKNOWN" + DistinctFromAExprReversableOp b -> "IS DISTINCT FROM " <> toTextBuilder settings b + OfAExprReversableOp b -> "IS OF " <> TextBuilders.renderInParens (toTextBuilder settings b) + BetweenAExprReversableOp b c d -> bool "BETWEEN " "BETWEEN ASYMMETRIC " b <> toTextBuilder settings c <> " AND " <> toTextBuilder settings d + BetweenSymmetricAExprReversableOp b c -> "BETWEEN SYMMETRIC " <> toTextBuilder settings b <> " AND " <> toTextBuilder settings c + InAExprReversableOp b -> "IN " <> toTextBuilder settings b + DocumentAExprReversableOp -> "IS DOCUMENT" + parser settings = + asum + [ Parsers.keyword "is" + *> Parsers.space1 + *> Parser.endHead + *> asum + [ NullAExprReversableOp <$ Parsers.keyword "null", + TrueAExprReversableOp <$ Parsers.keyword "true", + FalseAExprReversableOp <$ Parsers.keyword "false", + UnknownAExprReversableOp <$ Parsers.keyword "unknown", + DistinctFromAExprReversableOp <$> (Parsers.keyword "distinct" *> Parsers.space1 *> Parsers.keyword "from" *> Parsers.space1 *> Parser.endHead *> parser settings), + OfAExprReversableOp <$> (Parsers.keyword "of" *> Parsers.space1 *> Parser.endHead *> Parsers.inParens (parser settings)), + DocumentAExprReversableOp <$ Parsers.keyword "document" + ], + do + Parsers.keyword "between" + Parsers.space1 + Parser.endHead + c <- + asum + [ BetweenSymmetricAExprReversableOp <$ (Parsers.keyword "symmetric" *> Parsers.space1), + BetweenAExprReversableOp True <$ (Parsers.keyword "asymmetric" *> Parsers.space1), + pure (BetweenAExprReversableOp False) + ] + d <- parser settings + Parsers.space1 + Parsers.keyword "and" + Parsers.space1 + e <- parser settings + return (c d e), + InAExprReversableOp <$> (Parsers.keyword "in" *> Parsers.space *> parser settings) + ] + +instance Qc.Arbitrary AExprReversableOp where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then Qc.oneof [pure NullAExprReversableOp, pure TrueAExprReversableOp, pure FalseAExprReversableOp, pure UnknownAExprReversableOp, pure DocumentAExprReversableOp] + else + Qc.oneof + [ pure NullAExprReversableOp, + pure TrueAExprReversableOp, + pure FalseAExprReversableOp, + pure UnknownAExprReversableOp, + DistinctFromAExprReversableOp <$> Gens.downscale Qc.arbitrary, + OfAExprReversableOp <$> Gens.downscale Qc.arbitrary, + BetweenAExprReversableOp <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + BetweenSymmetricAExprReversableOp <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + InAExprReversableOp <$> Gens.downscale Qc.arbitrary, + pure DocumentAExprReversableOp + ] diff --git a/library-internal/PostgresqlSyntax/Ast/AexprConst.hs b/library-internal/PostgresqlSyntax/Ast/AexprConst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AexprConst.hs @@ -0,0 +1,126 @@ +module PostgresqlSyntax.Ast.AexprConst where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Bconst +import PostgresqlSyntax.Ast.ConstTypename +import PostgresqlSyntax.Ast.Fconst +import PostgresqlSyntax.Ast.FuncConstArgs +import PostgresqlSyntax.Ast.FuncName +import PostgresqlSyntax.Ast.Iconst +import PostgresqlSyntax.Ast.Interval +import PostgresqlSyntax.Ast.Sconst +import PostgresqlSyntax.Ast.Xconst +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc +import qualified Text.Megaparsec as Megaparsec +import qualified Text.Megaparsec.Char as MegaparsecChar + +-- | +-- ==== References +-- @ +-- AexprConst: +-- | Iconst +-- | FCONST +-- | Sconst +-- | BCONST +-- | XCONST +-- | func_name Sconst +-- | func_name '(' func_arg_list opt_sort_clause ')' Sconst +-- | ConstTypename Sconst +-- | ConstInterval Sconst opt_interval +-- | ConstInterval '(' Iconst ')' Sconst +-- | TRUE_P +-- | FALSE_P +-- | NULL_P +-- @ +data AexprConst + = IAexprConst Iconst + | FAexprConst Fconst + | SAexprConst Sconst + | BAexprConst Bconst + | XAexprConst Xconst + | FuncAexprConst FuncName (Maybe FuncConstArgs) Sconst + | ConstTypenameAexprConst ConstTypename Sconst + | StringIntervalAexprConst Sconst (Maybe Interval) + | IntIntervalAexprConst Iconst Sconst + | BoolAexprConst Bool + | NullAexprConst + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AexprConst where + toTextBuilder settings = \case + IAexprConst a -> toTextBuilder settings a + FAexprConst a -> toTextBuilder settings a + SAexprConst a -> toTextBuilder settings a + BAexprConst a -> toTextBuilder settings a + XAexprConst a -> toTextBuilder settings a + FuncAexprConst a b c -> toTextBuilder settings a <> foldMap (TextBuilders.renderInParens . toTextBuilder settings) b <> " " <> toTextBuilder settings c + ConstTypenameAexprConst a b -> toTextBuilder settings a <> " " <> toTextBuilder settings b + StringIntervalAexprConst a b -> "INTERVAL " <> toTextBuilder settings a <> TextBuilders.suffixMaybe (toTextBuilder settings) b + IntIntervalAexprConst a b -> "INTERVAL " <> TextBuilders.renderInParens (toTextBuilder settings a) <> " " <> toTextBuilder settings b + BoolAexprConst a -> if a then "TRUE" else "FALSE" + NullAexprConst -> "NULL" + parser settings = + asum + [ do + Parsers.keyword "interval" + Parsers.space1 + Parser.endHead + a <- + asum + [ do + a <- parser settings + Parser.endHead + b <- optional (Parsers.space1 *> parser settings) + return (StringIntervalAexprConst a b), + do + a <- Parsers.inParens (parser settings) + Parsers.space1 + Parser.endHead + b <- parser settings + return (IntIntervalAexprConst a b) + ] + return a, + do + a <- parser settings + Parsers.space1 + Parser.endHead + b <- parser settings + return (ConstTypenameAexprConst a b), + BoolAexprConst True <$ Parsers.keyword "true", + BoolAexprConst False <$ Parsers.keyword "false", + NullAexprConst <$ Parsers.keyword "null" <* Parser.parse (Megaparsec.notFollowedBy MegaparsecChar.alphaNumChar), + either IAexprConst FAexprConst <$> (Right <$> parser settings <|> Left <$> parser settings), + SAexprConst <$> parser settings, + BAexprConst <$> parser settings, + XAexprConst <$> parser settings, + Parser.wrapToHead $ do + a <- parser settings + Parsers.space + b <- Parsers.inParens (parser settings) + Parsers.space1 + d <- parser settings + return (FuncAexprConst a (Just b) d), + FuncAexprConst <$> (Parser.wrapToHead (parser settings) <* Parsers.space1) <*> pure Nothing <*> parser settings + ] + +instance Qc.Arbitrary AexprConst where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ IAexprConst <$> Qc.arbitrary, + FAexprConst <$> Qc.arbitrary, + SAexprConst <$> Qc.arbitrary, + BAexprConst <$> Qc.arbitrary, + XAexprConst <$> Qc.arbitrary, + FuncAexprConst <$> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary <*> Qc.arbitrary, + ConstTypenameAexprConst <$> Qc.arbitrary <*> Qc.arbitrary, + StringIntervalAexprConst <$> Qc.arbitrary <*> Qc.arbitrary, + IntIntervalAexprConst <$> Qc.arbitrary <*> Qc.arbitrary, + BoolAexprConst <$> Qc.arbitrary, + pure NullAexprConst + ] diff --git a/library-internal/PostgresqlSyntax/Ast/AliasClause.hs b/library-internal/PostgresqlSyntax/Ast/AliasClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AliasClause.hs @@ -0,0 +1,51 @@ +module PostgresqlSyntax.Ast.AliasClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.NameList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- alias_clause: +-- | AS ColId '(' name_list ')' +-- | AS ColId +-- | ColId '(' name_list ')' +-- | ColId +-- @ +-- +-- 'PostgresqlSyntax.Ast.ColId' is a bare alias to 'Ident', but its /parser/ +-- (kept in "PostgresqlSyntax.Parsing" since @ColId@ itself isn't extracted +-- in this batch) is more permissive than plain 'Ident'. Since this module +-- sits below "PostgresqlSyntax.Parsing" (no import cycle allowed), that +-- ColId-flavored element parser is duplicated here (mirroring @colId@'s +-- definition), same as 'PostgresqlSyntax.Ast.NameList'. +data AliasClause = AliasClause Bool Ident (Maybe NameList) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AliasClause where + toTextBuilder settings (AliasClause a b c) = + TextBuilders.optLexemes + [ if a then Just "AS" else Nothing, + Just (toTextBuilder settings b), + fmap (TextBuilders.renderInParens . toTextBuilder settings) c + ] + parser settings = do + (as, alias) <- (True,) <$> (Parsers.keyword "as" *> Parsers.space1 *> Parser.endHead *> colIdLikeName) <|> (False,) <$> colIdLikeName + columnAliases <- optional (Parsers.space1 *> Parsers.inParens (parser settings)) + return (AliasClause as alias columnAliases) + where + colIdLikeName = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + +instance Qc.Arbitrary AliasClause where + shrink = Qc.genericShrink + arbitrary = AliasClause <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/AllOp.hs b/library-internal/PostgresqlSyntax/Ast/AllOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AllOp.hs @@ -0,0 +1,37 @@ +module PostgresqlSyntax.Ast.AllOp where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.MathOp +import PostgresqlSyntax.Ast.Op +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- all_Op: +-- | Op +-- | MathOp +-- @ +data AllOp + = OpAllOp Op + | MathAllOp MathOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AllOp where + toTextBuilder settings = \case + OpAllOp a -> toTextBuilder settings a + MathAllOp a -> toTextBuilder settings a + parser settings = + asum + [ OpAllOp <$> parser settings, + MathAllOp <$> parser settings + ] + +instance Qc.Arbitrary AllOp where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ OpAllOp <$> Qc.arbitrary, + MathAllOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/AnyName.hs b/library-internal/PostgresqlSyntax/Ast/AnyName.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AnyName.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.AnyName where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Attrs +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- any_name: +-- | ColId +-- | ColId attrs +-- @ +-- +-- 'PostgresqlSyntax.Ast.ColId' is a bare alias to 'Ident', but its /parser/ +-- (kept in "PostgresqlSyntax.Parsing" since @ColId@ itself isn't extracted +-- in this batch) is more permissive than plain 'Ident'. Since this module +-- sits below "PostgresqlSyntax.Parsing" (no import cycle allowed), that +-- ColId-flavored element parser is duplicated here (mirroring @colId@'s +-- definition), same as 'PostgresqlSyntax.Ast.NameList'. (This is also +-- exactly what "PostgresqlSyntax.Parsing"'s @customizedAnyName@ does with +-- its @colId@ argument; that generic helper stays in "PostgresqlSyntax.Parsing" +-- since its other caller, @filteredAnyName@, passes a filtered variant.) +data AnyName = AnyName Ident (Maybe Attrs) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AnyName where + toTextBuilder settings (AnyName a b) = toTextBuilder settings a <> foldMap (toTextBuilder settings) b + parser settings = AnyName <$> (Parser.wrapToHead colIdLikeName <* Parser.endHead) <*> optional (Parsers.space *> parser settings) + where + colIdLikeName = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + +instance Qc.Arbitrary AnyName where + shrink = Qc.genericShrink + arbitrary = AnyName <$> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/AnyOperator.hs b/library-internal/PostgresqlSyntax/Ast/AnyOperator.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AnyOperator.hs @@ -0,0 +1,56 @@ +module PostgresqlSyntax.Ast.AnyOperator where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AllOp +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- any_operator: +-- | all_Op +-- | ColId '.' any_operator +-- @ +-- +-- 'PostgresqlSyntax.Ast.ColId' is a bare alias to 'Ident', but its /parser/ +-- (kept in "PostgresqlSyntax.Parsing" since @ColId@ itself isn't extracted +-- in this batch) is more permissive than plain 'Ident'. Since this module +-- sits below "PostgresqlSyntax.Parsing" (no import cycle allowed), that +-- ColId-flavored element parser is duplicated here (mirroring @colId@'s +-- definition), same as 'PostgresqlSyntax.Ast.NameList'. +data AnyOperator + = AllOpAnyOperator AllOp + | QualifiedAnyOperator Ident AnyOperator + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst AnyOperator where + toTextBuilder settings = \case + AllOpAnyOperator a -> toTextBuilder settings a + QualifiedAnyOperator a b -> toTextBuilder settings a <> "." <> toTextBuilder settings b + parser settings = + asum + [ AllOpAnyOperator <$> parser settings, + QualifiedAnyOperator <$> colIdLikeName <*> (Parsers.space *> Parsers.char '.' *> Parsers.space *> parser settings) + ] + where + colIdLikeName = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + +instance Qc.Arbitrary AnyOperator where + shrink = Qc.genericShrink + arbitrary = Qc.sized $ \n -> + if n <= 1 + then AllOpAnyOperator <$> Qc.arbitrary + else + Qc.oneof + [ AllOpAnyOperator <$> Qc.arbitrary, + QualifiedAnyOperator <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ArrayBounds.hs b/library-internal/PostgresqlSyntax/Ast/ArrayBounds.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ArrayBounds.hs @@ -0,0 +1,28 @@ +module PostgresqlSyntax.Ast.ArrayBounds where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Iconst +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_array_bounds: +-- | opt_array_bounds '[' Iconst ']' +-- | opt_array_bounds '[' ']' +-- | EMPTY +-- @ +newtype ArrayBounds = ArrayBounds (NonEmpty (Maybe Iconst)) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ArrayBounds where + toTextBuilder settings (ArrayBounds a) = TextBuilders.spaceNonEmpty (TextBuilders.renderInBrackets . foldMap (toTextBuilder settings)) a + parser settings = ArrayBounds <$> Parsers.sep1 Parsers.space (Parsers.inBrackets (optional (parser settings))) + +instance Qc.Arbitrary ArrayBounds where + shrink = Qc.genericShrink + arbitrary = ArrayBounds <$> Gens.nonEmptyUpTo 3 (Qc.oneof [pure Nothing, Just <$> Qc.arbitrary]) diff --git a/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs b/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs @@ -0,0 +1,50 @@ +module PostgresqlSyntax.Ast.ArrayExpr where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ArrayExprList +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- array_expr: +-- | '[' expr_list ']' +-- | '[' array_expr_list ']' +-- | '[' ']' +-- @ +data ArrayExpr + = ExprListArrayExpr ExprList + | ArrayExprListArrayExpr ArrayExprList + | EmptyArrayExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ArrayExpr where + toTextBuilder settings = + TextBuilders.renderInBrackets . \case + ExprListArrayExpr a -> toTextBuilder settings a + ArrayExprListArrayExpr a -> toTextBuilder settings a + EmptyArrayExpr -> mempty + parser settings = + Parsers.inBrackets $ + asum + [ ArrayExprListArrayExpr <$> parser settings, + ExprListArrayExpr <$> parser settings, + pure EmptyArrayExpr + ] + +instance Qc.Arbitrary ArrayExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then pure EmptyArrayExpr + else + Qc.oneof + [ ExprListArrayExpr <$> Qc.arbitrary, + ArrayExprListArrayExpr <$> Qc.arbitrary, + pure EmptyArrayExpr + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs-boot b/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ArrayExpr.hs-boot @@ -0,0 +1,19 @@ +module PostgresqlSyntax.Ast.ArrayExpr where + +import PostgresqlSyntax.Algebra (IsAst) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data ArrayExpr + +instance Show ArrayExpr + +instance Eq ArrayExpr + +instance Ord ArrayExpr + +instance Data ArrayExpr + +instance IsAst ArrayExpr + +instance Arbitrary ArrayExpr diff --git a/library-internal/PostgresqlSyntax/Ast/ArrayExprList.hs b/library-internal/PostgresqlSyntax/Ast/ArrayExprList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ArrayExprList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.ArrayExprList where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.ArrayExpr (ArrayExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- array_expr_list: +-- | array_expr +-- | array_expr_list ',' array_expr +-- @ +newtype ArrayExprList = ArrayExprList (NonEmpty ArrayExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ArrayExprList where + toTextBuilder settings (ArrayExprList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = ArrayExprList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary ArrayExprList where + shrink = Qc.genericShrink + arbitrary = ArrayExprList <$> Gens.nonEmptyUpTo 100 (Gens.downscale Qc.arbitrary) diff --git a/library-internal/PostgresqlSyntax/Ast/AscDesc.hs b/library-internal/PostgresqlSyntax/Ast/AscDesc.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/AscDesc.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.AscDesc where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_asc_desc: +-- | ASC +-- | DESC +-- | EMPTY +-- @ +data AscDesc = AscAscDesc | DescAscDesc + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst AscDesc where + toTextBuilder _settings = \case + AscAscDesc -> "ASC" + DescAscDesc -> "DESC" + parser _settings = Parsers.keyword "asc" $> AscAscDesc <|> Parsers.keyword "desc" $> DescAscDesc + +instance Qc.Arbitrary AscDesc where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/Attrs.hs b/library-internal/PostgresqlSyntax/Ast/Attrs.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Attrs.hs @@ -0,0 +1,45 @@ +module PostgresqlSyntax.Ast.Attrs where + +import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- attrs: +-- | '.' attr_name +-- | attrs '.' attr_name +-- @ +-- +-- 'PostgresqlSyntax.Ast.AttrName' is a bare alias to +-- 'PostgresqlSyntax.Ast.ColLabel' which is a bare alias to 'Ident', but the +-- @ColLabel@ /parser/ (kept in "PostgresqlSyntax.Parsing" since @ColLabel@ +-- itself isn't extracted in this batch) is more permissive than plain +-- 'Ident': it additionally accepts the full @keyword@ lexical class as an +-- identifier. Since this module sits below "PostgresqlSyntax.Parsing" (no +-- import cycle allowed), that ColLabel-flavored element parser is +-- duplicated here (mirroring @colLabel@'s definition) rather than reused, +-- to preserve exact parsing behavior. (See 'PostgresqlSyntax.Ast.NameList' +-- for the same pattern applied to @ColId@.) +newtype Attrs = Attrs (NonEmpty Ident) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Attrs where + toTextBuilder settings (Attrs a) = foldMap (mappend "." . toTextBuilder settings) a + parser settings = Attrs <$> NonEmpty.some (Parsers.char '.' *> Parser.endHead *> Parsers.space *> colLabelLikeName) + where + colLabelLikeName = + Parser.label "column label" $ + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.keyword + <|> parser settings + +instance Qc.Arbitrary Attrs where + shrink = Qc.genericShrink + arbitrary = Attrs <$> Gens.nonEmptyUpTo 9 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/BExpr.hs b/library-internal/PostgresqlSyntax/Ast/BExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/BExpr.hs @@ -0,0 +1,161 @@ +module PostgresqlSyntax.Ast.BExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.BExprIsOp +import PostgresqlSyntax.Ast.CExpr (CExpr) +import PostgresqlSyntax.Ast.QualOp +import PostgresqlSyntax.Ast.SymbolicExprBinOp +import PostgresqlSyntax.Ast.Typename +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- b_expr: +-- | c_expr +-- | b_expr TYPECAST Typename +-- | '+' b_expr +-- | '-' b_expr +-- | b_expr '+' b_expr +-- | b_expr '-' b_expr +-- | b_expr '*' b_expr +-- | b_expr '/' b_expr +-- | b_expr '%' b_expr +-- | b_expr '^' b_expr +-- | b_expr '<' b_expr +-- | b_expr '>' b_expr +-- | b_expr '=' b_expr +-- | b_expr LESS_EQUALS b_expr +-- | b_expr GREATER_EQUALS b_expr +-- | b_expr NOT_EQUALS b_expr +-- | b_expr qual_Op b_expr +-- | qual_Op b_expr +-- | b_expr IS DISTINCT FROM b_expr +-- | b_expr IS NOT DISTINCT FROM b_expr +-- | b_expr IS OF '(' type_list ')' +-- | b_expr IS NOT OF '(' type_list ')' +-- | b_expr IS DOCUMENT_P +-- | b_expr IS NOT DOCUMENT_P +-- @ +-- +-- Unlike 'PostgresqlSyntax.Ast.AExpr', nothing customizes this parser's +-- @c_expr@\/identifier axis externally, so — despite also being a +-- recursion hub — it needs no @customizedParser@\/@filteredParser@ export. +data BExpr + = CExprBExpr CExpr + | TypecastBExpr BExpr Typename + | PlusBExpr BExpr + | MinusBExpr BExpr + | SymbolicBinOpBExpr BExpr SymbolicExprBinOp BExpr + | QualOpBExpr QualOp BExpr + | IsOpBExpr BExpr Bool BExprIsOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst BExpr where + toTextBuilder settings = \case + CExprBExpr a -> toTextBuilder settings a + TypecastBExpr a b -> renderOperand a <> " :: " <> toTextBuilder settings b + PlusBExpr a -> "+ " <> toTextBuilder settings a + MinusBExpr a -> "- " <> toTextBuilder settings a + SymbolicBinOpBExpr a b c -> renderOperand a <> " " <> toTextBuilder settings b <> " " <> toTextBuilder settings c + QualOpBExpr a b -> toTextBuilder settings a <> " " <> toTextBuilder settings b + IsOpBExpr a b c -> renderOperand a <> " " <> renderBExprIsOp b c + where + -- See 'PostgresqlSyntax.Ast.AExpr'\'s @renderOperand@ for the + -- rationale — same left\/accumulator-position hazard, mirrored here + -- for 'BExpr'\'s own (smaller) suffix grammar. Unlike 'AExpr', there's + -- no @'(' b_expr ')'@ production to fall back on, so parenthesizing + -- reinterprets the operand as an @a_expr@ via + -- 'PostgresqlSyntax.Ast.CExpr'\'s @'(' a_expr ')'@ instead — still + -- valid, semantically-equivalent SQL, just not the same 'BExpr' shape + -- on reparse (only relevant to hand-constructed values; the + -- 'Qc.Arbitrary' instance below never generates an operand needing + -- this fallback). + renderOperand a + | isBoundedBExprOperand a = toTextBuilder settings a + | otherwise = TextBuilders.renderInParens (toTextBuilder settings a) + renderBExprIsOp a = + mappend (bool "IS " "IS NOT " a) . \case + DistinctFromBExprIsOp b -> "DISTINCT FROM " <> toTextBuilder settings b + OfBExprIsOp b -> "OF " <> TextBuilders.renderInParens (toTextBuilder settings b) + DocumentBExprIsOp -> "DOCUMENT" + parser settings = suffixRec base suffix + where + bExpr = suffixRec base suffix + base = + asum + [ Parsers.qualOpExpr settings bExpr QualOpBExpr, + PlusBExpr <$> Parsers.plusedExpr bExpr, + MinusBExpr <$> Parsers.minusedExpr bExpr, + CExprBExpr <$> parser settings + ] + suffix a = + asum + [ Parsers.typecastExpr settings a TypecastBExpr, + Parsers.symbolicBinOpExpr settings a bExpr SymbolicBinOpBExpr, + do + Parsers.space1 + Parsers.keyword "is" + Parsers.space1 + Parser.endHead + b <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + c <- + asum + [ DistinctFromBExprIsOp <$> (Parsers.keyphrase "distinct from" *> Parsers.space1 *> Parser.endHead *> bExpr), + OfBExprIsOp <$> (Parsers.keyword "of" *> Parsers.space1 *> Parser.endHead *> Parsers.inParens (parser settings)), + DocumentBExprIsOp <$ Parsers.keyword "document" + ] + return (IsOpBExpr a b c) + ] + +-- | +-- Whether the given 'BExpr' is safe to place in the left\/accumulator +-- position of a suffix production without parenthesizing it — see +-- 'IsAst' 'BExpr'\'s @renderOperand@. Mirrors +-- 'PostgresqlSyntax.Ast.AExpr.isBoundedAExprOperand'. +isBoundedBExprOperand :: BExpr -> Bool +isBoundedBExprOperand = \case + PlusBExpr {} -> False + MinusBExpr {} -> False + QualOpBExpr {} -> False + SymbolicBinOpBExpr {} -> False + IsOpBExpr _ _ c -> case c of + DistinctFromBExprIsOp {} -> False + _ -> True + _ -> True + +-- | +-- A generator for the left\/accumulator position of a suffix production +-- (see 'isBoundedBExprOperand'). Unlike +-- 'PostgresqlSyntax.Ast.AExpr.safeAExprOperand', 'BExpr' has no +-- parenthesizing escape hatch of its own (see @renderOperand@ above), so an +-- unbounded draw is simply replaced by an always-bounded 'CExprBExpr' +-- instead of wrapped. +safeBExprOperand :: Qc.Gen BExpr -> Qc.Gen BExpr +safeBExprOperand gen = do + a <- gen + if isBoundedBExprOperand a + then pure a + else CExprBExpr <$> Qc.arbitrary + +instance Qc.Arbitrary BExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then CExprBExpr <$> Qc.arbitrary + else + Qc.oneof + [ CExprBExpr <$> Qc.arbitrary, + TypecastBExpr <$> safeBExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary, + PlusBExpr <$> Gens.downscale Qc.arbitrary, + MinusBExpr <$> Gens.downscale Qc.arbitrary, + SymbolicBinOpBExpr <$> safeBExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + QualOpBExpr <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + IsOpBExpr <$> safeBExprOperand (Gens.downscale Qc.arbitrary) <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/BExpr.hs-boot b/library-internal/PostgresqlSyntax/Ast/BExpr.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/BExpr.hs-boot @@ -0,0 +1,19 @@ +module PostgresqlSyntax.Ast.BExpr where + +import PostgresqlSyntax.Algebra (IsAst) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data BExpr + +instance Show BExpr + +instance Eq BExpr + +instance Ord BExpr + +instance Data BExpr + +instance IsAst BExpr + +instance Arbitrary BExpr diff --git a/library-internal/PostgresqlSyntax/Ast/BExprIsOp.hs b/library-internal/PostgresqlSyntax/Ast/BExprIsOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/BExprIsOp.hs @@ -0,0 +1,55 @@ +module PostgresqlSyntax.Ast.BExprIsOp where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.BExpr (BExpr) +import PostgresqlSyntax.Ast.TypeList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- Renders\/parses only the \"positive\" form (@DISTINCT FROM ...@\/@OF +-- (...)@\/@DOCUMENT@), mirroring 'PostgresqlSyntax.Ast.AExprReversableOp': +-- the external @IS@\/@IS NOT@ toggle lives alongside this type in +-- 'PostgresqlSyntax.Ast.BExpr'\'s own @IsOpBExpr BExpr Bool BExprIsOp@ +-- constructor and is rendered\/parsed there, not here. +-- +-- ==== References +-- @ +-- | b_expr IS DISTINCT FROM b_expr +-- | b_expr IS NOT DISTINCT FROM b_expr +-- | b_expr IS OF '(' type_list ')' +-- | b_expr IS NOT OF '(' type_list ')' +-- | b_expr IS DOCUMENT_P +-- | b_expr IS NOT DOCUMENT_P +-- @ +data BExprIsOp + = DistinctFromBExprIsOp BExpr + | OfBExprIsOp TypeList + | DocumentBExprIsOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst BExprIsOp where + toTextBuilder settings = \case + DistinctFromBExprIsOp b -> "DISTINCT FROM " <> toTextBuilder settings b + OfBExprIsOp b -> "OF " <> TextBuilders.renderInParens (toTextBuilder settings b) + DocumentBExprIsOp -> "DOCUMENT" + parser settings = + asum + [ DistinctFromBExprIsOp <$> (Parsers.keyphrase "distinct from" *> Parsers.space1 *> Parser.endHead *> parser settings), + OfBExprIsOp <$> (Parsers.keyword "of" *> Parsers.space1 *> Parser.endHead *> Parsers.inParens (parser settings)), + DocumentBExprIsOp <$ Parsers.keyword "document" + ] + +instance Qc.Arbitrary BExprIsOp where + shrink = Qc.genericShrink + arbitrary = + Gens.oneofRec + [ pure DocumentBExprIsOp + ] + [ DistinctFromBExprIsOp <$> Qc.arbitrary, + OfBExprIsOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/Bconst.hs b/library-internal/PostgresqlSyntax/Ast/Bconst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Bconst.hs @@ -0,0 +1,33 @@ +module PostgresqlSyntax.Ast.Bconst where + +import qualified Data.Text as Text +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.Shrinks as Shrinks +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc +import qualified TextBuilder + +-- | +-- ==== References +-- @ +-- BCONST +-- @ +newtype Bconst = Bconst Text + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Bconst where + toTextBuilder _settings (Bconst a) = "B'" <> TextBuilder.text a <> "'" + parser _settings = Parser.label "bit literal" $ do + Parsers.string' "b'" + Parser.endHead + a <- Parsers.takeWhile1P (Just "0 or 1") (\b -> b == '0' || b == '1') + Parsers.char '\'' + return (Bconst a) + +instance Qc.Arbitrary Bconst where + shrink (Bconst a) = Bconst <$> Shrinks.nonEmptyText a + arbitrary = do + len <- Qc.choose (1, 100) + Bconst . Text.pack <$> Qc.vectorOf len (Qc.elements "01") diff --git a/library-internal/PostgresqlSyntax/Ast/Bit.hs b/library-internal/PostgresqlSyntax/Ast/Bit.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Bit.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.Bit where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.OptVarying +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- Bit: +-- | BitWithLength +-- | BitWithoutLength +-- ConstBit: +-- | BitWithLength +-- | BitWithoutLength +-- BitWithLength: +-- | BIT opt_varying '(' expr_list ')' +-- BitWithoutLength: +-- | BIT opt_varying +-- @ +data Bit = Bit OptVarying (Maybe ExprList) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Bit where + toTextBuilder settings (Bit a b) = + TextBuilders.optLexemes + [ Just "BIT", + bool Nothing (Just "VARYING") (coerce a :: Bool), + fmap (TextBuilders.renderInParens . toTextBuilder settings) b + ] + parser settings = do + Parsers.keyword "bit" + a <- parser settings + b <- optional (Parsers.space1 *> Parsers.inParens (parser settings)) + return (Bit a b) + +instance Qc.Arbitrary Bit where + shrink = Qc.genericShrink + arbitrary = Bit <$> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/CExpr.hs b/library-internal/PostgresqlSyntax/Ast/CExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/CExpr.hs @@ -0,0 +1,188 @@ +module PostgresqlSyntax.Ast.CExpr + ( CExpr (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.AexprConst +import PostgresqlSyntax.Ast.ArrayExpr +import PostgresqlSyntax.Ast.CaseExpr +import PostgresqlSyntax.Ast.Columnref +import PostgresqlSyntax.Ast.ExplicitRow +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.FuncExpr +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.ImplicitRow +import PostgresqlSyntax.Ast.Indirection +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- c_expr: +-- | columnref +-- | AexprConst +-- | PARAM opt_indirection +-- | '(' a_expr ')' opt_indirection +-- | case_expr +-- | func_expr +-- | select_with_parens +-- | select_with_parens indirection +-- | EXISTS select_with_parens +-- | ARRAY select_with_parens +-- | ARRAY array_expr +-- | explicit_row +-- | implicit_row +-- | GROUPING '(' expr_list ')' +-- @ +data CExpr + = ColumnrefCExpr Columnref + | AexprConstCExpr AexprConst + | ParamCExpr Int (Maybe Indirection) + | InParensCExpr AExpr (Maybe Indirection) + | CaseCExpr CaseExpr + | FuncCExpr FuncExpr + | SelectWithParensCExpr SelectWithParens (Maybe Indirection) + | ExistsCExpr SelectWithParens + | ArrayCExpr (Either SelectWithParens ArrayExpr) + | ExplicitRowCExpr ExplicitRow + | ImplicitRowCExpr ImplicitRow + | GroupingCExpr ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst CExpr where + toTextBuilder settings = \case + ColumnrefCExpr a -> toTextBuilder settings a + AexprConstCExpr a -> toTextBuilder settings a + ParamCExpr a b -> "$" <> TextBuilder.intDec a <> foldMap (toTextBuilder settings) b + InParensCExpr a b -> TextBuilders.renderInParens (toTextBuilder settings a) <> foldMap (toTextBuilder settings) b + CaseCExpr a -> toTextBuilder settings a + FuncCExpr a -> toTextBuilder settings a + SelectWithParensCExpr a b -> toTextBuilder settings a <> foldMap (toTextBuilder settings) b + ExistsCExpr a -> "EXISTS " <> toTextBuilder settings a + ArrayCExpr a -> "ARRAY " <> either (toTextBuilder settings) (toTextBuilder settings) a + ExplicitRowCExpr a -> toTextBuilder settings a + ImplicitRowCExpr a -> toTextBuilder settings a + GroupingCExpr a -> "GROUPING " <> TextBuilders.renderInParens (toTextBuilder settings a) + parser settings = customizedParser settings (colId settings) + +-- | +-- Parameterized over the @ColId@-like identifier parser used by the plain +-- 'ColumnrefCExpr' alternative — the one place 'PostgresqlSyntax.Ast.AExpr' +-- \'s @filteredParser@ needs to customize. Every other alternative here +-- (parenthesized expressions, @ARRAY@, @EXISTS@, function calls, ...) always +-- uses the ordinary, unfiltered parsers for its nested @a_expr@\/ +-- @select_with_parens@\/etc, exactly as the pre-extraction +-- @customizedCExpr@\/@parenthesizedExprCExpr@ did — the filtering doesn't +-- propagate past this one level. +customizedParser :: Settings -> Parser Ident -> Parser CExpr +customizedParser settings colIdParser = + asum + [ ParamCExpr <$> (Parsers.char '$' *> Parsers.decimal <* Parser.endHead) <*> optional (Parsers.space *> parser settings), + CaseCExpr <$> parser settings, + ExplicitRowCExpr <$> parser settings, + Parsers.inParensWithClause (Parsers.keyword "grouping") (GroupingCExpr . ExprList <$> Parsers.sep1 Parsers.commaSeparator (parser settings)), + Parsers.keyword "exists" *> Parsers.space *> (ExistsCExpr <$> parser settings), + do + Parsers.keyword "array" + Parsers.space + asum + [ ArrayCExpr . Right <$> parser settings, + ArrayCExpr . Left <$> parser settings + ], + do + a <- Parser.wrapToHead (parser settings) + Parser.endHead + b <- optional (Parsers.space *> parser settings) + return (SelectWithParensCExpr a b), + parenthesizedExprCExpr, + AexprConstCExpr <$> Parser.wrapToHead (parser settings), + FuncCExpr <$> parser settings, + ColumnrefCExpr <$> customizedColumnref + ] + where + customizedColumnref = do + a <- Parser.wrapToHead colIdParser + Parser.endHead + b <- optional (Parsers.space *> parser settings) + return (Columnref a b) + + -- See 'PostgresqlSyntax.Ast.AExpr'\'s doc on the sibling parser this + -- replaces (@parenthesizedExprCExpr@\/implicit-row sharing trick) for + -- why the single @a_expr@ parse is shared between the two endings. + parenthesizedExprCExpr :: Parser CExpr + parenthesizedExprCExpr = do + Parsers.char '(' + Parsers.space + a <- parser settings + Parsers.space + asum + [ do + Parsers.char ',' + Parser.endHead + Parsers.space + b <- Parsers.sep1 Parsers.commaSeparator (parser settings) + Parsers.space + Parsers.char ')' + return $ ImplicitRowCExpr $ case NonEmpty.consAndUnsnoc a b of + (c, d) -> ImplicitRow (ExprList c) d, + do + Parsers.char ')' + Parser.endHead + b <- optional (Parsers.space *> parser settings) + return (InParensCExpr a b) + ] + +instance Qc.Arbitrary CExpr where + shrink = fmap canonicalize . Qc.genericShrink + arbitrary = + fmap canonicalize $ Qc.sized $ \n -> + if n <= 1 + then ColumnrefCExpr <$> Qc.arbitrary + else + Qc.oneof + [ ColumnrefCExpr <$> Qc.arbitrary, + AexprConstCExpr <$> Qc.arbitrary, + ParamCExpr <$> Qc.choose (1, 19) <*> Qc.arbitrary, + InParensCExpr <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + CaseCExpr <$> Qc.arbitrary, + FuncCExpr <$> Qc.arbitrary, + SelectWithParensCExpr <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + ExistsCExpr <$> Gens.downscale Qc.arbitrary, + ArrayCExpr <$> Gens.downscale Qc.arbitrary, + ExplicitRowCExpr <$> Qc.arbitrary, + ImplicitRowCExpr <$> Qc.arbitrary, + GroupingCExpr <$> Qc.arbitrary + ] + +-- | +-- Collapses the non-canonical @InParensCExpr@-wrapping-a-@SelectWithParensCExpr@ +-- shape to the @SelectWithParensCExpr@\/@WithParensSelectWithParens@ shape the +-- parser actually produces for it. +-- +-- @'(' a_expr ')' opt_indirection@ (i.e. 'InParensCExpr') and +-- @select_with_parens@ (i.e. 'SelectWithParensCExpr') overlap whenever the +-- inner @a_expr@ is itself nothing but a bare, indirection-less +-- @select_with_parens@: both parse @((select 1))@. 'customizedParser' tries +-- the @select_with_parens@ alternative before @parenthesizedExprCExpr@, so +-- that's always what the parser returns — never 'InParensCExpr' — making +-- the latter non-canonical for this shape. Both 'arbitrary' and 'shrink' can +-- otherwise construct it (shrinking the outer indirection to @Nothing@ is +-- exactly how it arises), which renders fine but parses back to a +-- different, canonical value and so breaks the roundtrip property. +instance Canonicalizes CExpr where + canonicalize = \case + InParensCExpr a outerIndirection + | Just inner <- project @SelectWithParens a -> + SelectWithParensCExpr (embed @SelectWithParens inner) outerIndirection + other -> other diff --git a/library-internal/PostgresqlSyntax/Ast/CallStmt.hs b/library-internal/PostgresqlSyntax/Ast/CallStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/CallStmt.hs @@ -0,0 +1,22 @@ +module PostgresqlSyntax.Ast.CallStmt where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncApplication +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +newtype CallStmt + = CallStmt FuncApplication + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst CallStmt where + toTextBuilder settings (CallStmt a) = "CALL " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "call" + Parsers.space1 + CallStmt <$> parser settings + +instance Qc.Arbitrary CallStmt where + shrink = Qc.genericShrink + arbitrary = CallStmt <$> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/CaseExpr.hs b/library-internal/PostgresqlSyntax/Ast/CaseExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/CaseExpr.hs @@ -0,0 +1,54 @@ +module PostgresqlSyntax.Ast.CaseExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.WhenClauseList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- case_expr: +-- | CASE case_arg when_clause_list case_default END_P +-- @ +data CaseExpr = CaseExpr (Maybe AExpr) WhenClauseList (Maybe AExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst CaseExpr where + toTextBuilder settings (CaseExpr a b c) = + TextBuilders.optLexemes + [ Just "CASE", + fmap (toTextBuilder settings) a, + Just (toTextBuilder settings b), + fmap caseDefault c, + Just "END" + ] + where + caseDefault d = "ELSE " <> toTextBuilder settings d + parser settings = Parser.label "case expression" $ do + Parsers.keyword "case" + Parsers.space1 + Parser.endHead + arg <- optional (parser settings <* Parsers.space1) + whenClauses <- parser settings + Parsers.space1 + default' <- optional elseClause + Parsers.keyword "end" + pure (CaseExpr arg whenClauses default') + where + elseClause = do + Parsers.keyword "else" + Parsers.space1 + Parser.endHead + a <- parser settings + Parsers.space1 + return a + +instance Qc.Arbitrary CaseExpr where + shrink = Qc.genericShrink + arbitrary = CaseExpr <$> Gens.terminatingMaybe (Gens.downscale arbitrary) <*> arbitrary <*> Gens.terminatingMaybe (Gens.downscale arbitrary) diff --git a/library-internal/PostgresqlSyntax/Ast/Character.hs b/library-internal/PostgresqlSyntax/Ast/Character.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Character.hs @@ -0,0 +1,57 @@ +module PostgresqlSyntax.Ast.Character where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.OptVarying +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- character: +-- | CHARACTER opt_varying +-- | CHAR_P opt_varying +-- | VARCHAR +-- | NATIONAL CHARACTER opt_varying +-- | NATIONAL CHAR_P opt_varying +-- | NCHAR opt_varying +-- @ +data Character + = CharacterCharacter OptVarying + | CharCharacter OptVarying + | VarcharCharacter + | NationalCharacterCharacter OptVarying + | NationalCharCharacter OptVarying + | NcharCharacter OptVarying + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Character where + toTextBuilder _settings = \case + CharacterCharacter a -> "CHARACTER" <> bool "" " VARYING" (coerce a :: Bool) + CharCharacter a -> "CHAR" <> bool "" " VARYING" (coerce a :: Bool) + VarcharCharacter -> "VARCHAR" + NationalCharacterCharacter a -> "NATIONAL CHARACTER" <> bool "" " VARYING" (coerce a :: Bool) + NationalCharCharacter a -> "NATIONAL CHAR" <> bool "" " VARYING" (coerce a :: Bool) + NcharCharacter a -> "NCHAR" <> bool "" " VARYING" (coerce a :: Bool) + parser settings = + asum + [ CharacterCharacter <$> (Parsers.keyword "character" *> parser settings), + CharCharacter <$> (Parsers.keyword "char" *> parser settings), + VarcharCharacter <$ Parsers.keyword "varchar", + NationalCharacterCharacter <$> (Parsers.keyphrase "national character" *> parser settings), + NationalCharCharacter <$> (Parsers.keyphrase "national char" *> parser settings), + NcharCharacter <$> (Parsers.keyword "nchar" *> parser settings) + ] + +instance Qc.Arbitrary Character where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ CharacterCharacter <$> Qc.arbitrary, + CharCharacter <$> Qc.arbitrary, + pure VarcharCharacter, + NationalCharacterCharacter <$> Qc.arbitrary, + NationalCharCharacter <$> Qc.arbitrary, + NcharCharacter <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/Columnref.hs b/library-internal/PostgresqlSyntax/Ast/Columnref.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Columnref.hs @@ -0,0 +1,32 @@ +module PostgresqlSyntax.Ast.Columnref where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident (Ident, colId) +import PostgresqlSyntax.Ast.Indirection +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- columnref: +-- | ColId +-- | ColId indirection +-- @ +data Columnref = Columnref Ident (Maybe Indirection) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Columnref where + toTextBuilder settings (Columnref a b) = toTextBuilder settings a <> foldMap (toTextBuilder settings) b + parser settings = do + a <- Parser.wrapToHead (colId settings) + Parser.endHead + b <- optional (Parsers.space *> parser settings) + return (Columnref a b) + +instance Qc.Arbitrary Columnref where + shrink = Qc.genericShrink + arbitrary = Columnref <$> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/CommonTableExpr.hs b/library-internal/PostgresqlSyntax/Ast/CommonTableExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/CommonTableExpr.hs @@ -0,0 +1,59 @@ +module PostgresqlSyntax.Ast.CommonTableExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.PreparableStmt +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- common_table_expr: +-- | name opt_name_list AS opt_materialized '(' PreparableStmt ')' +-- opt_materialized: +-- | MATERIALIZED +-- | NOT MATERIALIZED +-- | EMPTY +-- @ +data CommonTableExpr = CommonTableExpr Ident (Maybe (NonEmpty Ident)) (Maybe Bool) PreparableStmt + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst CommonTableExpr where + toTextBuilder settings (CommonTableExpr a b c d) = + TextBuilders.optLexemes + [ Just (toTextBuilder settings a), + fmap (TextBuilders.renderInParens . TextBuilders.commaNonEmpty (toTextBuilder settings)) b, + Just "AS", + fmap materialization c, + Just (TextBuilders.renderInParens (toTextBuilder settings d)) + ] + where + materialization = bool "NOT MATERIALIZED" "MATERIALIZED" + parser settings = Parser.label "common table expression" $ do + name <- colId settings <* Parsers.space <* Parser.endHead + nameList <- optional (Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (colId settings)) <* Parsers.space1) + Parsers.keyword "as" + Parsers.space1 + materialized <- optional (materialized <* Parsers.space1) + stmt <- Parsers.inParens (parser settings) + return (CommonTableExpr name nameList materialized stmt) + where + materialized = + True + <$ Parsers.keyword "materialized" + <|> False + <$ Parsers.keyphrase "not materialized" + +instance Qc.Arbitrary CommonTableExpr where + shrink = Qc.genericShrink + arbitrary = + CommonTableExpr + <$> Qc.arbitrary + <*> Gens.terminatingMaybe (Gens.nonEmptyUpTo 6 Qc.arbitrary) + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/ConfExpr.hs b/library-internal/PostgresqlSyntax/Ast/ConfExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ConfExpr.hs @@ -0,0 +1,51 @@ +module PostgresqlSyntax.Ast.ConfExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.IndexParams +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_conf_expr: +-- | '(' index_params ')' where_clause +-- | ON CONSTRAINT name +-- | EMPTY +-- @ +-- +-- @where_clause@ is inlined here as a bare 'PostgresqlSyntax.Ast.AExpr' +-- rather than going through 'PostgresqlSyntax.Ast.WhereClause'. +-- @name@ is a bare alias to 'PostgresqlSyntax.Ast.Ident'. +data ConfExpr + = WhereConfExpr IndexParams (Maybe AExpr) + | ConstraintConfExpr Ident + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ConfExpr where + toTextBuilder settings = \case + WhereConfExpr a b -> TextBuilders.renderInParens (toTextBuilder settings a) <> TextBuilders.suffixMaybe whereClause b + ConstraintConfExpr a -> "ON CONSTRAINT " <> toTextBuilder settings a + where + whereClause a = "WHERE " <> toTextBuilder settings a + parser settings = + asum + [ WhereConfExpr <$> Parsers.inParens (parser settings) <*> optional (Parsers.space *> whereClause), + ConstraintConfExpr <$> (Parsers.keyword "on" *> Parsers.space1 *> Parsers.keyword "constraint" *> Parsers.space1 *> Parser.endHead *> colId settings) + ] + where + whereClause = Parsers.keyword "where" *> Parsers.space1 *> Parser.endHead *> parser settings + +instance Qc.Arbitrary ConfExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ WhereConfExpr <$> Qc.arbitrary <*> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary), + ConstraintConfExpr <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ConstCharacter.hs b/library-internal/PostgresqlSyntax/Ast/ConstCharacter.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ConstCharacter.hs @@ -0,0 +1,41 @@ +module PostgresqlSyntax.Ast.ConstCharacter where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Character +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- ConstCharacter: +-- | CharacterWithLength +-- | CharacterWithoutLength +-- CharacterWithLength: +-- | character '(' Iconst ')' +-- CharacterWithoutLength: +-- | character +-- @ +data ConstCharacter = ConstCharacter Character (Maybe Int64) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ConstCharacter where + toTextBuilder settings (ConstCharacter a b) = toTextBuilder settings a <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) b + parser settings = ConstCharacter <$> (parser settings <* Parser.endHead) <*> optional (Parsers.space *> Parsers.inParens Parsers.decimal) + +instance Qc.Arbitrary ConstCharacter where + shrink = Qc.genericShrink + + -- The length here is parsed via 'Parsers.decimal' (unsigned), so it must + -- never be negative — mirroring 'PostgresqlSyntax.Ast.IntervalSecond'\'s + -- own @nonNegative@. + arbitrary = ConstCharacter <$> arbitrary <*> Qc.oneof [pure Nothing, Just <$> nonNegativeInt64] + where + nonNegativeInt64 = Qc.sized (\n -> Qc.choose (0, cap n)) + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/ConstDatetime.hs b/library-internal/PostgresqlSyntax/Ast/ConstDatetime.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ConstDatetime.hs @@ -0,0 +1,69 @@ +module PostgresqlSyntax.Ast.ConstDatetime where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Timezone +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- ConstDatetime: +-- | TIMESTAMP '(' Iconst ')' opt_timezone +-- | TIMESTAMP opt_timezone +-- | TIME '(' Iconst ')' opt_timezone +-- | TIME opt_timezone +-- @ +data ConstDatetime + = TimestampConstDatetime (Maybe Int64) (Maybe Timezone) + | TimeConstDatetime (Maybe Int64) (Maybe Timezone) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ConstDatetime where + toTextBuilder settings = \case + TimestampConstDatetime a b -> + TextBuilders.optLexemes + [ Just "TIMESTAMP", + fmap (TextBuilders.renderInParens . TextBuilder.int64Dec) a, + fmap (toTextBuilder settings) b + ] + TimeConstDatetime a b -> + TextBuilders.optLexemes + [ Just "TIME", + fmap (TextBuilders.renderInParens . TextBuilder.int64Dec) a, + fmap (toTextBuilder settings) b + ] + parser settings = + asum + [ do + Parsers.keyword "timestamp" + a <- optional (Parsers.space1 *> Parsers.inParens Parsers.decimal) + b <- optional (Parsers.space1 *> parser settings) + return (TimestampConstDatetime a b), + do + Parsers.keyword "time" + a <- optional (Parsers.space1 *> Parsers.inParens Parsers.decimal) + b <- optional (Parsers.space1 *> parser settings) + return (TimeConstDatetime a b) + ] + +instance Qc.Arbitrary ConstDatetime where + shrink = Qc.genericShrink + + -- The precision here is parsed via 'Parsers.decimal' (unsigned), so it + -- must never be negative — mirroring + -- 'PostgresqlSyntax.Ast.IntervalSecond'\'s own @nonNegative@. + arbitrary = + Qc.oneof + [ TimestampConstDatetime <$> nonNegativeMaybeInt64 <*> Qc.arbitrary, + TimeConstDatetime <$> nonNegativeMaybeInt64 <*> Qc.arbitrary + ] + where + nonNegativeMaybeInt64 = Qc.oneof [pure Nothing, Just <$> nonNegativeInt64] + nonNegativeInt64 = Qc.sized (\n -> Qc.choose (0, cap n)) + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/ConstTypename.hs b/library-internal/PostgresqlSyntax/Ast/ConstTypename.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ConstTypename.hs @@ -0,0 +1,49 @@ +module PostgresqlSyntax.Ast.ConstTypename where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Bit (Bit) +import PostgresqlSyntax.Ast.ConstCharacter +import PostgresqlSyntax.Ast.ConstDatetime +import PostgresqlSyntax.Ast.Numeric +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- ConstTypename: +-- | Numeric +-- | ConstBit +-- | ConstCharacter +-- | ConstDatetime +-- @ +data ConstTypename + = NumericConstTypename Numeric + | ConstBitConstTypename Bit + | ConstCharacterConstTypename ConstCharacter + | ConstDatetimeConstTypename ConstDatetime + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ConstTypename where + toTextBuilder settings = \case + NumericConstTypename a -> toTextBuilder settings a + ConstBitConstTypename a -> toTextBuilder settings a + ConstCharacterConstTypename a -> toTextBuilder settings a + ConstDatetimeConstTypename a -> toTextBuilder settings a + parser settings = + asum + [ NumericConstTypename <$> parser settings, + ConstBitConstTypename <$> parser settings, + ConstCharacterConstTypename <$> parser settings, + ConstDatetimeConstTypename <$> parser settings + ] + +instance Qc.Arbitrary ConstTypename where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ NumericConstTypename <$> Qc.arbitrary, + ConstBitConstTypename <$> Qc.arbitrary, + ConstCharacterConstTypename <$> Qc.arbitrary, + ConstDatetimeConstTypename <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/DeleteStmt.hs b/library-internal/PostgresqlSyntax/Ast/DeleteStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/DeleteStmt.hs @@ -0,0 +1,55 @@ +module PostgresqlSyntax.Ast.DeleteStmt where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.RelationExprOptAlias (RelationExprOptAlias) +import PostgresqlSyntax.Ast.ReturningClause +import PostgresqlSyntax.Ast.UsingClause +import PostgresqlSyntax.Ast.WhereOrCurrentClause +import {-# SOURCE #-} PostgresqlSyntax.Ast.WithClause (WithClause) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- DeleteStmt: +-- | opt_with_clause DELETE_P FROM relation_expr_opt_alias +-- using_clause where_or_current_clause returning_clause +-- @ +data DeleteStmt = DeleteStmt (Maybe WithClause) RelationExprOptAlias (Maybe UsingClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst DeleteStmt where + toTextBuilder settings (DeleteStmt a b c d e) = + TextBuilders.prefixMaybe (toTextBuilder settings) a + <> "DELETE FROM " + <> toTextBuilder settings b + <> TextBuilders.suffixMaybe (toTextBuilder settings) c + <> TextBuilders.suffixMaybe (toTextBuilder settings) d + <> TextBuilders.suffixMaybe (toTextBuilder settings) e + parser settings = do + a <- optional (Parser.wrapToHead (parser settings) <* Parsers.space1) + Parsers.keyword "delete" + Parsers.space1 + Parser.endHead + Parsers.keyword "from" + Parsers.space1 + b <- parser settings + c <- optional (Parsers.space1 *> parser settings) + d <- optional (Parsers.space1 *> parser settings) + e <- optional (Parsers.space1 *> parser settings) + return (DeleteStmt a b c d e) + +instance Qc.Arbitrary DeleteStmt where + shrink = Qc.genericShrink + arbitrary = + DeleteStmt + <$> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) + <*> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/ExplicitRow.hs b/library-internal/PostgresqlSyntax/Ast/ExplicitRow.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ExplicitRow.hs @@ -0,0 +1,41 @@ +module PostgresqlSyntax.Ast.ExplicitRow where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- explicit_row: +-- | ROW '(' expr_list ')' +-- | ROW '(' ')' +-- @ +data ExplicitRow + = EmptyExplicitRow + | ExprListExplicitRow ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ExplicitRow where + toTextBuilder settings a = + "ROW " + <> TextBuilders.renderInParens + ( case a of + EmptyExplicitRow -> mempty + ExprListExplicitRow b -> toTextBuilder settings b + ) + parser settings = + Parsers.keyword "row" + *> Parsers.space + *> Parsers.inParens (maybe EmptyExplicitRow ExprListExplicitRow <$> optional (parser settings)) + +instance Qc.Arbitrary ExplicitRow where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ pure EmptyExplicitRow, + ExprListExplicitRow <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ExprList.hs b/library-internal/PostgresqlSyntax/Ast/ExprList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ExprList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.ExprList where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- expr_list: +-- | a_expr +-- | expr_list ',' a_expr +-- @ +newtype ExprList = ExprList (NonEmpty AExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ExprList where + toTextBuilder settings (ExprList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = ExprList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary ExprList where + shrink = Qc.genericShrink + arbitrary = ExprList <$> Gens.nonEmptyUpTo 6 (Gens.downscale Qc.arbitrary) diff --git a/library-internal/PostgresqlSyntax/Ast/ExtractArg.hs b/library-internal/PostgresqlSyntax/Ast/ExtractArg.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ExtractArg.hs @@ -0,0 +1,68 @@ +module PostgresqlSyntax.Ast.ExtractArg where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Sconst +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- extract_arg: +-- | IDENT +-- | YEAR_P +-- | MONTH_P +-- | DAY_P +-- | HOUR_P +-- | MINUTE_P +-- | SECOND_P +-- | Sconst +-- @ +data ExtractArg + = IdentExtractArg Ident + | YearExtractArg + | MonthExtractArg + | DayExtractArg + | HourExtractArg + | MinuteExtractArg + | SecondExtractArg + | SconstExtractArg Sconst + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ExtractArg where + toTextBuilder settings = \case + IdentExtractArg a -> toTextBuilder settings a + YearExtractArg -> "YEAR" + MonthExtractArg -> "MONTH" + DayExtractArg -> "DAY" + HourExtractArg -> "HOUR" + MinuteExtractArg -> "MINUTE" + SecondExtractArg -> "SECOND" + SconstExtractArg a -> toTextBuilder settings a + parser settings = + asum + [ YearExtractArg <$ Parsers.keyword "year", + MonthExtractArg <$ Parsers.keyword "month", + DayExtractArg <$ Parsers.keyword "day", + HourExtractArg <$ Parsers.keyword "hour", + MinuteExtractArg <$ Parsers.keyword "minute", + SecondExtractArg <$ Parsers.keyword "second", + SconstExtractArg <$> parser settings, + IdentExtractArg <$> parser settings + ] + +instance Qc.Arbitrary ExtractArg where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ IdentExtractArg <$> Qc.arbitrary, + pure YearExtractArg, + pure MonthExtractArg, + pure DayExtractArg, + pure HourExtractArg, + pure MinuteExtractArg, + pure SecondExtractArg, + SconstExtractArg <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ExtractList.hs b/library-internal/PostgresqlSyntax/Ast/ExtractList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ExtractList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.ExtractList where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExtractArg +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- extract_list: +-- | extract_arg FROM a_expr +-- | EMPTY +-- @ +data ExtractList = ExtractList ExtractArg AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ExtractList where + toTextBuilder settings (ExtractList a b) = toTextBuilder settings a <> " FROM " <> toTextBuilder settings b + parser settings = ExtractList <$> parser settings <*> (Parsers.space1 *> Parsers.keyword "from" *> Parsers.space1 *> parser settings) + +instance Qc.Arbitrary ExtractList where + shrink = Qc.genericShrink + arbitrary = ExtractList <$> arbitrary <*> Gens.downscale arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Fconst.hs b/library-internal/PostgresqlSyntax/Ast/Fconst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Fconst.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.Fconst where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- FCONST +-- @ +newtype Fconst = Fconst Double + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Fconst where + toTextBuilder _settings (Fconst a) = TextBuilder.doubleDec a + parser _settings = Fconst <$> Parsers.float + +instance Qc.Arbitrary Fconst where + shrink = Qc.genericShrink + + -- Parsed via 'Parsers.float' (unsigned — the sign, when present, is a + -- separate unary @AExpr@\/@BExpr@ operator applied outside this type), so + -- it must never be negative, mirroring + -- 'PostgresqlSyntax.Ast.IntervalSecond'\'s own @nonNegative@. + arbitrary = + Fconst . abs + <$> (Qc.arbitrary `Qc.suchThat` (\a -> fromIntegral (round a :: Int) /= a)) diff --git a/library-internal/PostgresqlSyntax/Ast/ForLockingClause.hs b/library-internal/PostgresqlSyntax/Ast/ForLockingClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ForLockingClause.hs @@ -0,0 +1,41 @@ +module PostgresqlSyntax.Ast.ForLockingClause where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ForLockingItem +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- for_locking_clause: +-- | for_locking_items +-- | FOR READ ONLY +-- for_locking_items: +-- | for_locking_item +-- | for_locking_items for_locking_item +-- @ +data ForLockingClause + = ItemsForLockingClause (NonEmpty ForLockingItem) + | ReadOnlyForLockingClause + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ForLockingClause where + toTextBuilder settings = \case + ItemsForLockingClause a -> TextBuilders.spaceNonEmpty (toTextBuilder settings) a + ReadOnlyForLockingClause -> "FOR READ ONLY" + parser settings = readOnly <|> items + where + readOnly = ReadOnlyForLockingClause <$ Parsers.keyphrase "for read only" + items = ItemsForLockingClause <$> Parsers.sep1 Parsers.space1 (parser settings) + +instance Qc.Arbitrary ForLockingClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ItemsForLockingClause <$> Gens.nonEmptyUpTo 7 Qc.arbitrary, + pure ReadOnlyForLockingClause + ] diff --git a/library-internal/PostgresqlSyntax/Ast/ForLockingItem.hs b/library-internal/PostgresqlSyntax/Ast/ForLockingItem.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ForLockingItem.hs @@ -0,0 +1,49 @@ +module PostgresqlSyntax.Ast.ForLockingItem where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ForLockingStrength +import PostgresqlSyntax.Ast.QualifiedName +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- for_locking_item: +-- | for_locking_strength locked_rels_list opt_nowait_or_skip +-- locked_rels_list: +-- | OF qualified_name_list +-- | EMPTY +-- opt_nowait_or_skip: +-- | NOWAIT +-- | SKIP LOCKED +-- | EMPTY +-- @ +data ForLockingItem = ForLockingItem ForLockingStrength (Maybe (NonEmpty QualifiedName)) (Maybe Bool) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ForLockingItem where + toTextBuilder settings (ForLockingItem a b c) = + TextBuilders.optLexemes + [ Just (toTextBuilder settings a), + fmap lockedRelsList b, + fmap nowaitOrSkip c + ] + where + lockedRelsList a' = "OF " <> TextBuilders.commaNonEmpty (toTextBuilder settings) a' + nowaitOrSkip = bool "NOWAIT" "SKIP LOCKED" + parser settings = do + strength <- parser settings + rels <- optional $ Parsers.space1 *> Parsers.keyword "of" *> Parsers.space1 *> Parser.endHead *> Parsers.sep1 Parsers.commaSeparator (parser settings) + nowaitOrSkip <- optional (Parsers.space1 *> nowaitOrSkip) + return (ForLockingItem strength rels nowaitOrSkip) + where + nowaitOrSkip = False <$ Parsers.keyword "nowait" <|> True <$ Parsers.keyphrase "skip locked" + +instance Qc.Arbitrary ForLockingItem where + shrink = Qc.genericShrink + arbitrary = ForLockingItem <$> arbitrary <*> Gens.terminatingMaybe arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/ForLockingStrength.hs b/library-internal/PostgresqlSyntax/Ast/ForLockingStrength.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ForLockingStrength.hs @@ -0,0 +1,48 @@ +module PostgresqlSyntax.Ast.ForLockingStrength where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- for_locking_strength: +-- | FOR UPDATE +-- | FOR NO KEY UPDATE +-- | FOR SHARE +-- | FOR KEY SHARE +-- @ +data ForLockingStrength + = UpdateForLockingStrength + | NoKeyUpdateForLockingStrength + | ShareForLockingStrength + | KeyForLockingStrength + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ForLockingStrength where + toTextBuilder _settings = \case + UpdateForLockingStrength -> "FOR UPDATE" + NoKeyUpdateForLockingStrength -> "FOR NO KEY UPDATE" + ShareForLockingStrength -> "FOR SHARE" + KeyForLockingStrength -> "FOR KEY SHARE" + parser _settings = + UpdateForLockingStrength + <$ Parsers.keyphrase "for update" + <|> NoKeyUpdateForLockingStrength + <$ Parsers.keyphrase "for no key update" + <|> ShareForLockingStrength + <$ Parsers.keyphrase "for share" + <|> KeyForLockingStrength + <$ Parsers.keyphrase "for key share" + +instance Qc.Arbitrary ForLockingStrength where + shrink = Qc.genericShrink + arbitrary = + Qc.elements + [ UpdateForLockingStrength, + NoKeyUpdateForLockingStrength, + ShareForLockingStrength, + KeyForLockingStrength + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FrameBound.hs b/library-internal/PostgresqlSyntax/Ast/FrameBound.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FrameBound.hs @@ -0,0 +1,56 @@ +module PostgresqlSyntax.Ast.FrameBound where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- frame_bound: +-- | UNBOUNDED PRECEDING +-- | UNBOUNDED FOLLOWING +-- | CURRENT_P ROW +-- | a_expr PRECEDING +-- | a_expr FOLLOWING +-- @ +data FrameBound + = UnboundedPrecedingFrameBound + | UnboundedFollowingFrameBound + | CurrentRowFrameBound + | PrecedingFrameBound AExpr + | FollowingFrameBound AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FrameBound where + toTextBuilder settings = \case + UnboundedPrecedingFrameBound -> "UNBOUNDED PRECEDING" + UnboundedFollowingFrameBound -> "UNBOUNDED FOLLOWING" + CurrentRowFrameBound -> "CURRENT ROW" + PrecedingFrameBound a -> toTextBuilder settings a <> " PRECEDING" + FollowingFrameBound a -> toTextBuilder settings a <> " FOLLOWING" + parser settings = + UnboundedPrecedingFrameBound + <$ Parsers.keyphrase "unbounded preceding" + <|> UnboundedFollowingFrameBound + <$ Parsers.keyphrase "unbounded following" + <|> CurrentRowFrameBound + <$ Parsers.keyphrase "current row" + <|> do + a <- parser settings :: Parser AExpr + Parsers.space1 + PrecedingFrameBound a <$ Parsers.keyword "preceding" <|> FollowingFrameBound a <$ Parsers.keyword "following" + +instance Qc.Arbitrary FrameBound where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ pure UnboundedPrecedingFrameBound, + pure UnboundedFollowingFrameBound, + pure CurrentRowFrameBound, + PrecedingFrameBound <$> Gens.downscale Qc.arbitrary, + FollowingFrameBound <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FrameClause.hs b/library-internal/PostgresqlSyntax/Ast/FrameClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FrameClause.hs @@ -0,0 +1,40 @@ +module PostgresqlSyntax.Ast.FrameClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FrameClauseMode +import PostgresqlSyntax.Ast.FrameExtent +import PostgresqlSyntax.Ast.WindowExclusionClause +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_frame_clause: +-- | RANGE frame_extent opt_window_exclusion_clause +-- | ROWS frame_extent opt_window_exclusion_clause +-- | GROUPS frame_extent opt_window_exclusion_clause +-- | EMPTY +-- @ +data FrameClause = FrameClause FrameClauseMode FrameExtent (Maybe WindowExclusionClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FrameClause where + toTextBuilder settings (FrameClause a b c) = + TextBuilders.optLexemes + [ Just (toTextBuilder settings a), + Just (toTextBuilder settings b), + fmap (toTextBuilder settings) c + ] + parser settings = do + a <- parser settings <* Parsers.space1 <* Parser.endHead + b <- parser settings + c <- optional (Parsers.space1 *> parser settings) + return (FrameClause a b c) + +instance Qc.Arbitrary FrameClause where + shrink = Qc.genericShrink + arbitrary = FrameClause <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/FrameClauseMode.hs b/library-internal/PostgresqlSyntax/Ast/FrameClauseMode.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FrameClauseMode.hs @@ -0,0 +1,34 @@ +module PostgresqlSyntax.Ast.FrameClauseMode where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_frame_clause: +-- | RANGE frame_extent opt_window_exclusion_clause +-- | ROWS frame_extent opt_window_exclusion_clause +-- | GROUPS frame_extent opt_window_exclusion_clause +-- | EMPTY +-- @ +data FrameClauseMode = RangeFrameClauseMode | RowsFrameClauseMode | GroupsFrameClauseMode + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FrameClauseMode where + toTextBuilder _settings = \case + RangeFrameClauseMode -> "RANGE" + RowsFrameClauseMode -> "ROWS" + GroupsFrameClauseMode -> "GROUPS" + parser _settings = + asum + [ RangeFrameClauseMode <$ Parsers.keyword "range", + RowsFrameClauseMode <$ Parsers.keyword "rows", + GroupsFrameClauseMode <$ Parsers.keyword "groups" + ] + +instance Qc.Arbitrary FrameClauseMode where + shrink = Qc.genericShrink + arbitrary = Qc.elements [RangeFrameClauseMode, RowsFrameClauseMode, GroupsFrameClauseMode] diff --git a/library-internal/PostgresqlSyntax/Ast/FrameExtent.hs b/library-internal/PostgresqlSyntax/Ast/FrameExtent.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FrameExtent.hs @@ -0,0 +1,37 @@ +module PostgresqlSyntax.Ast.FrameExtent where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FrameBound +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- frame_extent: +-- | frame_bound +-- | BETWEEN frame_bound AND frame_bound +-- @ +data FrameExtent = SingularFrameExtent FrameBound | BetweenFrameExtent FrameBound FrameBound + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FrameExtent where + toTextBuilder settings = \case + SingularFrameExtent a -> toTextBuilder settings a + BetweenFrameExtent a b -> "BETWEEN " <> toTextBuilder settings a <> " AND " <> toTextBuilder settings b + parser settings = + BetweenFrameExtent + <$> (Parsers.keyword "between" *> Parsers.space1 *> Parser.endHead *> parser settings <* Parsers.space1 <* Parsers.keyword "and" <* Parsers.space1) + <*> parser settings + <|> SingularFrameExtent + <$> parser settings + +instance Qc.Arbitrary FrameExtent where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ SingularFrameExtent <$> Qc.arbitrary, + BetweenFrameExtent <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FromClause.hs b/library-internal/PostgresqlSyntax/Ast/FromClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FromClause.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.FromClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FromList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- from_clause: +-- | FROM from_list +-- | /*EMPTY*/ +-- @ +newtype FromClause = FromClause FromList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FromClause where + toTextBuilder settings (FromClause a) = "FROM " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "from" + Parser.endHead + Parsers.space1 + FromClause <$> parser settings + +instance Qc.Arbitrary FromClause where + shrink = Qc.genericShrink + arbitrary = FromClause <$> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/FromList.hs b/library-internal/PostgresqlSyntax/Ast/FromList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FromList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.FromList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.TableRef +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- from_list: +-- | table_ref +-- | from_list ',' table_ref +-- @ +newtype FromList = FromList (NonEmpty TableRef) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FromList where + toTextBuilder settings (FromList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = FromList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary FromList where + shrink = Qc.genericShrink + arbitrary = FromList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/FuncAliasClause.hs b/library-internal/PostgresqlSyntax/Ast/FuncAliasClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncAliasClause.hs @@ -0,0 +1,83 @@ +module PostgresqlSyntax.Ast.FuncAliasClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AliasClause +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.TableFuncElementList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_alias_clause: +-- | alias_clause +-- | AS '(' TableFuncElementList ')' +-- | AS ColId '(' TableFuncElementList ')' +-- | ColId '(' TableFuncElementList ')' +-- | EMPTY +-- @ +data FuncAliasClause + = AliasFuncAliasClause AliasClause + | AsFuncAliasClause TableFuncElementList + | AsColIdFuncAliasClause Ident TableFuncElementList + | ColIdFuncAliasClause Ident TableFuncElementList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncAliasClause where + toTextBuilder settings = \case + AliasFuncAliasClause a -> toTextBuilder settings a + AsFuncAliasClause a -> "AS (" <> toTextBuilder settings a <> ")" + AsColIdFuncAliasClause a b -> "AS " <> toTextBuilder settings a <> " (" <> toTextBuilder settings b <> ")" + ColIdFuncAliasClause a b -> toTextBuilder settings a <> " (" <> toTextBuilder settings b <> ")" + parser settings = + asum + [ do + _ <- Parsers.keyword "as" + asum + [ do + Parsers.space + Parsers.inParens $ do + Parser.endHead + AsFuncAliasClause <$> parser settings, + do + Parsers.space1 + a <- colId settings + asum + [ do + Parsers.space + Parsers.inParens $ do + Parser.endHead + asum + [ AsColIdFuncAliasClause a <$> Parser.wrapToHead (parser settings), + AliasFuncAliasClause . AliasClause True a . Just <$> parser settings + ], + pure (AliasFuncAliasClause (AliasClause True a Nothing)) + ] + ], + do + a <- colId settings + asum + [ do + Parsers.space + Parsers.inParens $ do + Parser.endHead + asum + [ ColIdFuncAliasClause a <$> Parser.wrapToHead (parser settings), + AliasFuncAliasClause . AliasClause False a . Just <$> parser settings + ], + pure (AliasFuncAliasClause (AliasClause False a Nothing)) + ] + ] + +instance Qc.Arbitrary FuncAliasClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ AliasFuncAliasClause <$> Qc.arbitrary, + AsFuncAliasClause <$> Qc.arbitrary, + AsColIdFuncAliasClause <$> Qc.arbitrary <*> Qc.arbitrary, + ColIdFuncAliasClause <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncApplication.hs b/library-internal/PostgresqlSyntax/Ast/FuncApplication.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncApplication.hs @@ -0,0 +1,39 @@ +module PostgresqlSyntax.Ast.FuncApplication where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncApplicationParams +import PostgresqlSyntax.Ast.FuncName +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_application: +-- | func_name '(' ')' +-- | func_name '(' func_arg_list opt_sort_clause ')' +-- | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')' +-- | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')' +-- | func_name '(' ALL func_arg_list opt_sort_clause ')' +-- | func_name '(' DISTINCT func_arg_list opt_sort_clause ')' +-- | func_name '(' '*' ')' +-- @ +data FuncApplication = FuncApplication FuncName (Maybe FuncApplicationParams) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncApplication where + toTextBuilder settings (FuncApplication a b) = toTextBuilder settings a <> "(" <> foldMap (toTextBuilder settings) b <> ")" + + -- \"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. + parser settings = + Parsers.notFollowedBy (Parsers.keyword "operator" *> Parsers.space *> Parsers.char '(') + *> Parsers.inParensWithLabel FuncApplication (parser settings) (optional (parser settings)) + +instance Qc.Arbitrary FuncApplication where + shrink = Qc.genericShrink + arbitrary = FuncApplication <$> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/FuncApplicationParams.hs b/library-internal/PostgresqlSyntax/Ast/FuncApplicationParams.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncApplicationParams.hs @@ -0,0 +1,114 @@ +module PostgresqlSyntax.Ast.FuncApplicationParams + ( FuncApplicationParams (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncArgExpr +import PostgresqlSyntax.Ast.SortClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_application: +-- | func_name '(' ')' +-- | func_name '(' func_arg_list opt_sort_clause ')' +-- | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')' +-- | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')' +-- | func_name '(' ALL func_arg_list opt_sort_clause ')' +-- | func_name '(' DISTINCT func_arg_list opt_sort_clause ')' +-- | func_name '(' '*' ')' +-- @ +data FuncApplicationParams + = NormalFuncApplicationParams (Maybe Bool) (NonEmpty FuncArgExpr) (Maybe SortClause) + | VariadicFuncApplicationParams (Maybe (NonEmpty FuncArgExpr)) FuncArgExpr (Maybe SortClause) + | StarFuncApplicationParams + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncApplicationParams where + toTextBuilder settings = \case + NormalFuncApplicationParams a b c -> + TextBuilders.optLexemes + [ fmap TextBuilders.renderAllOrDistinct a, + Just (TextBuilders.commaNonEmpty (toTextBuilder settings) b), + fmap (toTextBuilder settings) c + ] + VariadicFuncApplicationParams a b c -> + TextBuilders.optLexemes + [ fmap (flip mappend "," . TextBuilders.commaNonEmpty (toTextBuilder settings)) a, + Just "VARIADIC", + Just (toTextBuilder settings b), + fmap (toTextBuilder settings) c + ] + StarFuncApplicationParams -> "*" + parser settings = + asum + [ starFuncApplicationParams, + listVariadicFuncApplicationParams, + singleVariadicFuncApplicationParams, + normalFuncApplicationParams + ] + where + normalFuncApplicationParams = do + optAllOrDistinct <- optional (Parsers.allOrDistinct <* Parsers.space1) + argList <- Parsers.sep1 Parsers.commaSeparator (parser settings) + Parser.endHead + optSortClause <- optional (Parsers.space1 *> parser settings) + return (NormalFuncApplicationParams optAllOrDistinct argList optSortClause) + singleVariadicFuncApplicationParams = do + Parsers.keyword "variadic" + Parsers.space1 + Parser.endHead + arg <- parser settings + optSortClause <- optional (Parsers.space1 *> parser settings) + return (VariadicFuncApplicationParams Nothing arg optSortClause) + + -- @func_arg_list ',' VARIADIC func_arg_expr@: one or more + -- comma-separated 'FuncArgExpr's, where the final comma is + -- immediately followed by (and the @VARIADIC@ Parsers.keyword itself consumed + -- by) the terminating branch — equivalent to the pre-extraction + -- @sepEnd1 Parsers.commaSeparator (Parsers.keyword "variadic" <* space1) funcArgExpr@. + listVariadicFuncApplicationParams = do + argList <- Parser.wrapToHead argListEndingInVariadic + Parser.endHead + arg <- parser settings + optSortClause <- optional (Parsers.space1 *> parser settings) + return (VariadicFuncApplicationParams (Just argList) arg optSortClause) + argListEndingInVariadic = do + a <- parser settings + Parsers.commaSeparator + asum + [ pure (a :| []) <* (Parsers.keyword "variadic" *> Parsers.space1), + (\(b :| bs) -> a :| b : bs) <$> argListEndingInVariadic + ] + -- A bare '*' char can also be the leading char of a longer operator + -- token (e.g. "*#" in @foo(*# DEFAULT)@'s @PrefixQualOpAExpr@), so + -- this only commits to the wildcard reading when no further op char + -- follows — otherwise it falls through to 'normalFuncApplicationParams', + -- which parses the '*' as the start of that operator instead. + starFuncApplicationParams = + Parsers.space + *> Parsers.char '*' + *> Parsers.notFollowedBy (Parsers.satisfy Predicate.opChar) + *> Parser.endHead + *> Parsers.space + $> StarFuncApplicationParams + +instance Qc.Arbitrary FuncApplicationParams where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ NormalFuncApplicationParams <$> Qc.arbitrary <*> nonEmptyOf 8 <*> Gens.terminatingMaybe Qc.arbitrary, + VariadicFuncApplicationParams <$> maybeNonEmptyOf 8 <*> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary, + pure StarFuncApplicationParams + ] + where + nonEmptyOf hi = Gens.nonEmptyUpTo (hi - 1) Qc.arbitrary + maybeNonEmptyOf hi = Qc.oneof [pure Nothing, Just <$> nonEmptyOf hi] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncArgExpr.hs b/library-internal/PostgresqlSyntax/Ast/FuncArgExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncArgExpr.hs @@ -0,0 +1,70 @@ +module PostgresqlSyntax.Ast.FuncArgExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_arg_expr: +-- | a_expr +-- | param_name COLON_EQUALS a_expr +-- | param_name EQUALS_GREATER a_expr +-- param_name: +-- | type_function_name +-- @ +data FuncArgExpr + = ExprFuncArgExpr AExpr + | ColonEqualsFuncArgExpr Ident AExpr + | EqualsGreaterFuncArgExpr Ident AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncArgExpr where + toTextBuilder settings = \case + ExprFuncArgExpr a -> toTextBuilder settings a + ColonEqualsFuncArgExpr a b -> toTextBuilder settings a <> " := " <> toTextBuilder settings b + EqualsGreaterFuncArgExpr a b -> toTextBuilder settings a <> " => " <> toTextBuilder settings b + parser settings = + asum + [ do + a <- Parser.wrapToHead typeFunctionName + Parsers.space + asum + [ do + Parsers.string ":=" + Parser.endHead + b <- Parsers.space *> parser settings + return (ColonEqualsFuncArgExpr a b), + do + Parsers.string "=>" + Parser.endHead + b <- Parsers.space *> parser settings + return (EqualsGreaterFuncArgExpr a b) + ], + ExprFuncArgExpr <$> parser settings + ] + where + -- Duplicated from "PostgresqlSyntax.Parsing"'s @typeFunctionName@ + -- (a bare-aliased 'PostgresqlSyntax.Ast.Ident' whose own parser lives + -- above this module in the dependency order), mirroring the + -- 'PostgresqlSyntax.Ast.AnyName'\/'PostgresqlSyntax.Ast.NameList' + -- precedent. + typeFunctionName = + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.typeFunctionName + <|> parser settings + +instance Qc.Arbitrary FuncArgExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprFuncArgExpr <$> Gens.downscale Qc.arbitrary, + ColonEqualsFuncArgExpr <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + EqualsGreaterFuncArgExpr <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncConstArgs.hs b/library-internal/PostgresqlSyntax/Ast/FuncConstArgs.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncConstArgs.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.FuncConstArgs where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncArgExpr +import PostgresqlSyntax.Ast.SortClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- The parenthesized-argument-list part of a @func_name '(' func_arg_list +-- opt_sort_clause ')' Sconst@ 'PostgresqlSyntax.Ast.AexprConst' — rendered\/ +-- parsed without its enclosing parens, which belong to the caller. +-- +-- ==== References +-- @ +-- | func_name '(' func_arg_list opt_sort_clause ')' Sconst +-- @ +data FuncConstArgs = FuncConstArgs (NonEmpty FuncArgExpr) (Maybe SortClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncConstArgs where + toTextBuilder settings (FuncConstArgs a b) = TextBuilders.commaNonEmpty (toTextBuilder settings) a <> TextBuilders.suffixMaybe (toTextBuilder settings) b + parser settings = FuncConstArgs <$> Parsers.sep1 Parsers.commaSeparator (parser settings) <*> optional (Parsers.space1 *> parser settings) + +instance Qc.Arbitrary FuncConstArgs where + shrink = Qc.genericShrink + arbitrary = FuncConstArgs <$> Gens.nonEmptyUpTo 6 Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/FuncExpr.hs b/library-internal/PostgresqlSyntax/Ast/FuncExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncExpr.hs @@ -0,0 +1,78 @@ +module PostgresqlSyntax.Ast.FuncExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.FuncApplication +import PostgresqlSyntax.Ast.FuncExprCommonSubexpr +import PostgresqlSyntax.Ast.OverClause +import PostgresqlSyntax.Ast.SortClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_expr: +-- | func_application within_group_clause filter_clause over_clause +-- | func_expr_common_subexpr +-- @ +-- +-- @within_group_clause@ and @filter_clause@ are bare aliases to +-- 'PostgresqlSyntax.Ast.SortClause' and 'PostgresqlSyntax.Ast.AExpr' +-- respectively. +data FuncExpr + = ApplicationFuncExpr FuncApplication (Maybe SortClause) (Maybe AExpr) (Maybe OverClause) + | SubexprFuncExpr FuncExprCommonSubexpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncExpr where + toTextBuilder settings = \case + ApplicationFuncExpr a b c d -> + TextBuilders.optLexemes + [ Just (toTextBuilder settings a), + fmap withinGroupClause b, + fmap filterClause c, + fmap (toTextBuilder settings) d + ] + SubexprFuncExpr a -> toTextBuilder settings a + where + withinGroupClause a = "WITHIN GROUP (" <> toTextBuilder settings a <> ")" + filterClause a = "FILTER (WHERE " <> toTextBuilder settings a <> ")" + parser settings = + asum + [ SubexprFuncExpr <$> parser settings, + do + a <- parser settings + Parser.endHead + b <- optional (Parsers.space1 *> withinGroupClause) + c <- optional (Parsers.space1 *> filterClause) + d <- optional (Parsers.space1 *> parser settings) + return (ApplicationFuncExpr a b c d) + ] + where + withinGroupClause = do + Parsers.keyphrase "within group" + Parser.endHead + Parsers.space + Parsers.inParens (parser settings) + filterClause = do + Parsers.keyword "filter" + Parser.endHead + Parsers.space + Parsers.inParens (Parsers.keyword "where" *> Parsers.space1 *> parser settings) + +instance Qc.Arbitrary FuncExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ApplicationFuncExpr + <$> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) + <*> Gens.terminatingMaybe Qc.arbitrary, + SubexprFuncExpr <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs b/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs @@ -0,0 +1,199 @@ +module PostgresqlSyntax.Ast.FuncExprCommonSubexpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.ExtractList +import PostgresqlSyntax.Ast.OverlayList +import PostgresqlSyntax.Ast.PositionList +import PostgresqlSyntax.Ast.SubstrList +import PostgresqlSyntax.Ast.TrimList +import PostgresqlSyntax.Ast.TrimModifier +import PostgresqlSyntax.Ast.Typename +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_expr_common_subexpr: +-- | COLLATION FOR '(' a_expr ')' +-- | CURRENT_DATE +-- | CURRENT_TIME +-- | CURRENT_TIME '(' Iconst ')' +-- | CURRENT_TIMESTAMP +-- | CURRENT_TIMESTAMP '(' Iconst ')' +-- | LOCALTIME +-- | LOCALTIME '(' Iconst ')' +-- | LOCALTIMESTAMP +-- | LOCALTIMESTAMP '(' Iconst ')' +-- | CURRENT_ROLE +-- | CURRENT_USER +-- | SESSION_USER +-- | USER +-- | CURRENT_CATALOG +-- | CURRENT_SCHEMA +-- | CAST '(' a_expr AS Typename ')' +-- | EXTRACT '(' extract_list ')' +-- | OVERLAY '(' overlay_list ')' +-- | POSITION '(' position_list ')' +-- | SUBSTRING '(' substr_list ')' +-- | TREAT '(' a_expr AS Typename ')' +-- | TRIM '(' BOTH trim_list ')' +-- | TRIM '(' LEADING trim_list ')' +-- | TRIM '(' TRAILING trim_list ')' +-- | TRIM '(' trim_list ')' +-- | NULLIF '(' a_expr ',' a_expr ')' +-- | COALESCE '(' expr_list ')' +-- | GREATEST '(' expr_list ')' +-- | LEAST '(' expr_list ')' +-- | XMLCONCAT '(' expr_list ')' +-- | XMLELEMENT '(' NAME_P ColLabel ')' +-- | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ')' +-- | XMLELEMENT '(' NAME_P ColLabel ',' expr_list ')' +-- | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ',' expr_list ')' +-- | XMLEXISTS '(' c_expr xmlexists_argument ')' +-- | XMLFOREST '(' xml_attribute_list ')' +-- | XMLPARSE '(' document_or_content a_expr xml_whitespace_option ')' +-- | XMLPI '(' NAME_P ColLabel ')' +-- | XMLPI '(' NAME_P ColLabel ',' a_expr ')' +-- | XMLROOT '(' a_expr ',' xml_root_version opt_xml_root_standalone ')' +-- | XMLSERIALIZE '(' document_or_content a_expr AS SimpleTypename ')' +-- +-- TODO: Implement the XML cases +-- @ +data FuncExprCommonSubexpr + = CollationForFuncExprCommonSubexpr AExpr + | CurrentDateFuncExprCommonSubexpr + | CurrentTimeFuncExprCommonSubexpr (Maybe Int64) + | CurrentTimestampFuncExprCommonSubexpr (Maybe Int64) + | LocalTimeFuncExprCommonSubexpr (Maybe Int64) + | LocalTimestampFuncExprCommonSubexpr (Maybe Int64) + | CurrentRoleFuncExprCommonSubexpr + | CurrentUserFuncExprCommonSubexpr + | SessionUserFuncExprCommonSubexpr + | UserFuncExprCommonSubexpr + | CurrentCatalogFuncExprCommonSubexpr + | CurrentSchemaFuncExprCommonSubexpr + | CastFuncExprCommonSubexpr AExpr Typename + | ExtractFuncExprCommonSubexpr (Maybe ExtractList) + | OverlayFuncExprCommonSubexpr OverlayList + | PositionFuncExprCommonSubexpr (Maybe PositionList) + | SubstringFuncExprCommonSubexpr (Maybe SubstrList) + | TreatFuncExprCommonSubexpr AExpr Typename + | TrimFuncExprCommonSubexpr (Maybe TrimModifier) TrimList + | NullIfFuncExprCommonSubexpr AExpr AExpr + | CoalesceFuncExprCommonSubexpr ExprList + | GreatestFuncExprCommonSubexpr ExprList + | LeastFuncExprCommonSubexpr ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncExprCommonSubexpr where + toTextBuilder settings = \case + CollationForFuncExprCommonSubexpr a -> "COLLATION FOR (" <> toTextBuilder settings a <> ")" + CurrentDateFuncExprCommonSubexpr -> "CURRENT_DATE" + CurrentTimeFuncExprCommonSubexpr a -> "CURRENT_TIME" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) a + CurrentTimestampFuncExprCommonSubexpr a -> "CURRENT_TIMESTAMP" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) a + LocalTimeFuncExprCommonSubexpr a -> "LOCALTIME" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) a + LocalTimestampFuncExprCommonSubexpr a -> "LOCALTIMESTAMP" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) a + CurrentRoleFuncExprCommonSubexpr -> "CURRENT_ROLE" + CurrentUserFuncExprCommonSubexpr -> "CURRENT_USER" + SessionUserFuncExprCommonSubexpr -> "SESSION_USER" + UserFuncExprCommonSubexpr -> "USER" + CurrentCatalogFuncExprCommonSubexpr -> "CURRENT_CATALOG" + CurrentSchemaFuncExprCommonSubexpr -> "CURRENT_SCHEMA" + CastFuncExprCommonSubexpr a b -> "CAST (" <> toTextBuilder settings a <> " AS " <> toTextBuilder settings b <> ")" + ExtractFuncExprCommonSubexpr a -> "EXTRACT (" <> foldMap (toTextBuilder settings) a <> ")" + OverlayFuncExprCommonSubexpr a -> "OVERLAY (" <> toTextBuilder settings a <> ")" + PositionFuncExprCommonSubexpr a -> "POSITION (" <> foldMap (toTextBuilder settings) a <> ")" + SubstringFuncExprCommonSubexpr a -> "SUBSTRING (" <> foldMap (toTextBuilder settings) a <> ")" + TreatFuncExprCommonSubexpr a b -> "TREAT (" <> toTextBuilder settings a <> " AS " <> toTextBuilder settings b <> ")" + TrimFuncExprCommonSubexpr a b -> "TRIM (" <> TextBuilders.prefixMaybe (toTextBuilder settings) a <> toTextBuilder settings b <> ")" + NullIfFuncExprCommonSubexpr a b -> "NULLIF (" <> toTextBuilder settings a <> ", " <> toTextBuilder settings b <> ")" + CoalesceFuncExprCommonSubexpr a -> "COALESCE (" <> toTextBuilder settings a <> ")" + GreatestFuncExprCommonSubexpr a -> "GREATEST (" <> toTextBuilder settings a <> ")" + LeastFuncExprCommonSubexpr a -> "LEAST (" <> toTextBuilder settings a <> ")" + parser settings = + asum + [ CollationForFuncExprCommonSubexpr <$> Parsers.inParensWithClause (Parsers.keyphrase "collation for") (parser settings), + CurrentDateFuncExprCommonSubexpr <$ Parsers.keyword "current_date", + CurrentTimestampFuncExprCommonSubexpr <$> labeledIconst "current_timestamp", + CurrentTimeFuncExprCommonSubexpr <$> labeledIconst "current_time", + LocalTimestampFuncExprCommonSubexpr <$> labeledIconst "localtimestamp", + LocalTimeFuncExprCommonSubexpr <$> labeledIconst "localtime", + CurrentRoleFuncExprCommonSubexpr <$ Parsers.keyword "current_role", + CurrentUserFuncExprCommonSubexpr <$ Parsers.keyword "current_user", + SessionUserFuncExprCommonSubexpr <$ Parsers.keyword "session_user", + UserFuncExprCommonSubexpr <$ Parsers.keyword "user", + CurrentCatalogFuncExprCommonSubexpr <$ Parsers.keyword "current_catalog", + CurrentSchemaFuncExprCommonSubexpr <$ Parsers.keyword "current_schema", + Parsers.inParensWithClause (Parsers.keyword "cast") (CastFuncExprCommonSubexpr <$> parser settings <*> (Parsers.space1 *> Parsers.keyword "as" *> Parsers.space1 *> parser settings)), + Parsers.inParensWithClause (Parsers.keyword "extract") (ExtractFuncExprCommonSubexpr <$> optional (parser settings)), + Parsers.inParensWithClause (Parsers.keyword "overlay") (OverlayFuncExprCommonSubexpr <$> parser settings), + Parsers.inParensWithClause (Parsers.keyword "position") (PositionFuncExprCommonSubexpr <$> optional (parser settings)), + Parsers.inParensWithClause (Parsers.keyword "substring") (SubstringFuncExprCommonSubexpr <$> optional (parser settings)), + Parsers.inParensWithClause (Parsers.keyword "treat") (TreatFuncExprCommonSubexpr <$> parser settings <*> (Parsers.space1 *> Parsers.keyword "as" *> Parsers.space1 *> parser settings)), + Parsers.inParensWithClause (Parsers.keyword "trim") (TrimFuncExprCommonSubexpr <$> optional (parser settings <* Parsers.space1) <*> parser settings), + Parsers.inParensWithClause (Parsers.keyword "nullif") (NullIfFuncExprCommonSubexpr <$> parser settings <*> (Parsers.commaSeparator *> parser settings)), + Parsers.inParensWithClause (Parsers.keyword "coalesce") (CoalesceFuncExprCommonSubexpr <$> parser settings), + Parsers.inParensWithClause (Parsers.keyword "greatest") (GreatestFuncExprCommonSubexpr <$> parser settings), + Parsers.inParensWithClause (Parsers.keyword "least") (LeastFuncExprCommonSubexpr <$> parser settings) + ] + where + labeledIconst lbl = Parsers.keyword lbl *> Parser.endHead *> optional (Parsers.space *> Parsers.inParens Parsers.decimal) + +instance Qc.Arbitrary FuncExprCommonSubexpr where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then + Qc.oneof + [ pure CurrentDateFuncExprCommonSubexpr, + pure CurrentRoleFuncExprCommonSubexpr, + pure CurrentUserFuncExprCommonSubexpr, + pure SessionUserFuncExprCommonSubexpr, + pure UserFuncExprCommonSubexpr, + pure CurrentCatalogFuncExprCommonSubexpr, + pure CurrentSchemaFuncExprCommonSubexpr + ] + else + Qc.oneof + [ CollationForFuncExprCommonSubexpr <$> Gens.downscale Qc.arbitrary, + pure CurrentDateFuncExprCommonSubexpr, + -- The @Iconst@ here is parsed via 'Parsers.decimal' (unsigned), so + -- it must never be negative — mirroring + -- 'PostgresqlSyntax.Ast.IntervalSecond'\'s own @nonNegative@. + CurrentTimeFuncExprCommonSubexpr <$> nonNegativeMaybeInt64, + CurrentTimestampFuncExprCommonSubexpr <$> nonNegativeMaybeInt64, + LocalTimeFuncExprCommonSubexpr <$> nonNegativeMaybeInt64, + LocalTimestampFuncExprCommonSubexpr <$> nonNegativeMaybeInt64, + pure CurrentRoleFuncExprCommonSubexpr, + pure CurrentUserFuncExprCommonSubexpr, + pure SessionUserFuncExprCommonSubexpr, + pure UserFuncExprCommonSubexpr, + pure CurrentCatalogFuncExprCommonSubexpr, + pure CurrentSchemaFuncExprCommonSubexpr, + CastFuncExprCommonSubexpr <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + ExtractFuncExprCommonSubexpr <$> Qc.arbitrary, + OverlayFuncExprCommonSubexpr <$> Qc.arbitrary, + PositionFuncExprCommonSubexpr <$> Qc.arbitrary, + SubstringFuncExprCommonSubexpr <$> Qc.arbitrary, + TreatFuncExprCommonSubexpr <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + TrimFuncExprCommonSubexpr <$> Qc.arbitrary <*> Qc.arbitrary, + NullIfFuncExprCommonSubexpr <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + CoalesceFuncExprCommonSubexpr <$> Qc.arbitrary, + GreatestFuncExprCommonSubexpr <$> Qc.arbitrary, + LeastFuncExprCommonSubexpr <$> Qc.arbitrary + ] + where + nonNegativeMaybeInt64 = Qc.oneof [pure Nothing, Just <$> nonNegativeInt64] + nonNegativeInt64 = Qc.sized (\n -> Qc.choose (0, cap n)) + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs-boot b/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncExprCommonSubexpr.hs-boot @@ -0,0 +1,19 @@ +module PostgresqlSyntax.Ast.FuncExprCommonSubexpr where + +import PostgresqlSyntax.Algebra (IsAst) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data FuncExprCommonSubexpr + +instance Show FuncExprCommonSubexpr + +instance Eq FuncExprCommonSubexpr + +instance Ord FuncExprCommonSubexpr + +instance Data FuncExprCommonSubexpr + +instance IsAst FuncExprCommonSubexpr + +instance Arbitrary FuncExprCommonSubexpr diff --git a/library-internal/PostgresqlSyntax/Ast/FuncExprWindowless.hs b/library-internal/PostgresqlSyntax/Ast/FuncExprWindowless.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncExprWindowless.hs @@ -0,0 +1,37 @@ +module PostgresqlSyntax.Ast.FuncExprWindowless where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncApplication +import PostgresqlSyntax.Ast.FuncExprCommonSubexpr +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_expr_windowless: +-- | func_application +-- | func_expr_common_subexpr +-- @ +data FuncExprWindowless + = ApplicationFuncExprWindowless FuncApplication + | CommonSubexprFuncExprWindowless FuncExprCommonSubexpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncExprWindowless where + toTextBuilder settings = \case + ApplicationFuncExprWindowless a -> toTextBuilder settings a + CommonSubexprFuncExprWindowless a -> toTextBuilder settings a + parser settings = + asum + [ CommonSubexprFuncExprWindowless <$> parser settings, + ApplicationFuncExprWindowless <$> parser settings + ] + +instance Qc.Arbitrary FuncExprWindowless where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ApplicationFuncExprWindowless <$> Qc.arbitrary, + CommonSubexprFuncExprWindowless <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncName.hs b/library-internal/PostgresqlSyntax/Ast/FuncName.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncName.hs @@ -0,0 +1,60 @@ +module PostgresqlSyntax.Ast.FuncName where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Indirection +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- 'PostgresqlSyntax.Ast.ColId' and 'PostgresqlSyntax.Ast.TypeFunctionName' +-- are both bare aliases to 'Ident', but their /parsers/ (kept in +-- "PostgresqlSyntax.Parsing" since neither is extracted in this batch) are +-- more permissive than plain 'Ident'. Since this module sits below +-- "PostgresqlSyntax.Parsing" (no import cycle allowed), those flavored +-- element parsers are duplicated here, same as 'PostgresqlSyntax.Ast.NameList'. +-- +-- ==== References +-- @ +-- func_name: +-- | type_function_name +-- | ColId indirection +-- @ +data FuncName + = TypeFuncName Ident + | IndirectedFuncName Ident Indirection + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncName where + toTextBuilder settings = \case + TypeFuncName a -> toTextBuilder settings a + IndirectedFuncName a b -> toTextBuilder settings a <> toTextBuilder settings b + parser settings = + IndirectedFuncName + <$> Parser.wrapToHead colIdLikeName + <*> (Parsers.space *> parser settings) + <|> TypeFuncName + <$> typeFunctionNameLikeName + where + colIdLikeName = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + typeFunctionNameLikeName = + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.typeFunctionName + <|> parser settings + +instance Qc.Arbitrary FuncName where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then TypeFuncName <$> Qc.arbitrary + else + Qc.oneof + [ TypeFuncName <$> Qc.arbitrary, + IndirectedFuncName <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/FuncTable.hs b/library-internal/PostgresqlSyntax/Ast/FuncTable.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/FuncTable.hs @@ -0,0 +1,50 @@ +module PostgresqlSyntax.Ast.FuncTable where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncExprWindowless +import PostgresqlSyntax.Ast.OptOrdinality +import PostgresqlSyntax.Ast.RowsfromList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- func_table: +-- | func_expr_windowless opt_ordinality +-- | ROWS FROM '(' rowsfrom_list ')' opt_ordinality +-- @ +data FuncTable + = FuncExprFuncTable FuncExprWindowless OptOrdinality + | RowsFromFuncTable RowsfromList OptOrdinality + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst FuncTable where + toTextBuilder settings = \case + FuncExprFuncTable a (OptOrdinality b) -> toTextBuilder settings a <> bool "" " WITH ORDINALITY" b + RowsFromFuncTable a (OptOrdinality b) -> "ROWS FROM (" <> toTextBuilder settings a <> ")" <> bool "" " WITH ORDINALITY" b + parser settings = + asum + [ do + Parsers.keyword "rows" + Parsers.space1 + Parsers.keyword "from" + Parsers.space + a <- Parsers.inParens (Parser.endHead *> parser settings) + b <- OptOrdinality <$> Parsers.trueIfPresent (Parsers.space *> Parsers.keyword "with" *> Parsers.space1 *> Parsers.keyword "ordinality") + return (RowsFromFuncTable a b), + do + a <- parser settings + b <- OptOrdinality <$> Parsers.trueIfPresent (Parsers.space1 *> Parsers.keyword "with" *> Parsers.space1 *> Parsers.keyword "ordinality") + return (FuncExprFuncTable a b) + ] + +instance Qc.Arbitrary FuncTable where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ FuncExprFuncTable <$> Qc.arbitrary <*> Qc.arbitrary, + RowsFromFuncTable <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/GenericType.hs b/library-internal/PostgresqlSyntax/Ast/GenericType.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/GenericType.hs @@ -0,0 +1,45 @@ +module PostgresqlSyntax.Ast.GenericType where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Attrs +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- GenericType: +-- | type_function_name opt_type_modifiers +-- | type_function_name attrs opt_type_modifiers +-- @ +-- +-- 'PostgresqlSyntax.Ast.TypeFunctionName' is a bare alias to 'Ident', but its +-- /parser/ (kept in "PostgresqlSyntax.Parsing" since @TypeFunctionName@ +-- itself isn't extracted in this batch) is more permissive than plain +-- 'Ident'. Since this module sits below "PostgresqlSyntax.Parsing" (no +-- import cycle allowed), that TypeFunctionName-flavored element parser is +-- duplicated here (mirroring @typeFunctionName@'s definition), same as +-- 'PostgresqlSyntax.Ast.NameList'. +data GenericType = GenericType Ident (Maybe Attrs) (Maybe ExprList) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst GenericType where + toTextBuilder settings (GenericType a b c) = toTextBuilder settings a <> foldMap (toTextBuilder settings) b <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . toTextBuilder settings) c + parser settings = do + a <- typeFunctionNameLikeName + Parser.endHead + b <- optional (Parsers.space *> parser settings) + c <- optional (Parsers.space1 *> Parsers.inParens (parser settings)) + return (GenericType a b c) + where + typeFunctionNameLikeName = Parsers.keywordNameFromSet UnquotedIdent KeywordSet.typeFunctionName <|> parser settings + +instance Qc.Arbitrary GenericType where + shrink = Qc.genericShrink + arbitrary = GenericType <$> arbitrary <*> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/GroupByItem.hs b/library-internal/PostgresqlSyntax/Ast/GroupByItem.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/GroupByItem.hs @@ -0,0 +1,68 @@ +module PostgresqlSyntax.Ast.GroupByItem where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- group_by_item: +-- | a_expr +-- | empty_grouping_set +-- | cube_clause +-- | rollup_clause +-- | grouping_sets_clause +-- empty_grouping_set: +-- | '(' ')' +-- rollup_clause: +-- | ROLLUP '(' expr_list ')' +-- cube_clause: +-- | CUBE '(' expr_list ')' +-- grouping_sets_clause: +-- | GROUPING SETS '(' group_by_list ')' +-- @ +data GroupByItem + = ExprGroupByItem AExpr + | EmptyGroupingSetGroupByItem + | RollupGroupByItem ExprList + | CubeGroupByItem ExprList + | GroupingSetsGroupByItem (NonEmpty GroupByItem) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst GroupByItem where + toTextBuilder settings = \case + ExprGroupByItem a -> toTextBuilder settings a + EmptyGroupingSetGroupByItem -> "()" + RollupGroupByItem a -> "ROLLUP (" <> toTextBuilder settings a <> ")" + CubeGroupByItem a -> "CUBE (" <> toTextBuilder settings a <> ")" + GroupingSetsGroupByItem a -> "GROUPING SETS (" <> TextBuilders.commaNonEmpty (toTextBuilder settings) a <> ")" + parser settings = + asum + [ EmptyGroupingSetGroupByItem <$ (Parsers.char '(' *> Parsers.space *> Parsers.char ')'), + RollupGroupByItem . ExprList <$> (Parsers.keyword "rollup" *> Parser.endHead *> Parsers.space *> Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (parser settings))), + CubeGroupByItem . ExprList <$> (Parsers.keyword "cube" *> Parser.endHead *> Parsers.space *> Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (parser settings))), + GroupingSetsGroupByItem <$> (Parsers.keyphrase "grouping sets" *> Parser.endHead *> Parsers.space *> Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (parser settings))), + ExprGroupByItem <$> parser settings + ] + +instance Qc.Arbitrary GroupByItem where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then Qc.oneof [ExprGroupByItem <$> Gens.downscale Qc.arbitrary, pure EmptyGroupingSetGroupByItem] + else + Qc.oneof + [ ExprGroupByItem <$> Gens.downscale Qc.arbitrary, + pure EmptyGroupingSetGroupByItem, + RollupGroupByItem <$> Qc.arbitrary, + CubeGroupByItem <$> Qc.arbitrary, + GroupingSetsGroupByItem <$> Gens.downscale (Gens.nonEmptyUpTo 2 Qc.arbitrary) + ] diff --git a/library-internal/PostgresqlSyntax/Ast/GroupClause.hs b/library-internal/PostgresqlSyntax/Ast/GroupClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/GroupClause.hs @@ -0,0 +1,35 @@ +module PostgresqlSyntax.Ast.GroupClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.GroupByItem +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- group_clause: +-- | GROUP_P BY set_quantifier group_by_list +-- | /*EMPTY*/ +-- @ +-- +-- @set_quantifier@ (@DISTINCT@\/@ALL@) is not modeled here — this +-- codebase's grammar subset doesn't support @GROUP BY DISTINCT@. +newtype GroupClause = GroupClause (NonEmpty GroupByItem) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst GroupClause where + toTextBuilder settings (GroupClause a) = "GROUP BY " <> TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = do + Parsers.keyphrase "group by" + Parser.endHead + Parsers.space1 + GroupClause <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary GroupClause where + shrink = Qc.genericShrink + arbitrary = GroupClause <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/HavingClause.hs b/library-internal/PostgresqlSyntax/Ast/HavingClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/HavingClause.hs @@ -0,0 +1,31 @@ +module PostgresqlSyntax.Ast.HavingClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- having_clause: +-- | HAVING a_expr +-- | /*EMPTY*/ +-- @ +newtype HavingClause = HavingClause AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst HavingClause where + toTextBuilder settings (HavingClause a) = "HAVING " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "having" + Parser.endHead + Parsers.space1 + HavingClause <$> parser settings + +instance Qc.Arbitrary HavingClause where + shrink = Qc.genericShrink + arbitrary = HavingClause <$> Gens.downscale Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Iconst.hs b/library-internal/PostgresqlSyntax/Ast/Iconst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Iconst.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.Iconst where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- Iconst +-- @ +newtype Iconst = Iconst Int64 + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Iconst where + toTextBuilder _settings (Iconst a) = TextBuilder.int64Dec a + parser _settings = Iconst <$> Parsers.decimal + +instance Qc.Arbitrary Iconst where + shrink = Qc.genericShrink + arbitrary = Iconst <$> Qc.sized (\n -> Qc.choose (0, cap n)) + where + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/Ident.hs b/library-internal/PostgresqlSyntax/Ast/Ident.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Ident.hs @@ -0,0 +1,103 @@ +module PostgresqlSyntax.Ast.Ident where + +import qualified Data.Text as Text +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.Shrinks as Shrinks +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude hiding (filter, try) +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc +import qualified TextBuilder + +-- | +-- ==== References +-- @ +-- IDENT +-- @ +data Ident = QuotedIdent Text | UnquotedIdent Text + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Ident where + toTextBuilder _settings = \case + QuotedIdent a -> TextBuilder.char7 '"' <> TextBuilder.text (Text.replace "\"" "\"\"" a) <> TextBuilder.char7 '"' + UnquotedIdent a -> TextBuilder.text a + parser _settings = quotedName <|> Parsers.keywordNameByPredicate UnquotedIdent (not . Predicate.keyword) + where + quotedName = Parser.filter (const "Empty name") (not . Text.null) (Parsers.quotedString '"') & fmap QuotedIdent + +-- | +-- ==== References +-- @ +-- ColId: +-- | IDENT +-- | unreserved_keyword +-- | col_name_keyword +-- @ +-- +-- Most grammar positions that hold an identifier (column\/table\/alias +-- names, ...) are actually @ColId@, not bare @IDENT@ — this is the +-- permissive variant that most 'Ident'-typed fields elsewhere in +-- "PostgresqlSyntax.Ast" should parse with, since 'Ident'\'s own generic +-- 'parser' only accepts the strict @IDENT@ token (no Parsers.keyword fallback). +colId :: Settings -> Parser Ident +colId settings = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + +-- | +-- ==== References +-- @ +-- ColLabel: +-- | IDENT +-- | unreserved_keyword +-- | col_name_keyword +-- | type_func_name_keyword +-- | reserved_keyword +-- @ +colLabel :: Settings -> Parser Ident +colLabel settings = + Parser.label "column label" $ + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.keyword + <|> parser settings + +-- | +-- ==== References +-- @ +-- type_function_name: +-- | IDENT +-- | unreserved_keyword +-- | type_func_name_keyword +-- @ +typeFunctionName :: Settings -> Parser Ident +typeFunctionName settings = + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.typeFunctionName + <|> parser settings + +instance Qc.Arbitrary Ident where + shrink = \case + QuotedIdent a -> QuotedIdent <$> Shrinks.textTail a + UnquotedIdent a -> UnquotedIdent <$> Shrinks.textTail a + arbitrary = + Qc.frequency + [ (95, UnquotedIdent <$> unquotedIdentText), + (5, QuotedIdent <$> quotedIdentText) + ] + where + unquotedIdentText = + ( do + firstChar <- Qc.elements startChars + restLength <- Qc.choose (0, 29) + rest <- Qc.vectorOf restLength (Qc.elements contChars) + pure (Text.pack (firstChar : rest)) + ) + `Qc.suchThat` (not . Predicate.keyword) + startChars = ['a' .. 'z'] <> ['_'] + contChars = startChars <> ['0' .. '9'] <> ['$'] + quotedIdentText = do + len <- Qc.choose (1, 30) + Text.pack <$> Qc.vectorOf len (Qc.arbitrary `Qc.suchThat` (not . isControl)) diff --git a/library-internal/PostgresqlSyntax/Ast/ImplicitRow.hs b/library-internal/PostgresqlSyntax/Ast/ImplicitRow.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ImplicitRow.hs @@ -0,0 +1,38 @@ +module PostgresqlSyntax.Ast.ImplicitRow where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- implicit_row: +-- | '(' expr_list ',' a_expr ')' +-- @ +data ImplicitRow = ImplicitRow ExprList AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ImplicitRow where + toTextBuilder settings (ImplicitRow a b) = TextBuilders.renderInParens (toTextBuilder settings a <> ", " <> toTextBuilder settings b) + + -- Parses the shared @a_expr@ once and then decides, from what follows, + -- whether it's the sole element of the leading 'ExprList' or the trailing + -- @a_expr@ — see 'PostgresqlSyntax.Extras.NonEmpty.consAndUnsnoc'. + parser settings = Parsers.inParens $ do + a <- Parser.wrapToHead (parser settings) + Parsers.commaSeparator + b <- Parsers.sep1 Parsers.commaSeparator (parser settings) + return $ case NonEmpty.consAndUnsnoc a b of + (c, d) -> ImplicitRow (ExprList c) d + +instance Qc.Arbitrary ImplicitRow where + shrink = Qc.genericShrink + arbitrary = ImplicitRow <$> arbitrary <*> Gens.downscale arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/InExpr.hs b/library-internal/PostgresqlSyntax/Ast/InExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InExpr.hs @@ -0,0 +1,69 @@ +module PostgresqlSyntax.Ast.InExpr + ( InExpr (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc +import qualified Text.Megaparsec as Megaparsec + +-- | +-- ==== References +-- @ +-- in_expr: +-- | select_with_parens +-- | '(' expr_list ')' +-- @ +data InExpr + = SelectInExpr SelectWithParens + | ExprListInExpr ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InExpr where + toTextBuilder settings = \case + SelectInExpr a -> toTextBuilder settings a + ExprListInExpr a -> TextBuilders.renderInParens (toTextBuilder settings a) + parser settings = + (ExprListInExpr <$> Parser.parse (Megaparsec.try (Parser.toParsec (Parsers.inParens (parser settings))))) + <|> (SelectInExpr <$> Parser.wrapToHead (parser settings)) + +instance Qc.Arbitrary InExpr where + shrink = fmap canonicalize . Qc.genericShrink + arbitrary = + canonicalize + <$> Qc.sized + ( \n -> + if n <= 1 + then ExprListInExpr <$> Qc.arbitrary + else + Qc.oneof + [ SelectInExpr <$> Gens.downscale Qc.arbitrary, + ExprListInExpr <$> Qc.arbitrary + ] + ) + +-- | +-- Collapses the non-canonical @SelectInExpr@-of-@WithParensSelectWithParens@ +-- shape to the @ExprListInExpr@ shape the parser actually produces for it: +-- @in_expr@'s two productions, @select_with_parens@ and +-- @'(' expr_list ')'@, overlap whenever the parenthesised select itself +-- contains another parenthesised select, since a single-element +-- @expr_list@ can itself be that inner parenthesised select wrapped as a +-- @c_expr@. Both render to the same text; the parser's @expr_list@ +-- alternative is tried first and so wins. Both 'arbitrary' and 'shrink' +-- can otherwise construct the non-canonical shape, which renders fine but +-- parses back to a different, canonical value and so breaks the +-- roundtrip property. +instance Canonicalizes InExpr where + canonicalize = \case + SelectInExpr a + | Just inner <- project @SelectWithParens a -> + ExprListInExpr (ExprList (embed @SelectWithParens inner :| [])) + other -> other diff --git a/library-internal/PostgresqlSyntax/Ast/IndexElem.hs b/library-internal/PostgresqlSyntax/Ast/IndexElem.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IndexElem.hs @@ -0,0 +1,58 @@ +module PostgresqlSyntax.Ast.IndexElem where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AnyName +import PostgresqlSyntax.Ast.AscDesc +import PostgresqlSyntax.Ast.IndexElemDef +import PostgresqlSyntax.Ast.NullsOrder +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- index_elem: +-- | ColId opt_collate opt_class opt_asc_desc opt_nulls_order +-- | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order +-- | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order +-- @ +-- +-- @opt_collate@\/@opt_class@ are bare aliases to +-- 'PostgresqlSyntax.Ast.AnyName'. +data IndexElem = IndexElem IndexElemDef (Maybe AnyName) (Maybe AnyName) (Maybe AscDesc) (Maybe NullsOrder) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IndexElem where + toTextBuilder settings (IndexElem a b c d e) = + toTextBuilder settings a + <> TextBuilders.suffixMaybe collate b + <> TextBuilders.suffixMaybe (toTextBuilder settings) c + <> TextBuilders.suffixMaybe (toTextBuilder settings) d + <> TextBuilders.suffixMaybe (toTextBuilder settings) e + where + collate = mappend "COLLATE " . toTextBuilder settings + parser settings = + IndexElem + <$> (parser settings <* Parser.endHead) + <*> optional (Parsers.space1 *> collate) + <*> optional (Parsers.space1 *> class_) + <*> optional (Parsers.space1 *> parser settings) + <*> optional (Parsers.space1 *> parser settings) + where + collate = Parsers.keyword "collate" *> Parsers.space1 *> Parser.endHead *> parser settings + + class_ = parser settings + +instance Qc.Arbitrary IndexElem where + shrink = Qc.genericShrink + arbitrary = + IndexElem + <$> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Qc.arbitrary + <*> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/IndexElemDef.hs b/library-internal/PostgresqlSyntax/Ast/IndexElemDef.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IndexElemDef.hs @@ -0,0 +1,46 @@ +module PostgresqlSyntax.Ast.IndexElemDef where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.FuncExprWindowless +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | ColId opt_collate opt_class opt_asc_desc opt_nulls_order +-- | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order +-- | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order +-- @ +data IndexElemDef + = IdIndexElemDef Ident + | FuncIndexElemDef FuncExprWindowless + | ExprIndexElemDef AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IndexElemDef where + toTextBuilder settings = \case + IdIndexElemDef a -> toTextBuilder settings a + FuncIndexElemDef a -> toTextBuilder settings a + ExprIndexElemDef a -> TextBuilders.renderInParens (toTextBuilder settings a) + parser settings = + ExprIndexElemDef + <$> Parsers.inParens (parser settings) + <|> FuncIndexElemDef + <$> parser settings + <|> IdIndexElemDef + <$> colId settings + +instance Qc.Arbitrary IndexElemDef where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ IdIndexElemDef <$> Qc.arbitrary, + FuncIndexElemDef <$> Qc.arbitrary, + ExprIndexElemDef <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/IndexParams.hs b/library-internal/PostgresqlSyntax/Ast/IndexParams.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IndexParams.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.IndexParams where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.IndexElem +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- index_params: +-- | index_elem +-- | index_params ',' index_elem +-- @ +newtype IndexParams = IndexParams (NonEmpty IndexElem) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IndexParams where + toTextBuilder settings (IndexParams a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = IndexParams <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary IndexParams where + shrink = Qc.genericShrink + arbitrary = IndexParams <$> Gens.nonEmptyUpTo 4 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Indirection.hs b/library-internal/PostgresqlSyntax/Ast/Indirection.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Indirection.hs @@ -0,0 +1,26 @@ +module PostgresqlSyntax.Ast.Indirection where + +import Control.Applicative.Combinators.NonEmpty (some) +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.IndirectionEl +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import PostgresqlSyntax.Prelude hiding (some) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- indirection: +-- | indirection_el +-- | indirection indirection_el +-- @ +newtype Indirection = Indirection (NonEmpty IndirectionEl) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Indirection where + toTextBuilder settings (Indirection a) = foldMap (toTextBuilder settings) a + parser settings = Indirection <$> some (parser settings) + +instance Qc.Arbitrary Indirection where + shrink = Qc.genericShrink + arbitrary = Indirection <$> Gens.nonEmptyUpTo 4 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/IndirectionEl.hs b/library-internal/PostgresqlSyntax/Ast/IndirectionEl.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IndirectionEl.hs @@ -0,0 +1,104 @@ +module PostgresqlSyntax.Ast.IndirectionEl where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- 'PostgresqlSyntax.Ast.AttrName' is a bare alias to 'PostgresqlSyntax.Ast.ColLabel', +-- which is a bare alias to 'Ident', but the @ColLabel@ /parser/ (kept in +-- "PostgresqlSyntax.Parsing" since @ColLabel@ itself isn't extracted in this +-- batch) is more permissive than plain 'Ident'. Since this module sits below +-- "PostgresqlSyntax.Parsing" (no import cycle allowed), that ColLabel-flavored +-- element parser is duplicated here, same as 'PostgresqlSyntax.Ast.NameList'. +-- +-- ==== References +-- @ +-- indirection_el: +-- | '.' attr_name +-- | '.' '*' +-- | '[' a_expr ']' +-- | '[' opt_slice_bound ':' opt_slice_bound ']' +-- opt_slice_bound: +-- | a_expr +-- | EMPTY +-- @ +data IndirectionEl + = AttrNameIndirectionEl Ident + | AllIndirectionEl + | ExprIndirectionEl AExpr + | SliceIndirectionEl (Maybe AExpr) (Maybe AExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IndirectionEl where + toTextBuilder settings = \case + AttrNameIndirectionEl a -> "." <> toTextBuilder settings a + AllIndirectionEl -> ".*" + ExprIndirectionEl a -> TextBuilders.renderInBrackets (toTextBuilder settings a) + SliceIndirectionEl a b -> TextBuilders.renderInBrackets (foldMap (toTextBuilder settings) a <> ":" <> foldMap (toTextBuilder settings) b) + parser settings = + asum + [ do + Parsers.char '.' + Parser.endHead + Parsers.space + AllIndirectionEl <$ Parsers.char '*' <|> AttrNameIndirectionEl <$> colLabelLikeName, + do + Parsers.char '[' + Parser.endHead + Parsers.space + a <- + asum + [ do + Parsers.char ':' + Parser.endHead + Parsers.space + b <- optional (parser settings) + return (SliceIndirectionEl Nothing b), + do + a <- parser settings + asum + [ do + Parsers.space + Parsers.char ':' + Parsers.space + b <- optional (parser settings) + return (SliceIndirectionEl (Just a) b), + return (ExprIndirectionEl a) + ] + ] + Parsers.space + Parsers.char ']' + return a + ] + where + colLabelLikeName = + Parser.label "column label" $ + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.keyword + <|> parser settings + +instance Qc.Arbitrary IndirectionEl where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \size -> + if size <= 1 + then + Qc.oneof + [ AttrNameIndirectionEl <$> Qc.arbitrary, + pure AllIndirectionEl, + pure (SliceIndirectionEl Nothing Nothing) + ] + else + Qc.oneof + [ AttrNameIndirectionEl <$> Qc.arbitrary, + pure AllIndirectionEl, + ExprIndirectionEl <$> Gens.downscale Qc.arbitrary, + SliceIndirectionEl <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/InsertColumnItem.hs b/library-internal/PostgresqlSyntax/Ast/InsertColumnItem.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InsertColumnItem.hs @@ -0,0 +1,32 @@ +module PostgresqlSyntax.Ast.InsertColumnItem where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Indirection +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- insert_column_item: +-- | ColId opt_indirection +-- @ +data InsertColumnItem = InsertColumnItem Ident (Maybe Indirection) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InsertColumnItem where + toTextBuilder settings (InsertColumnItem a b) = toTextBuilder settings a <> TextBuilders.suffixMaybe (toTextBuilder settings) b + parser settings = do + a <- colId settings + Parser.endHead + b <- optional (Parsers.space1 *> parser settings) + return (InsertColumnItem a b) + +instance Qc.Arbitrary InsertColumnItem where + shrink = Qc.genericShrink + arbitrary = InsertColumnItem <$> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/InsertColumnList.hs b/library-internal/PostgresqlSyntax/Ast/InsertColumnList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InsertColumnList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.InsertColumnList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.InsertColumnItem +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- insert_column_list: +-- | insert_column_item +-- | insert_column_list ',' insert_column_item +-- @ +newtype InsertColumnList = InsertColumnList (NonEmpty InsertColumnItem) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InsertColumnList where + toTextBuilder settings (InsertColumnList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = InsertColumnList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary InsertColumnList where + shrink = Qc.genericShrink + arbitrary = InsertColumnList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/InsertRest.hs b/library-internal/PostgresqlSyntax/Ast/InsertRest.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InsertRest.hs @@ -0,0 +1,72 @@ +module PostgresqlSyntax.Ast.InsertRest where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.InsertColumnList +import PostgresqlSyntax.Ast.OverrideKind +import PostgresqlSyntax.Ast.SelectStmt +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- insert_rest: +-- | SelectStmt +-- | OVERRIDING override_kind VALUE_P SelectStmt +-- | '(' insert_column_list ')' SelectStmt +-- | '(' insert_column_list ')' OVERRIDING override_kind VALUE_P SelectStmt +-- | DEFAULT VALUES +-- @ +data InsertRest + = SelectInsertRest (Maybe InsertColumnList) (Maybe OverrideKind) SelectStmt + | DefaultValuesInsertRest + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InsertRest where + toTextBuilder settings = \case + SelectInsertRest a b c -> + TextBuilders.optLexemes + [ fmap (TextBuilders.renderInParens . toTextBuilder settings) a, + fmap insertRestOverriding b, + Just (toTextBuilder settings c) + ] + DefaultValuesInsertRest -> "DEFAULT VALUES" + where + insertRestOverriding a = "OVERRIDING " <> toTextBuilder settings a <> " VALUE" + parser settings = + asum + [ DefaultValuesInsertRest <$ (Parsers.keyword "default" *> Parsers.space1 *> Parser.endHead *> Parsers.keyword "values"), + do + -- 'Parser.wrapToHead' makes the whole parenthesized column list + -- (including any 'Parser.endHead' calls inside 'InsertColumnItem') + -- backtrackable as one unit. Without it, parsing e.g. @(VALUES ...)@ + -- would commit to treating @VALUES@ as a single-column + -- 'InsertColumnList' entry (since it's a valid 'ColId') right after + -- reading it, and fail instead of backtracking into the correct + -- 'SelectStmt' (@select_with_parens@ wrapping a bare @VALUES@ + -- clause) parse below. See gram.y's @insert_rest@. + a <- optional (Parser.wrapToHead (Parsers.inParens (parser settings) <* Parsers.space1)) + b <- optional $ do + Parsers.keyword "overriding" + Parsers.space1 + Parser.endHead + b <- parser settings + Parsers.space1 + Parsers.keyword "value" + Parsers.space1 + return b + c <- parser settings + return (SelectInsertRest a b c) + ] + +instance Qc.Arbitrary InsertRest where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ SelectInsertRest <$> Gens.terminatingMaybe Qc.arbitrary <*> Qc.arbitrary <*> Qc.arbitrary, + pure DefaultValuesInsertRest + ] diff --git a/library-internal/PostgresqlSyntax/Ast/InsertStmt.hs b/library-internal/PostgresqlSyntax/Ast/InsertStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InsertStmt.hs @@ -0,0 +1,57 @@ +module PostgresqlSyntax.Ast.InsertStmt where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.InsertRest +import PostgresqlSyntax.Ast.InsertTarget +import PostgresqlSyntax.Ast.OnConflict +import PostgresqlSyntax.Ast.ReturningClause +import {-# SOURCE #-} PostgresqlSyntax.Ast.WithClause (WithClause) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- InsertStmt: +-- | opt_with_clause INSERT INTO insert_target insert_rest +-- opt_on_conflict returning_clause +-- @ +data InsertStmt = InsertStmt (Maybe WithClause) InsertTarget InsertRest (Maybe OnConflict) (Maybe ReturningClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InsertStmt where + toTextBuilder settings (InsertStmt a b c d e) = + TextBuilders.prefixMaybe (toTextBuilder settings) a + <> "INSERT INTO " + <> toTextBuilder settings b + <> " " + <> toTextBuilder settings c + <> TextBuilders.suffixMaybe (toTextBuilder settings) d + <> TextBuilders.suffixMaybe (toTextBuilder settings) e + parser settings = do + a <- optional (Parser.wrapToHead (parser settings) <* Parsers.space1) + Parsers.keyword "insert" + Parsers.space1 + Parser.endHead + Parsers.keyword "into" + Parsers.space1 + b <- parser settings + Parsers.space1 + c <- parser settings + d <- optional (Parsers.space1 *> parser settings) + e <- optional (Parsers.space1 *> parser settings) + return (InsertStmt a b c d e) + +instance Qc.Arbitrary InsertStmt where + shrink = Qc.genericShrink + arbitrary = + InsertStmt + <$> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) + <*> Qc.arbitrary + <*> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/InsertTarget.hs b/library-internal/PostgresqlSyntax/Ast/InsertTarget.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/InsertTarget.hs @@ -0,0 +1,31 @@ +module PostgresqlSyntax.Ast.InsertTarget where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.QualifiedName +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- insert_target: +-- | qualified_name +-- | qualified_name AS ColId +-- @ +data InsertTarget = InsertTarget QualifiedName (Maybe Ident) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst InsertTarget where + toTextBuilder settings (InsertTarget a b) = toTextBuilder settings a <> foldMap (mappend " AS " . toTextBuilder settings) b + parser settings = do + a <- parser settings + Parser.endHead + b <- optional (Parsers.space1 *> Parsers.keyword "as" *> Parsers.space1 *> Parser.endHead *> colId settings) + return (InsertTarget a b) + +instance Qc.Arbitrary InsertTarget where + shrink = Qc.genericShrink + arbitrary = InsertTarget <$> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Interval.hs b/library-internal/PostgresqlSyntax/Ast/Interval.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Interval.hs @@ -0,0 +1,94 @@ +module PostgresqlSyntax.Ast.Interval where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.IntervalSecond +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_interval: +-- | YEAR_P +-- | MONTH_P +-- | DAY_P +-- | HOUR_P +-- | MINUTE_P +-- | interval_second +-- | YEAR_P TO MONTH_P +-- | DAY_P TO HOUR_P +-- | DAY_P TO MINUTE_P +-- | DAY_P TO interval_second +-- | HOUR_P TO MINUTE_P +-- | HOUR_P TO interval_second +-- | MINUTE_P TO interval_second +-- | EMPTY +-- @ +data Interval + = YearInterval + | MonthInterval + | DayInterval + | HourInterval + | MinuteInterval + | SecondInterval IntervalSecond + | YearToMonthInterval + | DayToHourInterval + | DayToMinuteInterval + | DayToSecondInterval IntervalSecond + | HourToMinuteInterval + | HourToSecondInterval IntervalSecond + | MinuteToSecondInterval IntervalSecond + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Interval where + toTextBuilder settings = \case + YearInterval -> "YEAR" + MonthInterval -> "MONTH" + DayInterval -> "DAY" + HourInterval -> "HOUR" + MinuteInterval -> "MINUTE" + SecondInterval a -> toTextBuilder settings a + YearToMonthInterval -> "YEAR TO MONTH" + DayToHourInterval -> "DAY TO HOUR" + DayToMinuteInterval -> "DAY TO MINUTE" + DayToSecondInterval a -> "DAY TO " <> toTextBuilder settings a + HourToMinuteInterval -> "HOUR TO MINUTE" + HourToSecondInterval a -> "HOUR TO " <> toTextBuilder settings a + MinuteToSecondInterval a -> "MINUTE TO " <> toTextBuilder settings a + parser settings = + asum + [ YearToMonthInterval <$ Parsers.keyphrase "year to month", + DayToHourInterval <$ Parsers.keyphrase "day to hour", + DayToMinuteInterval <$ Parsers.keyphrase "day to minute", + DayToSecondInterval <$> (Parsers.keyphrase "day to" *> Parsers.space1 *> Parser.endHead *> parser settings), + HourToMinuteInterval <$ Parsers.keyphrase "hour to minute", + HourToSecondInterval <$> (Parsers.keyphrase "hour to" *> Parsers.space1 *> Parser.endHead *> parser settings), + MinuteToSecondInterval <$> (Parsers.keyphrase "minute to" *> Parsers.space1 *> Parser.endHead *> parser settings), + YearInterval <$ Parsers.keyword "year", + MonthInterval <$ Parsers.keyword "month", + DayInterval <$ Parsers.keyword "day", + HourInterval <$ Parsers.keyword "hour", + MinuteInterval <$ Parsers.keyword "minute", + SecondInterval <$> parser settings + ] + +instance Qc.Arbitrary Interval where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ pure YearInterval, + pure MonthInterval, + pure DayInterval, + pure HourInterval, + pure MinuteInterval, + SecondInterval <$> Qc.arbitrary, + pure YearToMonthInterval, + pure DayToHourInterval, + pure DayToMinuteInterval, + DayToSecondInterval <$> Qc.arbitrary, + pure HourToMinuteInterval, + HourToSecondInterval <$> Qc.arbitrary, + MinuteToSecondInterval <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/IntervalSecond.hs b/library-internal/PostgresqlSyntax/Ast/IntervalSecond.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IntervalSecond.hs @@ -0,0 +1,36 @@ +module PostgresqlSyntax.Ast.IntervalSecond where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- interval_second: +-- | SECOND_P +-- | SECOND_P '(' Iconst ')' +-- @ +newtype IntervalSecond = IntervalSecond (Maybe Int64) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IntervalSecond where + toTextBuilder _settings (IntervalSecond a) = case a of + Nothing -> "SECOND" + Just a' -> "SECOND " <> TextBuilders.renderInParens (TextBuilder.int64Dec a') + parser _settings = do + Parsers.keyword "second" + a <- optional (Parsers.space *> Parsers.inParens Parsers.decimal) + return (IntervalSecond a) + +instance Qc.Arbitrary IntervalSecond where + shrink = Qc.genericShrink + arbitrary = IntervalSecond <$> Qc.oneof [pure Nothing, Just <$> nonNegative] + where + nonNegative = Qc.sized (\n -> Qc.choose (0, cap n)) + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/IntoClause.hs b/library-internal/PostgresqlSyntax/Ast/IntoClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/IntoClause.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.IntoClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.OptTempTableName +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- into_clause: +-- | INTO OptTempTableName +-- | /*EMPTY*/ +-- @ +newtype IntoClause = IntoClause OptTempTableName + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst IntoClause where + toTextBuilder settings (IntoClause a) = "INTO " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "into" + Parser.endHead + Parsers.space1 + IntoClause <$> parser settings + +instance Qc.Arbitrary IntoClause where + shrink = Qc.genericShrink + arbitrary = IntoClause <$> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/JoinQual.hs b/library-internal/PostgresqlSyntax/Ast/JoinQual.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/JoinQual.hs @@ -0,0 +1,40 @@ +module PostgresqlSyntax.Ast.JoinQual where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- join_qual: +-- | USING '(' name_list ')' +-- | ON a_expr +-- @ +data JoinQual + = UsingJoinQual (NonEmpty Ident) + | OnJoinQual AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst JoinQual where + toTextBuilder settings = \case + UsingJoinQual a -> "USING (" <> TextBuilders.commaNonEmpty (toTextBuilder settings) a <> ")" + OnJoinQual a -> "ON " <> toTextBuilder settings a + parser settings = + asum + [ Parsers.keyword "using" *> Parsers.space1 *> Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (colId settings)) <&> UsingJoinQual, + Parsers.keyword "on" *> Parsers.space1 *> parser settings <&> OnJoinQual + ] + +instance Qc.Arbitrary JoinQual where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ UsingJoinQual <$> Gens.nonEmptyUpTo 7 Qc.arbitrary, + OnJoinQual <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/JoinType.hs b/library-internal/PostgresqlSyntax/Ast/JoinType.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/JoinType.hs @@ -0,0 +1,60 @@ +module PostgresqlSyntax.Ast.JoinType where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | FULL join_outer +-- | LEFT join_outer +-- | RIGHT join_outer +-- | INNER_P +-- @ +data JoinType + = FullJoinType Bool + | LeftJoinType Bool + | RightJoinType Bool + | InnerJoinType + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst JoinType where + toTextBuilder _settings = \case + FullJoinType a -> "FULL" <> if a then " OUTER" else "" + LeftJoinType a -> "LEFT" <> if a then " OUTER" else "" + RightJoinType a -> "RIGHT" <> if a then " OUTER" else "" + InnerJoinType -> "INNER" + parser _settings = + asum + [ do + Parsers.keyword "full" + Parser.endHead + outer <- outerAfterSpace + return (FullJoinType outer), + do + Parsers.keyword "left" + Parser.endHead + outer <- outerAfterSpace + return (LeftJoinType outer), + do + Parsers.keyword "right" + Parser.endHead + outer <- outerAfterSpace + return (RightJoinType outer), + Parsers.keyword "inner" $> InnerJoinType + ] + where + outerAfterSpace = (Parsers.space1 *> Parsers.keyword "outer") $> True <|> pure False + +instance Qc.Arbitrary JoinType where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ FullJoinType <$> Qc.arbitrary, + LeftJoinType <$> Qc.arbitrary, + RightJoinType <$> Qc.arbitrary, + pure InnerJoinType + ] diff --git a/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs b/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs @@ -0,0 +1,141 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module PostgresqlSyntax.Ast.JoinedTable + ( JoinedTable (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.JoinQual +import PostgresqlSyntax.Ast.JoinType +import {-# SOURCE #-} PostgresqlSyntax.Ast.TableRef (TableRef) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | '(' joined_table ')' +-- | table_ref CROSS JOIN table_ref +-- | table_ref join_type JOIN table_ref join_qual +-- | table_ref JOIN table_ref join_qual +-- | table_ref NATURAL join_type JOIN table_ref +-- | table_ref NATURAL JOIN table_ref +-- @ +data JoinedTable + = InParensJoinedTable JoinedTable + | CrossJoinedTable TableRef TableRef + | QualJoinedTable TableRef (Maybe JoinType) TableRef JoinQual + | NaturalJoinedTable TableRef (Maybe JoinType) TableRef + deriving (Show, Generic, Eq, Ord, Data) + +-- | +-- Parsing delegates to 'parseExtended' over the 'Extends' instance +-- below — a bare @table_ref@ parse is greedy, absorbing any trailing @CROSS +-- JOIN@\/@JOIN@\/@NATURAL JOIN@ continuation into itself, so a +-- @joined_table@ is never reachable as a bare, zero-extension 'TableRef'; +-- it always needs at least one. Failing that, the only remaining +-- @joined_table@ production is the non-left-recursive 'parseBase'. +instance IsAst JoinedTable where + toTextBuilder settings = \case + InParensJoinedTable a -> TextBuilders.renderInParens (toTextBuilder settings a) + CrossJoinedTable a b -> toTextBuilder settings a <> " CROSS JOIN " <> toTextBuilder settings b + QualJoinedTable a b c d -> toTextBuilder settings a <> TextBuilders.suffixMaybe (toTextBuilder settings) b <> " JOIN " <> toTextBuilder settings c <> " " <> toTextBuilder settings d + NaturalJoinedTable a b c -> toTextBuilder settings a <> " NATURAL" <> TextBuilders.suffixMaybe (toTextBuilder settings) b <> " JOIN " <> toTextBuilder settings c + + parser settings = parseExtended @TableRef settings <|> parseBase settings + +-- | +-- The one @joined_table@ production that doesn't begin with a +-- left-recursive @table_ref@: +-- +-- @ +-- | '(' joined_table ')' +-- @ +-- +-- It still recurses — just not on the left, since the opening parenthesis +-- has to be consumed first. "PostgresqlSyntax.Ast.TableRef" reaches it +-- through this class method, which is why 'JoinedTable' needs no helper +-- export. +instance LeftRecursive JoinedTable where + parseBase settings = InParensJoinedTable <$> Parsers.inParens (parser settings) + +instance Qc.Arbitrary JoinedTable where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then joined + else Qc.oneof [InParensJoinedTable <$> Gens.downscale Qc.arbitrary, joined] + where + joined = + Qc.oneof + [ CrossJoinedTable <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + QualJoinedTable <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + NaturalJoinedTable <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] + +-- | +-- The left-recursion-eliminated form of @table_ref@\/@joined_table@: a +-- 'TableRef' is the non-recursive base (@β@, its own 'parseBase'). All +-- three join kinds sit at the same precedence (@%left JOIN CROSS LEFT FULL +-- RIGHT INNER_P NATURAL@ in @gram.y@), and there's nothing to hold between +-- parsing a join and applying it, so no item type is warranted here — +-- unlike "PostgresqlSyntax.Ast.SimpleSelect", this hub isn't collect-then-fold. +instance Extends TableRef JoinedTable where + -- ==== References + -- @ + -- | table_ref CROSS JOIN table_ref + -- | table_ref join_type JOIN table_ref join_qual + -- | table_ref JOIN table_ref join_qual + -- | table_ref NATURAL join_type JOIN table_ref + -- | table_ref NATURAL JOIN table_ref + -- @ + -- + -- Parses one join onto 'tr1', then recurses with the built 'JoinedTable' + -- (embedded back to 'TableRef') as the new left operand, falling back to + -- what's already built when no further join follows. The + -- 'Parser.wrapToHead'\/'Parser.endHead' pair around the single join + -- mirrors 'PostgresqlSyntax.Algebra.parseExtensionChain'\'s per-item + -- protocol, since this recursive shape can't build on that combinator + -- directly. + parseExtensions settings tr1 = do + built <- Parser.wrapToHead parseOneJoin + Parser.endHead + optional (parseExtensions @TableRef settings (embed built)) >>= pure . maybe built id + where + parseOneJoin = + Parsers.space1 + *> asum + [ do + Parsers.keyphrase "cross join" + Parser.endHead + Parsers.space1 + tr2 <- parseBase @TableRef settings + return (CrossJoinedTable tr1 tr2), + do + jt <- joinTypedJoin + Parser.endHead + Parsers.space1 + tr2 <- parser settings + Parsers.space1 + jq <- parser settings + return (QualJoinedTable tr1 jt tr2 jq), + do + Parsers.keyword "natural" + Parser.endHead + Parsers.space1 + jt <- joinTypedJoin + Parsers.space1 + tr2 <- parseBase @TableRef settings + return (NaturalJoinedTable tr1 jt tr2) + ] + joinTypedJoin = + Just + <$> (parser settings <* Parser.endHead <* Parsers.space1 <* Parsers.keyword "join") + <|> Nothing + <$ Parsers.keyword "join" diff --git a/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs-boot b/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/JoinedTable.hs-boot @@ -0,0 +1,3 @@ +module PostgresqlSyntax.Ast.JoinedTable where + +data JoinedTable diff --git a/library-internal/PostgresqlSyntax/Ast/LimitClause.hs b/library-internal/PostgresqlSyntax/Ast/LimitClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/LimitClause.hs @@ -0,0 +1,100 @@ +module PostgresqlSyntax.Ast.LimitClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.SelectFetchFirstValue +import PostgresqlSyntax.Ast.SelectLimitValue +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- limit_clause: +-- | LIMIT select_limit_value +-- | LIMIT select_limit_value ',' select_offset_value +-- | FETCH first_or_next select_fetch_first_value row_or_rows ONLY +-- | FETCH first_or_next row_or_rows ONLY +-- select_offset_value: +-- | a_expr +-- first_or_next: +-- | FIRST_P +-- | NEXT +-- row_or_rows: +-- | ROW +-- | ROWS +-- @ +data LimitClause + = LimitLimitClause SelectLimitValue (Maybe AExpr) + | FetchOnlyLimitClause Bool (Maybe SelectFetchFirstValue) Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst LimitClause where + toTextBuilder settings = \case + LimitLimitClause a b -> "LIMIT " <> toTextBuilder settings a <> foldMap (mappend ", " . toTextBuilder settings) b + FetchOnlyLimitClause a b c -> + TextBuilders.optLexemes + [ Just "FETCH", + Just (firstOrNext a), + fmap (toTextBuilder settings) b, + Just (rowOrRows c), + Just "ONLY" + ] + where + firstOrNext = bool "FIRST" "NEXT" + rowOrRows = bool "ROW" "ROWS" + parser settings = + ( do + Parsers.keyword "limit" + Parser.endHead + Parsers.space1 + a <- parser settings + b <- optional $ do + Parsers.commaSeparator + parser settings + return (LimitLimitClause a b) + ) + <|> ( do + Parsers.keyword "fetch" + Parser.endHead + Parsers.space1 + a <- firstOrNext + Parsers.space1 + asum + [ do + b <- rowOrRows + Parsers.space1 + Parsers.keyword "only" + return (FetchOnlyLimitClause a Nothing b), + do + b <- parser settings + Parsers.space1 + c <- rowOrRows + Parsers.space1 + Parsers.keyword "only" + return (FetchOnlyLimitClause a (Just b) c) + ] + ) + where + firstOrNext = + False + <$ Parsers.keyword "first" + <|> True + <$ Parsers.keyword "next" + rowOrRows = + True + <$ Parsers.keyword "rows" + <|> False + <$ Parsers.keyword "row" + +instance Qc.Arbitrary LimitClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ LimitLimitClause <$> Qc.arbitrary <*> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary), + FetchOnlyLimitClause <$> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/MathOp.hs b/library-internal/PostgresqlSyntax/Ast/MathOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/MathOp.hs @@ -0,0 +1,76 @@ +module PostgresqlSyntax.Ast.MathOp where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- MathOp: +-- | '+' +-- | '-' +-- | '*' +-- | '/' +-- | '%' +-- | '^' +-- | '<' +-- | '>' +-- | '=' +-- | LESS_EQUALS +-- | GREATER_EQUALS +-- | NOT_EQUALS +-- @ +data MathOp + = PlusMathOp + | MinusMathOp + | AsteriskMathOp + | SlashMathOp + | PercentMathOp + | ArrowUpMathOp + | ArrowLeftMathOp + | ArrowRightMathOp + | EqualsMathOp + | LessEqualsMathOp + | GreaterEqualsMathOp + | ArrowLeftArrowRightMathOp + | ExclamationEqualsMathOp + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst MathOp where + toTextBuilder _settings = \case + PlusMathOp -> TextBuilder.char7 '+' + MinusMathOp -> TextBuilder.char7 '-' + AsteriskMathOp -> TextBuilder.char7 '*' + SlashMathOp -> TextBuilder.char7 '/' + PercentMathOp -> TextBuilder.char7 '%' + ArrowUpMathOp -> TextBuilder.char7 '^' + ArrowLeftMathOp -> TextBuilder.char7 '<' + ArrowRightMathOp -> TextBuilder.char7 '>' + EqualsMathOp -> TextBuilder.char7 '=' + LessEqualsMathOp -> "<=" + GreaterEqualsMathOp -> ">=" + ArrowLeftArrowRightMathOp -> "<>" + ExclamationEqualsMathOp -> "!=" + parser _settings = + asum + [ ArrowLeftArrowRightMathOp <$ Parsers.string' "<>", + GreaterEqualsMathOp <$ Parsers.string' ">=", + ExclamationEqualsMathOp <$ Parsers.string' "!=", + LessEqualsMathOp <$ Parsers.string' "<=", + PlusMathOp <$ Parsers.char '+', + MinusMathOp <$ Parsers.char '-', + AsteriskMathOp <$ Parsers.char '*', + SlashMathOp <$ Parsers.char '/', + PercentMathOp <$ Parsers.char '%', + ArrowUpMathOp <$ Parsers.char '^', + ArrowLeftMathOp <$ Parsers.char '<', + ArrowRightMathOp <$ Parsers.char '>', + EqualsMathOp <$ Parsers.char '=' + ] + +instance Qc.Arbitrary MathOp where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/NameList.hs b/library-internal/PostgresqlSyntax/Ast/NameList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/NameList.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.NameList where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- name_list: +-- | name +-- | name_list ',' name +-- @ +-- +-- 'Name' is a bare alias to 'PostgresqlSyntax.Ast.ColId' which is a bare +-- alias to 'Ident', but the @ColId@ /parser/ (kept in "PostgresqlSyntax.Parsing" +-- since @ColId@ itself isn't extracted in this batch) is more permissive +-- than plain 'Ident': it additionally accepts the @unreserved_keyword@ and +-- @col_name_keyword@ lexical classes as identifiers. Since this module sits +-- below "PostgresqlSyntax.Parsing" (no import cycle allowed), that +-- ColId-flavored element parser is duplicated here (mirroring @colId@'s +-- definition) rather than reused, to preserve exact parsing behavior. +newtype NameList = NameList (NonEmpty Ident) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst NameList where + toTextBuilder settings (NameList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = NameList <$> Parsers.sep1 Parsers.commaSeparator colIdLikeName + where + colIdLikeName = + Parser.label "identifier" $ + parser settings + <|> Parsers.keywordNameFromSet UnquotedIdent (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) + +instance Qc.Arbitrary NameList where + shrink = Qc.genericShrink + arbitrary = NameList <$> Gens.nonEmptyUpTo 7 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/NullsOrder.hs b/library-internal/PostgresqlSyntax/Ast/NullsOrder.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/NullsOrder.hs @@ -0,0 +1,28 @@ +module PostgresqlSyntax.Ast.NullsOrder where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_nulls_order: +-- | NULLS_LA FIRST_P +-- | NULLS_LA LAST_P +-- | EMPTY +-- @ +data NullsOrder = FirstNullsOrder | LastNullsOrder + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst NullsOrder where + toTextBuilder _settings = \case + FirstNullsOrder -> "NULLS FIRST" + LastNullsOrder -> "NULLS LAST" + parser _settings = Parsers.keyword "nulls" *> Parsers.space1 *> Parser.endHead *> (FirstNullsOrder <$ Parsers.keyword "first" <|> LastNullsOrder <$ Parsers.keyword "last") + +instance Qc.Arbitrary NullsOrder where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/Numeric.hs b/library-internal/PostgresqlSyntax/Ast/Numeric.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Numeric.hs @@ -0,0 +1,99 @@ +module PostgresqlSyntax.Ast.Numeric where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- Numeric: +-- | INT_P +-- | INTEGER +-- | SMALLINT +-- | BIGINT +-- | REAL +-- | FLOAT_P opt_float +-- | DOUBLE_P PRECISION +-- | DECIMAL_P opt_type_modifiers +-- | DEC opt_type_modifiers +-- | NUMERIC opt_type_modifiers +-- | BOOLEAN_P +-- opt_float: +-- | '(' Iconst ')' +-- | EMPTY +-- opt_type_modifiers: +-- | '(' expr_list ')' +-- | EMPTY +-- @ +data Numeric + = IntNumeric + | IntegerNumeric + | SmallintNumeric + | BigintNumeric + | RealNumeric + | FloatNumeric (Maybe Int64) + | DoublePrecisionNumeric + | DecimalNumeric (Maybe ExprList) + | DecNumeric (Maybe ExprList) + | NumericNumeric (Maybe ExprList) + | BooleanNumeric + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Numeric where + toTextBuilder settings = \case + IntNumeric -> "INT" + IntegerNumeric -> "INTEGER" + SmallintNumeric -> "SMALLINT" + BigintNumeric -> "BIGINT" + RealNumeric -> "REAL" + FloatNumeric a -> "FLOAT" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . TextBuilder.int64Dec) a + DoublePrecisionNumeric -> "DOUBLE PRECISION" + DecimalNumeric a -> "DECIMAL" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . toTextBuilder settings) a + DecNumeric a -> "DEC" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . toTextBuilder settings) a + NumericNumeric a -> "NUMERIC" <> TextBuilders.suffixMaybe (TextBuilders.renderInParens . toTextBuilder settings) a + BooleanNumeric -> "BOOLEAN" + parser settings = + asum + [ IntegerNumeric <$ Parsers.keyword "integer", + IntNumeric <$ Parsers.keyword "int", + SmallintNumeric <$ Parsers.keyword "smallint", + BigintNumeric <$ Parsers.keyword "bigint", + RealNumeric <$ Parsers.keyword "real", + FloatNumeric <$> (Parsers.keyword "float" *> Parser.endHead *> optional (Parsers.space *> Parsers.inParens Parsers.decimal)), + DoublePrecisionNumeric <$ Parsers.keyphrase "double precision", + DecimalNumeric <$> (Parsers.keyword "decimal" *> Parser.endHead *> optional (Parsers.space *> Parsers.inParens (parser settings))), + DecNumeric <$> (Parsers.keyword "dec" *> Parser.endHead *> optional (Parsers.space *> Parsers.inParens (parser settings))), + NumericNumeric <$> (Parsers.keyword "numeric" *> Parser.endHead *> optional (Parsers.space *> Parsers.inParens (parser settings))), + BooleanNumeric <$ Parsers.keyword "boolean" + ] + +instance Qc.Arbitrary Numeric where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ pure IntNumeric, + pure IntegerNumeric, + pure SmallintNumeric, + pure BigintNumeric, + pure RealNumeric, + -- The @Iconst@ here is parsed via 'Parsers.decimal' (unsigned), so, + -- unlike a plain 'Int64', it must never be negative — mirroring + -- 'PostgresqlSyntax.Ast.IntervalSecond'\'s own @nonNegative@. + FloatNumeric <$> Qc.oneof [pure Nothing, Just <$> nonNegativeInt64], + pure DoublePrecisionNumeric, + DecimalNumeric <$> Qc.arbitrary, + DecNumeric <$> Qc.arbitrary, + NumericNumeric <$> Qc.arbitrary, + pure BooleanNumeric + ] + where + nonNegativeInt64 = Qc.sized (\n -> Qc.choose (0, cap n)) + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/OffsetClause.hs b/library-internal/PostgresqlSyntax/Ast/OffsetClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OffsetClause.hs @@ -0,0 +1,56 @@ +module PostgresqlSyntax.Ast.OffsetClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.SelectFetchFirstValue +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- offset_clause: +-- | OFFSET select_offset_value +-- | OFFSET select_fetch_first_value row_or_rows +-- select_offset_value: +-- | a_expr +-- row_or_rows: +-- | ROW +-- | ROWS +-- @ +data OffsetClause + = ExprOffsetClause AExpr + | FetchFirstOffsetClause SelectFetchFirstValue Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OffsetClause where + toTextBuilder settings = \case + ExprOffsetClause a -> "OFFSET " <> toTextBuilder settings a + FetchFirstOffsetClause a b -> "OFFSET " <> toTextBuilder settings a <> " " <> rowOrRows b + where + rowOrRows = bool "ROW" "ROWS" + parser settings = do + Parsers.keyword "offset" + Parser.endHead + Parsers.space1 + asum + [ FetchFirstOffsetClause <$> Parser.wrapToHead (parser settings) <*> (Parsers.space1 *> rowOrRows), + ExprOffsetClause <$> parser settings + ] + where + rowOrRows = + True + <$ Parsers.keyword "rows" + <|> False + <$ Parsers.keyword "row" + +instance Qc.Arbitrary OffsetClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprOffsetClause <$> Gens.downscale Qc.arbitrary, + FetchFirstOffsetClause <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/OnConflict.hs b/library-internal/PostgresqlSyntax/Ast/OnConflict.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OnConflict.hs @@ -0,0 +1,40 @@ +module PostgresqlSyntax.Ast.OnConflict where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ConfExpr +import PostgresqlSyntax.Ast.OnConflictDo +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_on_conflict: +-- | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause +-- | ON CONFLICT opt_conf_expr DO NOTHING +-- | EMPTY +-- @ +data OnConflict = OnConflict (Maybe ConfExpr) OnConflictDo + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OnConflict where + toTextBuilder settings (OnConflict a b) = "ON CONFLICT" <> TextBuilders.suffixMaybe (toTextBuilder settings) a <> " DO " <> toTextBuilder settings b + parser settings = do + Parsers.keyword "on" + Parsers.space1 + Parsers.keyword "conflict" + Parsers.space1 + Parser.endHead + a <- optional (parser settings <* Parsers.space1) + Parsers.keyword "do" + Parsers.space1 + b <- parser settings + return (OnConflict a b) + +instance Qc.Arbitrary OnConflict where + shrink = Qc.genericShrink + arbitrary = OnConflict <$> Gens.terminatingMaybe arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/OnConflictDo.hs b/library-internal/PostgresqlSyntax/Ast/OnConflictDo.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OnConflictDo.hs @@ -0,0 +1,57 @@ +module PostgresqlSyntax.Ast.OnConflictDo where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.SetClauseList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_on_conflict: +-- | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause +-- | ON CONFLICT opt_conf_expr DO NOTHING +-- | EMPTY +-- @ +-- +-- @where_clause@ is inlined here as a bare 'PostgresqlSyntax.Ast.AExpr' +-- rather than going through 'PostgresqlSyntax.Ast.WhereClause'. +data OnConflictDo + = UpdateOnConflictDo SetClauseList (Maybe AExpr) + | NothingOnConflictDo + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OnConflictDo where + toTextBuilder settings = \case + UpdateOnConflictDo a b -> "UPDATE SET " <> toTextBuilder settings a <> TextBuilders.suffixMaybe whereClause b + NothingOnConflictDo -> "NOTHING" + where + whereClause a = "WHERE " <> toTextBuilder settings a + parser settings = + asum + [ NothingOnConflictDo <$ Parsers.keyword "nothing", + do + Parsers.keyword "update" + Parsers.space1 + Parser.endHead + Parsers.keyword "set" + Parsers.space1 + a <- parser settings + b <- optional (Parsers.space1 *> whereClause) + return (UpdateOnConflictDo a b) + ] + where + whereClause = Parsers.keyword "where" *> Parsers.space1 *> Parser.endHead *> parser settings + +instance Qc.Arbitrary OnConflictDo where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ UpdateOnConflictDo <$> Qc.arbitrary <*> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary), + pure NothingOnConflictDo + ] diff --git a/library-internal/PostgresqlSyntax/Ast/Op.hs b/library-internal/PostgresqlSyntax/Ast/Op.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Op.hs @@ -0,0 +1,36 @@ +module PostgresqlSyntax.Ast.Op where + +import qualified Data.Text as Text +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.Shrinks as Shrinks +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude +import qualified PostgresqlSyntax.Validation as Validation +import qualified Test.QuickCheck as Qc +import qualified TextBuilder + +-- | +-- ==== References +-- @ +-- Op +-- @ +newtype Op = Op Text + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Op where + toTextBuilder _settings (Op a) = TextBuilder.text a + parser _settings = do + a <- Parsers.takeWhile1P Nothing Predicate.opChar + case Validation.op a of + Nothing -> return (Op a) + Just err -> fail (Text.unpack err) + +instance Qc.Arbitrary Op where + shrink (Op a) = Op <$> filter (isNothing . Validation.op) (Shrinks.nonEmptyText a) + arbitrary = Op <$> genOpText `Qc.suchThat` (isNothing . Validation.op) + where + genOpText = do + len <- Qc.choose (1, 7) + Text.pack <$> Qc.vectorOf len (Qc.elements opChars) + opChars = "+-*/<>=~!@#%^&|`?" diff --git a/library-internal/PostgresqlSyntax/Ast/OptOrdinality.hs b/library-internal/PostgresqlSyntax/Ast/OptOrdinality.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OptOrdinality.hs @@ -0,0 +1,24 @@ +module PostgresqlSyntax.Ast.OptOrdinality where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_ordinality: +-- | WITH_LA ORDINALITY +-- | EMPTY +-- @ +newtype OptOrdinality = OptOrdinality Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OptOrdinality where + toTextBuilder _settings (OptOrdinality a) = if a then "WITH ORDINALITY" else mempty + parser _settings = OptOrdinality <$> Parsers.trueIfPresent (Parsers.keyword "with" *> Parsers.space1 *> Parsers.keyword "ordinality") + +instance Qc.Arbitrary OptOrdinality where + shrink = Qc.genericShrink + arbitrary = OptOrdinality <$> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/OptTempTableName.hs b/library-internal/PostgresqlSyntax/Ast/OptTempTableName.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OptTempTableName.hs @@ -0,0 +1,85 @@ +module PostgresqlSyntax.Ast.OptTempTableName where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.QualifiedName +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- OptTempTableName: +-- | TEMPORARY opt_table qualified_name +-- | TEMP opt_table qualified_name +-- | LOCAL TEMPORARY opt_table qualified_name +-- | LOCAL TEMP opt_table qualified_name +-- | GLOBAL TEMPORARY opt_table qualified_name +-- | GLOBAL TEMP opt_table qualified_name +-- | UNLOGGED opt_table qualified_name +-- | TABLE qualified_name +-- | qualified_name +-- @ +data OptTempTableName + = TemporaryOptTempTableName Bool QualifiedName + | TempOptTempTableName Bool QualifiedName + | LocalTemporaryOptTempTableName Bool QualifiedName + | LocalTempOptTempTableName Bool QualifiedName + | GlobalTemporaryOptTempTableName Bool QualifiedName + | GlobalTempOptTempTableName Bool QualifiedName + | UnloggedOptTempTableName Bool QualifiedName + | TableOptTempTableName QualifiedName + | QualifedOptTempTableName QualifiedName + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OptTempTableName where + toTextBuilder settings = \case + TemporaryOptTempTableName a b -> TextBuilders.optLexemes [Just "TEMPORARY", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + TempOptTempTableName a b -> TextBuilders.optLexemes [Just "TEMP", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + LocalTemporaryOptTempTableName a b -> TextBuilders.optLexemes [Just "LOCAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + LocalTempOptTempTableName a b -> TextBuilders.optLexemes [Just "LOCAL TEMP", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + GlobalTemporaryOptTempTableName a b -> TextBuilders.optLexemes [Just "GLOBAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + GlobalTempOptTempTableName a b -> TextBuilders.optLexemes [Just "GLOBAL TEMP", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + UnloggedOptTempTableName a b -> TextBuilders.optLexemes [Just "UNLOGGED", bool Nothing (Just "TABLE") a, Just (toTextBuilder settings b)] + TableOptTempTableName a -> "TABLE " <> toTextBuilder settings a + QualifedOptTempTableName a -> toTextBuilder settings a + parser settings = + asum + [ do + a <- + asum + [ TemporaryOptTempTableName <$ Parsers.keyword "temporary" <* Parsers.space1, + TempOptTempTableName <$ Parsers.keyword "temp" <* Parsers.space1, + LocalTemporaryOptTempTableName <$ Parsers.keyphrase "local temporary" <* Parsers.space1, + LocalTempOptTempTableName <$ Parsers.keyphrase "local temp" <* Parsers.space1, + GlobalTemporaryOptTempTableName <$ Parsers.keyphrase "global temporary" <* Parsers.space1, + GlobalTempOptTempTableName <$ Parsers.keyphrase "global temp" <* Parsers.space1, + UnloggedOptTempTableName <$ Parsers.keyword "unlogged" <* Parsers.space1 + ] + b <- option False (True <$ Parsers.keyword "table" <* Parsers.space1) + c <- parser settings + return (a b c), + do + Parsers.keyword "table" + Parsers.space1 + Parser.endHead + TableOptTempTableName <$> parser settings, + QualifedOptTempTableName <$> parser settings + ] + +instance Qc.Arbitrary OptTempTableName where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ TemporaryOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + TempOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + LocalTemporaryOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + LocalTempOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + GlobalTemporaryOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + GlobalTempOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + UnloggedOptTempTableName <$> Qc.arbitrary <*> Qc.arbitrary, + TableOptTempTableName <$> Qc.arbitrary, + QualifedOptTempTableName <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/OptVarying.hs b/library-internal/PostgresqlSyntax/Ast/OptVarying.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OptVarying.hs @@ -0,0 +1,24 @@ +module PostgresqlSyntax.Ast.OptVarying where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_varying: +-- | VARYING +-- | EMPTY +-- @ +newtype OptVarying = OptVarying Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OptVarying where + toTextBuilder _settings (OptVarying a) = if a then "VARYING" else mempty + parser _settings = OptVarying <$> (True <$ Parsers.space1 <* Parsers.keyword "varying" <|> pure False) + +instance Qc.Arbitrary OptVarying where + shrink = Qc.genericShrink + arbitrary = OptVarying <$> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/OverClause.hs b/library-internal/PostgresqlSyntax/Ast/OverClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OverClause.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.OverClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.WindowSpecification +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- over_clause: +-- | OVER window_specification +-- | OVER ColId +-- | EMPTY +-- @ +data OverClause + = WindowOverClause WindowSpecification + | ColIdOverClause Ident + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OverClause where + toTextBuilder settings = \case + WindowOverClause a -> "OVER " <> toTextBuilder settings a + ColIdOverClause a -> "OVER " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "over" + Parsers.space1 + Parser.endHead + asum + [ WindowOverClause <$> parser settings, + ColIdOverClause <$> colId settings + ] + +instance Qc.Arbitrary OverClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ WindowOverClause <$> Qc.arbitrary, + ColIdOverClause <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/OverlayList.hs b/library-internal/PostgresqlSyntax/Ast/OverlayList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OverlayList.hs @@ -0,0 +1,58 @@ +module PostgresqlSyntax.Ast.OverlayList where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- overlay_list: +-- | a_expr overlay_placing substr_from substr_for +-- | a_expr overlay_placing substr_from +-- @ +-- +-- @overlay_placing@\/@substr_from@\/@substr_for@ are bare aliases to +-- 'PostgresqlSyntax.Ast.AExpr' (@PLACING a_expr@\/@FROM a_expr@\/@FOR +-- a_expr@ respectively); their tiny keyword-prefix wrapping is inlined here +-- rather than named, since 'PostgresqlSyntax.Ast.SubstrListFromFor' has its +-- own (differently-scoped) copy of the @FROM@\/@FOR@ half. +data OverlayList = OverlayList AExpr AExpr AExpr (Maybe AExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst OverlayList where + toTextBuilder settings (OverlayList a b c d) = + toTextBuilder settings a + <> " PLACING " + <> toTextBuilder settings b + <> " FROM " + <> toTextBuilder settings c + <> TextBuilders.suffixMaybe (mappend "FOR " . toTextBuilder settings) d + parser settings = do + a <- parser settings + Parsers.space1 + Parsers.keyword "placing" + Parsers.space1 + Parser.endHead + b <- parser settings + Parsers.space1 + Parsers.keyword "from" + Parsers.space1 + Parser.endHead + c <- parser settings + d <- optional (Parsers.space1 *> Parsers.keyword "for" *> Parsers.space1 *> Parser.endHead *> parser settings) + return (OverlayList a b c d) + +instance Qc.Arbitrary OverlayList where + shrink = Qc.genericShrink + arbitrary = + OverlayList + <$> Gens.downscale Qc.arbitrary + <*> Gens.downscale Qc.arbitrary + <*> Gens.downscale Qc.arbitrary + <*> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) diff --git a/library-internal/PostgresqlSyntax/Ast/OverrideKind.hs b/library-internal/PostgresqlSyntax/Ast/OverrideKind.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/OverrideKind.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.OverrideKind where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- override_kind: +-- | USER +-- | SYSTEM_P +-- @ +data OverrideKind = UserOverrideKind | SystemOverrideKind + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst OverrideKind where + toTextBuilder _settings = \case + UserOverrideKind -> "USER" + SystemOverrideKind -> "SYSTEM" + parser _settings = + asum + [ UserOverrideKind <$ Parsers.keyword "user", + SystemOverrideKind <$ Parsers.keyword "system" + ] + +instance Qc.Arbitrary OverrideKind where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/PositionList.hs b/library-internal/PostgresqlSyntax/Ast/PositionList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/PositionList.hs @@ -0,0 +1,26 @@ +module PostgresqlSyntax.Ast.PositionList where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.BExpr (BExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- position_list: +-- | b_expr IN_P b_expr +-- | EMPTY +-- @ +data PositionList = PositionList BExpr BExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst PositionList where + toTextBuilder settings (PositionList a b) = toTextBuilder settings a <> " IN " <> toTextBuilder settings b + parser settings = PositionList <$> parser settings <*> (Parsers.space1 *> Parsers.keyword "in" *> Parsers.space1 *> parser settings) + +instance Qc.Arbitrary PositionList where + shrink = Qc.genericShrink + arbitrary = PositionList <$> Gens.downscale arbitrary <*> Gens.downscale arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/PreparableStmt.hs b/library-internal/PostgresqlSyntax/Ast/PreparableStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/PreparableStmt.hs @@ -0,0 +1,55 @@ +module PostgresqlSyntax.Ast.PreparableStmt where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.CallStmt +import PostgresqlSyntax.Ast.DeleteStmt +import PostgresqlSyntax.Ast.InsertStmt +import PostgresqlSyntax.Ast.SelectStmt +import PostgresqlSyntax.Ast.UpdateStmt +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- PreparableStmt: +-- | SelectStmt +-- | InsertStmt +-- | UpdateStmt +-- | DeleteStmt +-- | CallStmt +-- @ +data PreparableStmt + = SelectPreparableStmt SelectStmt + | InsertPreparableStmt InsertStmt + | UpdatePreparableStmt UpdateStmt + | DeletePreparableStmt DeleteStmt + | CallPreparableStmt CallStmt + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst PreparableStmt where + toTextBuilder settings = \case + SelectPreparableStmt a -> toTextBuilder settings a + InsertPreparableStmt a -> toTextBuilder settings a + UpdatePreparableStmt a -> toTextBuilder settings a + DeletePreparableStmt a -> toTextBuilder settings a + CallPreparableStmt a -> toTextBuilder settings a + parser settings = + asum + [ SelectPreparableStmt <$> parser settings, + InsertPreparableStmt <$> parser settings, + UpdatePreparableStmt <$> parser settings, + DeletePreparableStmt <$> parser settings, + CallPreparableStmt <$> parser settings + ] + +instance Qc.Arbitrary PreparableStmt where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ SelectPreparableStmt <$> Qc.arbitrary, + InsertPreparableStmt <$> Qc.arbitrary, + UpdatePreparableStmt <$> Qc.arbitrary, + DeletePreparableStmt <$> Qc.arbitrary, + CallPreparableStmt <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/QualAllOp.hs b/library-internal/PostgresqlSyntax/Ast/QualAllOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/QualAllOp.hs @@ -0,0 +1,39 @@ +module PostgresqlSyntax.Ast.QualAllOp where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AllOp +import PostgresqlSyntax.Ast.AnyOperator +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- qual_all_Op: +-- | all_Op +-- | OPERATOR '(' any_operator ')' +-- @ +data QualAllOp + = AllQualAllOp AllOp + | AnyQualAllOp AnyOperator + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst QualAllOp where + toTextBuilder settings = \case + AllQualAllOp a -> toTextBuilder settings a + AnyQualAllOp a -> "OPERATOR (" <> toTextBuilder settings a <> ")" + parser settings = + asum + [ AnyQualAllOp <$> (Parsers.keyword "operator" *> Parsers.space *> Parsers.inParens (Parser.endHead *> parser settings)), + AllQualAllOp <$> parser settings + ] + +instance Qc.Arbitrary QualAllOp where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ AllQualAllOp <$> Qc.arbitrary, + AnyQualAllOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/QualOp.hs b/library-internal/PostgresqlSyntax/Ast/QualOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/QualOp.hs @@ -0,0 +1,38 @@ +module PostgresqlSyntax.Ast.QualOp where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AnyOperator +import PostgresqlSyntax.Ast.Op +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- qual_Op: +-- | Op +-- | OPERATOR '(' any_operator ')' +-- @ +data QualOp + = OpQualOp Op + | OperatorQualOp AnyOperator + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst QualOp where + toTextBuilder settings = \case + OpQualOp a -> toTextBuilder settings a + OperatorQualOp a -> "OPERATOR (" <> toTextBuilder settings a <> ")" + parser settings = + asum + [ OpQualOp <$> parser settings, + OperatorQualOp <$> Parsers.inParensWithClause (Parsers.keyword "operator") (parser settings) + ] + +instance Qc.Arbitrary QualOp where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ OpQualOp <$> Qc.arbitrary, + OperatorQualOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/QualifiedName.hs b/library-internal/PostgresqlSyntax/Ast/QualifiedName.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/QualifiedName.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.QualifiedName where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Indirection +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- columnref: +-- | ColId +-- | ColId indirection +-- qualified_name: +-- | ColId +-- | ColId indirection +-- @ +data QualifiedName + = SimpleQualifiedName Ident + | IndirectedQualifiedName Ident Indirection + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst QualifiedName where + toTextBuilder settings = \case + SimpleQualifiedName a -> toTextBuilder settings a + IndirectedQualifiedName a b -> toTextBuilder settings a <> toTextBuilder settings b + parser settings = + IndirectedQualifiedName + <$> Parser.wrapToHead (colId settings) + <*> (Parsers.space *> parser settings) + <|> SimpleQualifiedName + <$> colId settings + +instance Qc.Arbitrary QualifiedName where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ SimpleQualifiedName <$> Qc.arbitrary, + IndirectedQualifiedName <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/RelationExpr.hs b/library-internal/PostgresqlSyntax/Ast/RelationExpr.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/RelationExpr.hs @@ -0,0 +1,55 @@ +module PostgresqlSyntax.Ast.RelationExpr where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.QualifiedName +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | qualified_name +-- | qualified_name '*' +-- | ONLY qualified_name +-- | ONLY '(' qualified_name ')' +-- @ +data RelationExpr + = -- | Name, then whether an asterisk is present. + SimpleRelationExpr QualifiedName Bool + | -- | Name, then whether parentheses are present. + OnlyRelationExpr QualifiedName Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst RelationExpr where + toTextBuilder settings = \case + SimpleRelationExpr a b -> toTextBuilder settings a <> bool "" " *" b + OnlyRelationExpr a b -> "ONLY " <> bool (toTextBuilder settings) (TextBuilders.renderInParens . toTextBuilder settings) b a + parser settings = + Parser.label "relation expression" $ + asum + [ do + Parsers.keyword "only" + Parsers.space1 + name <- parser settings + return (OnlyRelationExpr name False), + Parsers.inParensWithClause (Parsers.keyword "only") (parser settings) <&> \a -> OnlyRelationExpr a True, + do + name <- parser settings + asterisk <- + asum + [ True <$ (Parsers.space1 *> Parsers.char '*'), + pure False + ] + return (SimpleRelationExpr name asterisk) + ] + +instance Qc.Arbitrary RelationExpr where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ SimpleRelationExpr <$> Qc.arbitrary <*> Qc.arbitrary, + OnlyRelationExpr <$> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/RelationExprOptAlias.hs b/library-internal/PostgresqlSyntax/Ast/RelationExprOptAlias.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/RelationExprOptAlias.hs @@ -0,0 +1,43 @@ +module PostgresqlSyntax.Ast.RelationExprOptAlias + ( RelationExprOptAlias (..), + ) +where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.RelationExpr +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- relation_expr_opt_alias: +-- | relation_expr +-- | relation_expr ColId +-- | relation_expr AS ColId +-- @ +data RelationExprOptAlias = RelationExprOptAlias RelationExpr (Maybe (Bool, Ident)) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst RelationExprOptAlias where + toTextBuilder settings (RelationExprOptAlias a b) = toTextBuilder settings a <> TextBuilders.suffixMaybe optAlias b + where + optAlias (c, d) = bool "" "AS " c <> toTextBuilder settings d + parser settings = do + a <- parser settings + b <- optional $ do + Parsers.space1 + b <- Parsers.trueIfPresent (Parsers.keyword "as" *> Parsers.space1) + -- Only the bare-alias (no @AS@) branch has the shift/reduce conflict + -- that Postgres resolves by excluding @SET@; see @gram.y@, comment + -- above @relation_expr_opt_alias@'s first production. + c <- Parsers.filteredColIdLike UnquotedIdent (parser settings) (if b then [] else ["set"]) + return (b, c) + return (RelationExprOptAlias a b) + +instance Qc.Arbitrary RelationExprOptAlias where + shrink = Qc.genericShrink + arbitrary = RelationExprOptAlias <$> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/ReturningClause.hs b/library-internal/PostgresqlSyntax/Ast/ReturningClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ReturningClause.hs @@ -0,0 +1,33 @@ +module PostgresqlSyntax.Ast.ReturningClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.TargetList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- returning_clause: +-- | RETURNING returning_with_clause target_list +-- | /*EMPTY*/ +-- @ +-- +-- @returning_with_clause@ (the @WITH (...)@ modifier) is not modeled +-- here — not supported by this codebase's grammar subset. +newtype ReturningClause = ReturningClause TargetList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ReturningClause where + toTextBuilder settings (ReturningClause a) = "RETURNING " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "returning" + Parsers.space1 + Parser.endHead + ReturningClause <$> parser settings + +instance Qc.Arbitrary ReturningClause where + shrink = Qc.genericShrink + arbitrary = ReturningClause <$> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Row.hs b/library-internal/PostgresqlSyntax/Ast/Row.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Row.hs @@ -0,0 +1,34 @@ +module PostgresqlSyntax.Ast.Row where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExplicitRow +import PostgresqlSyntax.Ast.ImplicitRow +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- row: +-- | ROW '(' expr_list ')' +-- | ROW '(' ')' +-- | '(' expr_list ',' a_expr ')' +-- @ +data Row + = ExplicitRowRow ExplicitRow + | ImplicitRowRow ImplicitRow + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Row where + toTextBuilder settings = \case + ExplicitRowRow a -> toTextBuilder settings a + ImplicitRowRow a -> toTextBuilder settings a + parser settings = ExplicitRowRow <$> parser settings <|> ImplicitRowRow <$> parser settings + +instance Qc.Arbitrary Row where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExplicitRowRow <$> Qc.arbitrary, + ImplicitRowRow <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/RowsfromItem.hs b/library-internal/PostgresqlSyntax/Ast/RowsfromItem.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/RowsfromItem.hs @@ -0,0 +1,39 @@ +module PostgresqlSyntax.Ast.RowsfromItem where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FuncExprWindowless +import PostgresqlSyntax.Ast.TableFuncElementList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- rowsfrom_item: +-- | func_expr_windowless opt_col_def_list +-- @ +-- +-- @opt_col_def_list@ is a bare alias to +-- 'PostgresqlSyntax.Ast.TableFuncElementList'. +data RowsfromItem = RowsfromItem FuncExprWindowless (Maybe TableFuncElementList) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst RowsfromItem where + toTextBuilder settings (RowsfromItem a b) = toTextBuilder settings a <> TextBuilders.suffixMaybe colDefList b + where + colDefList a' = "AS (" <> toTextBuilder settings a' <> ")" + parser settings = do + a <- parser settings + Parser.endHead + b <- optional (Parsers.space1 *> colDefList) + return (RowsfromItem a b) + where + colDefList = Parsers.keyword "as" *> Parsers.space *> Parsers.inParens (Parser.endHead *> parser settings) + +instance Qc.Arbitrary RowsfromItem where + shrink = Qc.genericShrink + arbitrary = RowsfromItem <$> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/RowsfromList.hs b/library-internal/PostgresqlSyntax/Ast/RowsfromList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/RowsfromList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.RowsfromList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.RowsfromItem +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- rowsfrom_list: +-- | rowsfrom_item +-- | rowsfrom_list ',' rowsfrom_item +-- @ +newtype RowsfromList = RowsfromList (NonEmpty RowsfromItem) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst RowsfromList where + toTextBuilder settings (RowsfromList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = RowsfromList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary RowsfromList where + shrink = Qc.genericShrink + arbitrary = RowsfromList <$> Gens.nonEmptyUpTo 7 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Sconst.hs b/library-internal/PostgresqlSyntax/Ast/Sconst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Sconst.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.Sconst where + +import qualified Data.Text as Text +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.Shrinks as Shrinks +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc +import qualified TextBuilder + +-- | +-- ==== References +-- @ +-- Sconst +-- @ +newtype Sconst = Sconst Text + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Sconst where + toTextBuilder _settings (Sconst a) = "'" <> TextBuilder.text (Text.replace "'" "''" a) <> "'" + parser _settings = Sconst <$> (Parsers.quotedString '\'' <|> Parsers.dollarQuotedSconst) + +instance Qc.Arbitrary Sconst where + shrink (Sconst a) = Sconst <$> Shrinks.text a + arbitrary = do + len <- Qc.sized (\n -> Qc.choose (0, min 1000 (n * 20))) + Sconst . Text.pack <$> Qc.vectorOf len (Qc.arbitrary `Qc.suchThat` (not . isControl)) diff --git a/library-internal/PostgresqlSyntax/Ast/SelectBinOp.hs b/library-internal/PostgresqlSyntax/Ast/SelectBinOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectBinOp.hs @@ -0,0 +1,32 @@ +module PostgresqlSyntax.Ast.SelectBinOp where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | select_clause UNION all_or_distinct select_clause +-- | select_clause INTERSECT all_or_distinct select_clause +-- | select_clause EXCEPT all_or_distinct select_clause +-- @ +data SelectBinOp = UnionSelectBinOp | IntersectSelectBinOp | ExceptSelectBinOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectBinOp where + toTextBuilder _settings = \case + UnionSelectBinOp -> "UNION" + IntersectSelectBinOp -> "INTERSECT" + ExceptSelectBinOp -> "EXCEPT" + parser _settings = + asum + [ Parsers.keyword "union" $> UnionSelectBinOp, + Parsers.keyword "intersect" $> IntersectSelectBinOp, + Parsers.keyword "except" $> ExceptSelectBinOp + ] + +instance Qc.Arbitrary SelectBinOp where + shrink = Qc.genericShrink + arbitrary = Qc.elements [UnionSelectBinOp, IntersectSelectBinOp, ExceptSelectBinOp] diff --git a/library-internal/PostgresqlSyntax/Ast/SelectClause.hs b/library-internal/PostgresqlSyntax/Ast/SelectClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectClause.hs @@ -0,0 +1,74 @@ +module PostgresqlSyntax.Ast.SelectClause where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import {-# SOURCE #-} PostgresqlSyntax.Ast.SimpleSelect (SimpleSelect) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- select_clause: +-- | simple_select +-- | select_with_parens +-- @ +-- +-- This type's own 'IsAst' instance is a plain, non-recursive-suffix-aware +-- dispatch — the real @UNION@\/@INTERSECT@\/@EXCEPT@-chaining grammar +-- (where a @select_clause@ extends into a bigger +-- 'PostgresqlSyntax.Ast.SimpleSelect' via its @BinSimpleSelect@ +-- constructor) is hosted in "PostgresqlSyntax.Ast.SimpleSelect" instead, +-- since only that module can construct @BinSimpleSelect@ values. See its +-- module documentation. +data SelectClause + = SimpleSelectSelectClause SimpleSelect + | WithParensSelectClause SelectWithParens + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectClause where + toTextBuilder settings = \case + SimpleSelectSelectClause a -> toTextBuilder settings a + WithParensSelectClause a -> toTextBuilder settings a + + -- ==== Law + -- + -- @parser = parseMaybeExtended \@SelectClause@ — see + -- 'PostgresqlSyntax.Ast.SimpleSelect'\'s 'PostgresqlSyntax.Algebra.Extends' + -- instance for the real @select_clause@ grammar, including + -- @UNION@\/@INTERSECT@\/@EXCEPT@-chaining. + parser settings = parseMaybeExtended @SimpleSelect settings + +-- | +-- Every @select_clause@ production except the left-recursive ones (those +-- are the @UNION@\/@INTERSECT@\/@EXCEPT@ continuations, hosted by +-- "PostgresqlSyntax.Ast.SimpleSelect"\'s +-- 'PostgresqlSyntax.Algebra.Extends' instance). +instance LeftRecursive SelectClause where + parseBase settings = + asum + [ WithParensSelectClause <$> parser settings, + SimpleSelectSelectClause <$> parseBase @SimpleSelect settings + ] + +-- | +-- A 'SimpleSelect' embeds trivially into a 'SelectClause' (it's one of its +-- two alternatives), and a 'SelectClause' of that exact shape is +-- recognizable back as one. Needed so +-- "PostgresqlSyntax.Ast.SimpleSelect"\'s +-- 'PostgresqlSyntax.Algebra.Extends' instance can fold a chain of +-- @UNION@\/@INTERSECT@\/@EXCEPT@ items onto a leading 'SelectClause'. +instance Refines SimpleSelect SelectClause where + embed = SimpleSelectSelectClause + project = \case + SimpleSelectSelectClause a -> Just a + _ -> Nothing + +instance Qc.Arbitrary SelectClause where + shrink = Qc.genericShrink + arbitrary = + Qc.frequency + [ (3, SimpleSelectSelectClause <$> Gens.downscale Qc.arbitrary), + (1, WithParensSelectClause <$> Gens.downscale Qc.arbitrary) + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SelectClause.hs-boot b/library-internal/PostgresqlSyntax/Ast/SelectClause.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectClause.hs-boot @@ -0,0 +1,19 @@ +module PostgresqlSyntax.Ast.SelectClause where + +import PostgresqlSyntax.Algebra (IsAst) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data SelectClause + +instance Show SelectClause + +instance Eq SelectClause + +instance Ord SelectClause + +instance Data SelectClause + +instance IsAst SelectClause + +instance Arbitrary SelectClause diff --git a/library-internal/PostgresqlSyntax/Ast/SelectFetchFirstValue.hs b/library-internal/PostgresqlSyntax/Ast/SelectFetchFirstValue.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectFetchFirstValue.hs @@ -0,0 +1,61 @@ +module PostgresqlSyntax.Ast.SelectFetchFirstValue where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.CExpr +import PostgresqlSyntax.Ast.Fconst +import qualified PostgresqlSyntax.Extras.TextBuilder as TextBuilder +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- select_fetch_first_value: +-- | c_expr +-- | '+' I_or_F_const +-- | '-' I_or_F_const +-- @ +data SelectFetchFirstValue + = ExprSelectFetchFirstValue CExpr + | NumSelectFetchFirstValue Bool (Either Int64 Double) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectFetchFirstValue where + toTextBuilder settings = \case + ExprSelectFetchFirstValue a -> toTextBuilder settings a + NumSelectFetchFirstValue a b -> bool "+" "-" a <> intOrFloat b + where + intOrFloat = either TextBuilder.int64Dec TextBuilder.doubleDec + parser settings = + ExprSelectFetchFirstValue + <$> parser settings + <|> NumSelectFetchFirstValue + <$> (plusOrMinus <* Parser.endHead <* Parsers.space) + <*> iconstOrFconst + where + plusOrMinus = False <$ Parsers.char '+' <|> True <$ Parsers.char '-' + iconstOrFconst = Right <$> (coerce <$> (parser settings :: Parser Fconst)) <|> Left <$> Parsers.decimal + +instance Qc.Arbitrary SelectFetchFirstValue where + shrink = Qc.genericShrink + + -- The magnitude is parsed via unsigned 'Parser.decimal'\/'Fconst' (the + -- sign is this type's own separate @Bool@ field), so, like + -- 'PostgresqlSyntax.Ast.IntervalSecond'\'s @nonNegative@, it must never be + -- negative itself — otherwise e.g. @NumSelectFetchFirstValue True (Left + -- (-1))@ renders as @-1@ with no space (a valid unsigned-magnitude + -- rendering would be @- 1@ or just @-1@ for magnitude 1), doubling up + -- into @--1@, which reparses as a line comment. + arbitrary = + Qc.oneof + [ ExprSelectFetchFirstValue <$> Qc.arbitrary, + NumSelectFetchFirstValue <$> Qc.arbitrary <*> Qc.oneof [Left <$> nonNegativeInt64, Right <$> nonNegativeDouble] + ] + where + nonNegativeInt64 = Qc.sized (\n -> Qc.choose (0, cap n)) + nonNegativeDouble = abs <$> Qc.arbitrary + cap n + | n >= 62 = maxBound + | otherwise = 2 ^ n diff --git a/library-internal/PostgresqlSyntax/Ast/SelectLimit.hs b/library-internal/PostgresqlSyntax/Ast/SelectLimit.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectLimit.hs @@ -0,0 +1,51 @@ +module PostgresqlSyntax.Ast.SelectLimit where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.LimitClause +import PostgresqlSyntax.Ast.OffsetClause +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- select_limit: +-- | limit_clause offset_clause +-- | offset_clause limit_clause +-- | limit_clause +-- | offset_clause +-- @ +data SelectLimit + = LimitOffsetSelectLimit LimitClause OffsetClause + | OffsetLimitSelectLimit OffsetClause LimitClause + | LimitSelectLimit LimitClause + | OffsetSelectLimit OffsetClause + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectLimit where + toTextBuilder settings = \case + LimitOffsetSelectLimit a b -> TextBuilders.lexemes [toTextBuilder settings a, toTextBuilder settings b] + OffsetLimitSelectLimit a b -> TextBuilders.lexemes [toTextBuilder settings a, toTextBuilder settings b] + LimitSelectLimit a -> toTextBuilder settings a + OffsetSelectLimit a -> toTextBuilder settings a + parser settings = + asum + [ do + a <- parser settings + LimitOffsetSelectLimit a <$> (Parsers.space1 *> parser settings) <|> pure (LimitSelectLimit a), + do + a <- parser settings + OffsetLimitSelectLimit a <$> (Parsers.space1 *> parser settings) <|> pure (OffsetSelectLimit a) + ] + +instance Qc.Arbitrary SelectLimit where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ LimitOffsetSelectLimit <$> Qc.arbitrary <*> Qc.arbitrary, + OffsetLimitSelectLimit <$> Qc.arbitrary <*> Qc.arbitrary, + LimitSelectLimit <$> Qc.arbitrary, + OffsetSelectLimit <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SelectLimitValue.hs b/library-internal/PostgresqlSyntax/Ast/SelectLimitValue.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectLimitValue.hs @@ -0,0 +1,38 @@ +module PostgresqlSyntax.Ast.SelectLimitValue where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- select_limit_value: +-- | a_expr +-- | ALL +-- @ +data SelectLimitValue + = ExprSelectLimitValue AExpr + | AllSelectLimitValue + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectLimitValue where + toTextBuilder settings = \case + ExprSelectLimitValue a -> toTextBuilder settings a + AllSelectLimitValue -> "ALL" + parser settings = + AllSelectLimitValue + <$ Parsers.keyword "all" + <|> ExprSelectLimitValue + <$> parser settings + +instance Qc.Arbitrary SelectLimitValue where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprSelectLimitValue <$> Gens.downscale Qc.arbitrary, + pure AllSelectLimitValue + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs b/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs @@ -0,0 +1,106 @@ +module PostgresqlSyntax.Ast.SelectNoParens + ( SelectNoParens (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ForLockingClause +import PostgresqlSyntax.Ast.SelectClause +import PostgresqlSyntax.Ast.SelectLimit +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import {-# SOURCE #-} PostgresqlSyntax.Ast.SimpleSelect (SimpleSelect) +import PostgresqlSyntax.Ast.SortClause +import {-# SOURCE #-} PostgresqlSyntax.Ast.WithClause (WithClause) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc + +-- | +-- Covers the following cases: +-- +-- @ +-- select_no_parens: +-- | simple_select +-- | select_clause sort_clause +-- | select_clause opt_sort_clause for_locking_clause opt_select_limit +-- | select_clause opt_sort_clause select_limit opt_for_locking_clause +-- | with_clause select_clause +-- | with_clause select_clause sort_clause +-- | with_clause select_clause opt_sort_clause for_locking_clause opt_select_limit +-- | with_clause select_clause opt_sort_clause select_limit opt_for_locking_clause +-- @ +data SelectNoParens + = SelectNoParens (Maybe WithClause) SelectClause (Maybe SortClause) (Maybe SelectLimit) (Maybe ForLockingClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectNoParens where + toTextBuilder settings (SelectNoParens a b c d e) = + TextBuilders.optLexemes + [ fmap (toTextBuilder settings) a, + Just (toTextBuilder settings b), + fmap (toTextBuilder settings) c, + fmap (toTextBuilder settings) d, + fmap (toTextBuilder settings) e + ] + parser settings = withSelectNoParens <|> simpleSelectNoParens + where + simpleSelectNoParens = sharedSelectNoParens settings Nothing + withSelectNoParens = do + with <- Parser.wrapToHead (parser settings) + Parsers.space1 + sharedSelectNoParens settings (Just with) + +-- | +-- Parses the @select_clause@ (see +-- 'PostgresqlSyntax.Ast.SimpleSelect'\'s 'Extends' instance for the +-- @UNION@\/@INTERSECT@\/@EXCEPT@-chaining grammar) plus everything that can +-- follow it. +sharedSelectNoParens :: Settings -> Maybe WithClause -> Parser SelectNoParens +sharedSelectNoParens settings with = do + select <- parseMaybeExtended @SimpleSelect settings + sort <- optional (Parsers.space1 *> parser settings) + (limit, forLocking) <- limitFirst <|> forLockingFirst <|> pure (Nothing, Nothing) + return (SelectNoParens with select sort limit forLocking) + where + limitFirst = do + limit <- Parsers.space1 *> parser settings + forLocking <- optional (Parsers.space1 *> parser settings) + pure (Just limit, forLocking) + forLockingFirst = do + forLocking <- Parsers.space1 *> parser settings + limit <- optional (Parsers.space1 *> parser settings) + pure (limit, Just forLocking) + +-- | +-- If a 'SelectNoParens' is merely a trivial wrapper around a single +-- parenthesized select — no with-clause, sort, limit or locking clause of +-- its own — returns the wrapped 'SelectWithParens'. Used by the +-- 'Refines' instance to canonicalize such wrappers. +refineToSelectWithParens :: SelectNoParens -> Maybe SelectWithParens +refineToSelectWithParens = \case + SelectNoParens Nothing (WithParensSelectClause c) Nothing Nothing Nothing -> Just c + _ -> Nothing + +instance Refines SelectWithParens SelectNoParens where + embed c = SelectNoParens Nothing (WithParensSelectClause c) Nothing Nothing Nothing + project = refineToSelectWithParens + +instance Qc.Arbitrary SelectNoParens where + shrink = Qc.genericShrink + arbitrary = + sized $ \size -> + if size <= 1 + then do + selectClause <- Qc.arbitrary + return (SelectNoParens Nothing selectClause Nothing Nothing Nothing) + else + SelectNoParens + <$> Gens.downscale Qc.arbitrary + <*> Qc.arbitrary + <*> Qc.arbitrary + <*> Qc.arbitrary + <*> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs-boot b/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectNoParens.hs-boot @@ -0,0 +1,22 @@ +module PostgresqlSyntax.Ast.SelectNoParens where + +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import PostgresqlSyntax.Algebra (IsAst, Refines) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data SelectNoParens + +instance Show SelectNoParens + +instance Eq SelectNoParens + +instance Ord SelectNoParens + +instance Data SelectNoParens + +instance IsAst SelectNoParens + +instance Arbitrary SelectNoParens + +instance Refines SelectWithParens SelectNoParens diff --git a/library-internal/PostgresqlSyntax/Ast/SelectStmt.hs b/library-internal/PostgresqlSyntax/Ast/SelectStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectStmt.hs @@ -0,0 +1,39 @@ +module PostgresqlSyntax.Ast.SelectStmt where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectNoParens (SelectNoParens) +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- SelectStmt: +-- | select_no_parens +-- | select_with_parens +-- @ +data SelectStmt + = NoParensSelectStmt SelectNoParens + | WithParensSelectStmt SelectWithParens + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectStmt where + toTextBuilder settings = \case + NoParensSelectStmt a -> toTextBuilder settings a + WithParensSelectStmt a -> toTextBuilder settings a + parser settings = NoParensSelectStmt <$> parser settings <|> WithParensSelectStmt <$> parser settings + +instance Qc.Arbitrary SelectStmt where + shrink = Qc.genericShrink + + -- @WithParensSelectStmt@ is unreachable via this type's own @parser@: + -- @NoParensSelectStmt@'s alternative is tried first, and + -- 'PostgresqlSyntax.Ast.SelectClause' (reachable from any + -- @select_no_parens@ with every other clause absent) always accepts a + -- parenthesized select too — so any @'(' select ')'@ text always parses + -- as @NoParensSelectStmt (SelectNoParens Nothing (WithParensSelectClause + -- _) Nothing Nothing Nothing)@, never as a bare @WithParensSelectStmt@. + -- Generating the latter would therefore never round-trip. + arbitrary = NoParensSelectStmt <$> Gens.downscale Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs b/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs @@ -0,0 +1,70 @@ +module PostgresqlSyntax.Ast.SelectWithParens + ( SelectWithParens (..), + ) +where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectNoParens (SelectNoParens) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- select_with_parens: +-- | '(' select_no_parens ')' +-- | '(' select_with_parens ')' +-- @ +data SelectWithParens + = NoParensSelectWithParens SelectNoParens + | WithParensSelectWithParens SelectWithParens + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SelectWithParens where + toTextBuilder settings = + TextBuilders.renderInParens . \case + NoParensSelectWithParens a -> toTextBuilder settings a + WithParensSelectWithParens a -> toTextBuilder settings a + + -- ==== Canonical shape + -- + -- Because @select_with_parens@ (@'(' select_with_parens ')'@) and + -- @'(' select_no_parens ')'@ both parse @((select 1))@, there are two + -- possible representations: @WithParensSelectWithParens@ wrapping the + -- inner parenthesised select, or @NoParensSelectWithParens@ of a + -- @SelectNoParens@ whose clause is that inner select. Both render back + -- to the same text. __The first (@WithParensSelectWithParens@) is + -- canonical.__ The 'Canonicalizes' instance normalizes shrunk or generated + -- values to this shape. + parser settings = Parsers.inParens (canonicalize . NoParensSelectWithParens <$> parser settings) + +instance Qc.Arbitrary SelectWithParens where + shrink = fmap canonicalize . Qc.genericShrink + arbitrary = + canonicalize + <$> Qc.frequency + [ (3, NoParensSelectWithParens <$> Gens.downscale Qc.arbitrary), + (1, WithParensSelectWithParens <$> Gens.downscale Qc.arbitrary) + ] + +-- | +-- Collapses the non-canonical @NoParensSelectWithParens@ shape described +-- above to the @WithParensSelectWithParens@ shape the parser actually +-- produces for it. Both 'arbitrary' and 'shrink' can otherwise construct +-- the non-canonical shape (shrinking the inner 'SelectNoParens' toward +-- @Nothing@s is exactly how it arises), which renders fine but parses back +-- to a different, canonical value and so breaks the roundtrip property. +instance Canonicalizes SelectWithParens where + canonicalize = \case + NoParensSelectWithParens a + | Just c <- project @SelectWithParens a -> WithParensSelectWithParens c + other -> other + +instance Refines SelectWithParens SelectWithParens where + embed = WithParensSelectWithParens + project = \case + WithParensSelectWithParens a -> Just a + _ -> Nothing diff --git a/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs-boot b/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SelectWithParens.hs-boot @@ -0,0 +1,21 @@ +module PostgresqlSyntax.Ast.SelectWithParens where + +import PostgresqlSyntax.Algebra (IsAst, Refines) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data SelectWithParens + +instance Show SelectWithParens + +instance Eq SelectWithParens + +instance Ord SelectWithParens + +instance Data SelectWithParens + +instance IsAst SelectWithParens + +instance Arbitrary SelectWithParens + +instance Refines SelectWithParens SelectWithParens diff --git a/library-internal/PostgresqlSyntax/Ast/SetClause.hs b/library-internal/PostgresqlSyntax/Ast/SetClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SetClause.hs @@ -0,0 +1,53 @@ +module PostgresqlSyntax.Ast.SetClause where + +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.SetTarget +import PostgresqlSyntax.Ast.SetTargetList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- set_clause: +-- | set_target '=' a_expr +-- | '(' set_target_list ')' '=' a_expr +-- @ +data SetClause + = TargetSetClause SetTarget AExpr + | TargetListSetClause SetTargetList AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SetClause where + toTextBuilder settings = \case + TargetSetClause a b -> toTextBuilder settings a <> " = " <> toTextBuilder settings b + TargetListSetClause a b -> TextBuilders.renderInParens (toTextBuilder settings a) <> " = " <> toTextBuilder settings b + parser settings = + asum + [ do + a <- Parsers.inParens (parser settings) + Parsers.space + Parsers.char '=' + Parsers.space + b <- parser settings + return (TargetListSetClause a b), + do + a <- parser settings + Parsers.space + Parsers.char '=' + Parsers.space + b <- parser settings + return (TargetSetClause a b) + ] + +instance Qc.Arbitrary SetClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ TargetSetClause <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + TargetListSetClause <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SetClauseList.hs b/library-internal/PostgresqlSyntax/Ast/SetClauseList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SetClauseList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.SetClauseList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SetClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- set_clause_list: +-- | set_clause +-- | set_clause_list ',' set_clause +-- @ +newtype SetClauseList = SetClauseList (NonEmpty SetClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SetClauseList where + toTextBuilder settings (SetClauseList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = SetClauseList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary SetClauseList where + shrink = Qc.genericShrink + arbitrary = SetClauseList <$> Gens.nonEmptyUpTo 9 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SetTarget.hs b/library-internal/PostgresqlSyntax/Ast/SetTarget.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SetTarget.hs @@ -0,0 +1,32 @@ +module PostgresqlSyntax.Ast.SetTarget where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Indirection +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- set_target: +-- | ColId opt_indirection +-- @ +data SetTarget = SetTarget Ident (Maybe Indirection) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SetTarget where + toTextBuilder settings (SetTarget a b) = toTextBuilder settings a <> TextBuilders.suffixMaybe (toTextBuilder settings) b + parser settings = do + a <- colId settings + Parser.endHead + b <- optional (Parsers.space1 *> parser settings) + return (SetTarget a b) + +instance Qc.Arbitrary SetTarget where + shrink = Qc.genericShrink + arbitrary = SetTarget <$> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SetTargetList.hs b/library-internal/PostgresqlSyntax/Ast/SetTargetList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SetTargetList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.SetTargetList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SetTarget +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- set_target_list: +-- | set_target +-- | set_target_list ',' set_target +-- @ +newtype SetTargetList = SetTargetList (NonEmpty SetTarget) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SetTargetList where + toTextBuilder settings (SetTargetList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = SetTargetList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary SetTargetList where + shrink = Qc.genericShrink + arbitrary = SetTargetList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs b/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs @@ -0,0 +1,232 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module PostgresqlSyntax.Ast.SimpleSelect + ( SimpleSelect (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FromClause +import PostgresqlSyntax.Ast.GroupClause +import PostgresqlSyntax.Ast.HavingClause +import PostgresqlSyntax.Ast.IntoClause +import PostgresqlSyntax.Ast.RelationExpr +import PostgresqlSyntax.Ast.SelectBinOp +import PostgresqlSyntax.Ast.SelectClause +import PostgresqlSyntax.Ast.Targeting +import PostgresqlSyntax.Ast.ValuesClause +import PostgresqlSyntax.Ast.WhereClause +import PostgresqlSyntax.Ast.WindowClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (Settings) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- simple_select: +-- | SELECT opt_all_clause opt_target_list +-- into_clause from_clause where_clause +-- group_clause having_clause window_clause +-- | SELECT distinct_clause target_list +-- into_clause from_clause where_clause +-- group_clause having_clause window_clause +-- | values_clause +-- | TABLE relation_expr +-- | select_clause UNION all_or_distinct select_clause +-- | select_clause INTERSECT all_or_distinct select_clause +-- | select_clause EXCEPT all_or_distinct select_clause +-- @ +-- +-- Hosts the real @select_clause@ grammar (including its +-- @UNION@\/@INTERSECT@\/@EXCEPT@-chaining) for both itself and +-- "PostgresqlSyntax.Ast.SelectNoParens", which shares it — see +-- 'PostgresqlSyntax.Ast.SelectClause'\'s module documentation for why. +data SimpleSelect + = NormalSimpleSelect (Maybe Targeting) (Maybe IntoClause) (Maybe FromClause) (Maybe WhereClause) (Maybe GroupClause) (Maybe HavingClause) (Maybe WindowClause) + | ValuesSimpleSelect ValuesClause + | TableSimpleSelect RelationExpr + | BinSimpleSelect SelectBinOp SelectClause (Maybe Bool) SelectClause + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SimpleSelect where + toTextBuilder settings = \case + NormalSimpleSelect a b c d e f g -> + TextBuilders.optLexemes + [ Just "SELECT", + fmap (toTextBuilder settings) a, + fmap (toTextBuilder settings) b, + fmap (toTextBuilder settings) c, + fmap (toTextBuilder settings) d, + fmap (toTextBuilder settings) e, + fmap (toTextBuilder settings) f, + fmap (toTextBuilder settings) g + ] + ValuesSimpleSelect a -> toTextBuilder settings a + TableSimpleSelect a -> "TABLE " <> toTextBuilder settings a + BinSimpleSelect a b c d -> toTextBuilder settings b <> " " <> toTextBuilder settings a <> foldMap (mappend " " . TextBuilders.renderAllOrDistinct) c <> " " <> toTextBuilder settings d + + -- ==== Law + -- + -- @parser = parseExtended \@SelectClause \<|\> baseSimpleSelect@ — a bare + -- 'SimpleSelect' is either a @select_clause@ chain of at least one + -- @UNION@\/@INTERSECT@\/@EXCEPT@ (see 'Extends' below), or, failing + -- that (no continuation follows), one of the non-chain base cases; it's + -- never a bare, zero-extension @select_clause@ (that's not a + -- 'SimpleSelect' at all — see 'SelectClause'). The chain alternative has + -- to come first: trying 'baseSimpleSelect' alone would succeed on just + -- the head of a chain and never look for what follows. + parser settings = parseExtended @SelectClause settings <|> parseBase settings + +-- | +-- The @simple_select@ productions that don't left-recurse through +-- @select_clause@ — i.e. everything but @select_clause BINOP +-- select_clause@. "PostgresqlSyntax.Ast.SelectClause" reaches these +-- through this class method, which is why 'SimpleSelect' needs no helper +-- export. +instance LeftRecursive SimpleSelect where + parseBase settings = + asum + [ do + Parsers.keyword "select" + Parsers.notFollowedBy $ Parsers.satisfy isAlphaNum + Parser.endHead + targeting <- optional (Parsers.space1 *> parser settings) + intoClause <- optional (Parsers.space1 *> parser settings) + fromClause <- optional (Parsers.space1 *> parser settings) + whereClause <- optional (Parsers.space1 *> parser settings) + groupClause <- optional (Parsers.space1 *> parser settings) + havingClause <- optional (Parsers.space1 *> parser settings) + windowClause <- optional (Parsers.space1 *> parser settings) + return (NormalSimpleSelect targeting intoClause fromClause whereClause groupClause havingClause windowClause), + do + Parsers.keyword "table" + Parsers.space1 + Parser.endHead + TableSimpleSelect <$> parser settings, + ValuesSimpleSelect <$> parser settings + ] + +-- | +-- The left-recursion-eliminated form of @select_clause@: a bare +-- 'SelectClause' (either a parenthesized select, or one of +-- 'SimpleSelect'\'s non-chain cases) is the non-recursive base (@β@), +-- and each @UNION@\/@INTERSECT@\/@EXCEPT@ continuation is a +-- 'SelectBinOp' plus its @ALL@\/@DISTINCT@ qualifier and right operand, +-- applied via 'BinSimpleSelect'. +-- +-- Keeps the collect-then-fold shape — parsing every 'SelectChainLink' up +-- front via 'parseExtensionChain', then folding via 'foldChain' — rather +-- than folding as it goes, because this hub's items aren't all one +-- precedence level: @gram.y@ declares @%left UNION EXCEPT@ before (i.e. +-- binding looser than) @%left INTERSECT@ (gram.y:813-814), both +-- left-associative, so a uniform left-to-right fold-as-you-parse would +-- root @a INTERSECT b UNION c@ at @INTERSECT@ and nest @a EXCEPT b EXCEPT +-- c@ to the right — both wrong. 'foldChain' needs the whole flat sequence +-- in hand to sort that out; see its own docs above. +instance Extends SelectClause SimpleSelect where + parseExtensions settings lhs = foldChain lhs <$> parseLinks settings + +-- | +-- One @UNION@\/@INTERSECT@\/@EXCEPT@ continuation, minus the left operand +-- it applies to. +data SelectChainLink = SelectChainLink SelectBinOp (Maybe Bool) SelectClause + +parseLinks :: Settings -> Parser (NonEmpty SelectChainLink) +parseLinks settings = parseExtensionChain $ do + op <- Parsers.space1 *> parser settings <* Parsers.space1 + Parser.endHead + distinct <- optional (Parsers.allOrDistinct <* Parsers.space1) + rhs <- parseBase @SelectClause settings + return (SelectChainLink op distinct rhs) + +-- | +-- ==== The precedence fold +-- +-- @go@ applies items to the accumulator one at a time, left to right — +-- which by itself is already left-associative for a run of same-operator +-- items, INTERSECT included. What needs help is a /low-precedence/ item +-- (@UNION@\/@EXCEPT@) immediately followed by @INTERSECT@ items: those +-- bind tighter, so they must combine into that item's right operand +-- before @go@ applies it, not become separate steps of @go@'s own fold. +-- @absorbIntersect@ does exactly that — and only that: it leaves an +-- @INTERSECT@ item itself untouched (its rest is handled by @go@'s next +-- iteration, one item at a time), and otherwise absorbs a maximal +-- trailing run of @INTERSECT@ items into the current item's right +-- operand. @go@ then continues from whatever @absorbIntersect@ left +-- unconsumed, and either finishes (if nothing's left — the whole point of +-- ending on 'applyLink' rather than wrapping it back into a +-- @SelectClause@ is that the final combination must be the returned +-- @SimpleSelect@) or continues. +foldChain :: SelectClause -> NonEmpty SelectChainLink -> SimpleSelect +foldChain base (i0 :| is0) = go base i0 is0 + where + go acc item rest = + let (absorbedItem, rest') = absorbIntersect item rest + in case rest' of + [] -> applyLink acc absorbedItem + item' : rest'' -> go (SimpleSelectSelectClause (applyLink acc absorbedItem)) item' rest'' + + applyLink lhs (SelectChainLink op distinct rhs) = BinSimpleSelect op lhs distinct rhs + + absorbIntersect item@(SelectChainLink IntersectSelectBinOp _ _) rest = (item, rest) + absorbIntersect (SelectChainLink op distinct rhs) (SelectChainLink IntersectSelectBinOp d rhs' : rest) = + absorbIntersect (SelectChainLink op distinct (SimpleSelectSelectClause (BinSimpleSelect IntersectSelectBinOp rhs d rhs'))) rest + absorbIntersect item rest = (item, rest) + +instance Qc.Arbitrary SimpleSelect where + shrink = fmap canonicalize . Qc.genericShrink + arbitrary = + canonicalize + <$> Qc.sized + ( \n -> + if n <= 1 + then TableSimpleSelect <$> Qc.arbitrary + else + Qc.oneof + [ NormalSimpleSelect + <$> Qc.arbitrary + <*> Qc.arbitrary + <*> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Qc.arbitrary, + ValuesSimpleSelect <$> Qc.arbitrary, + TableSimpleSelect <$> Qc.arbitrary, + BinSimpleSelect <$> Qc.arbitrary <*> Qc.arbitrary <*> Qc.arbitrary <*> Qc.arbitrary + ] + ) + +-- | +-- Collapses an arbitrary-shaped @BinSimpleSelect@ chain to the shape +-- 'foldChain' actually produces for it (left-associated within each +-- precedence level, @INTERSECT@ binding tighter than @UNION@\/@EXCEPT@ — +-- see 'foldChain' above): 'flattenChain' reduces the chain to its flat +-- sequence of operators and operands regardless of how it's currently +-- nested, and re-folding that sequence with the same 'foldChain' the +-- parser itself uses is by construction the shape @parse . toText@ +-- produces. Both 'arbitrary' and 'shrink' can otherwise construct a +-- non-canonical shape, which renders fine but parses back to a +-- different, canonical value and so breaks the roundtrip property. +instance Canonicalizes SimpleSelect where + canonicalize s@(BinSimpleSelect {}) = + case flattenChain (SimpleSelectSelectClause s) of + (headClause, i : is) -> foldChain headClause (i :| is) + (_, []) -> s + canonicalize other = other + +-- | +-- Reduces a @BinSimpleSelect@ chain, in whatever shape it's currently +-- nested, to its leading operand and the flat, left-to-right sequence of +-- 'SelectChainLink' items that follow it — the inverse of 'foldChain'. +flattenChain :: SelectClause -> (SelectClause, [SelectChainLink]) +flattenChain (SimpleSelectSelectClause (BinSimpleSelect op lhs distinct rhs)) = + let (lhsHead, lhsRest) = flattenChain lhs + (rhsHead, rhsRest) = flattenChain rhs + in (lhsHead, lhsRest <> [SelectChainLink op distinct rhsHead] <> rhsRest) +flattenChain c = (c, []) diff --git a/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs-boot b/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SimpleSelect.hs-boot @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module PostgresqlSyntax.Ast.SimpleSelect where + +import PostgresqlSyntax.Algebra (Extends, IsAst, LeftRecursive) +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectClause (SelectClause) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data SimpleSelect + +instance Show SimpleSelect + +instance Eq SimpleSelect + +instance Ord SimpleSelect + +instance Data SimpleSelect + +instance IsAst SimpleSelect + +instance Arbitrary SimpleSelect + +instance LeftRecursive SimpleSelect + +instance Extends SelectClause SimpleSelect diff --git a/library-internal/PostgresqlSyntax/Ast/SimpleTypename.hs b/library-internal/PostgresqlSyntax/Ast/SimpleTypename.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SimpleTypename.hs @@ -0,0 +1,74 @@ +module PostgresqlSyntax.Ast.SimpleTypename where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Bit +import PostgresqlSyntax.Ast.Character +import PostgresqlSyntax.Ast.ConstDatetime +import PostgresqlSyntax.Ast.GenericType +import PostgresqlSyntax.Ast.Iconst +import PostgresqlSyntax.Ast.Interval +import PostgresqlSyntax.Ast.Numeric +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- SimpleTypename: +-- | GenericType +-- | Numeric +-- | Bit +-- | Character +-- | ConstDatetime +-- | ConstInterval opt_interval +-- | ConstInterval '(' Iconst ')' +-- ConstInterval: +-- | INTERVAL +-- @ +data SimpleTypename + = GenericTypeSimpleTypename GenericType + | NumericSimpleTypename Numeric + | BitSimpleTypename Bit + | CharacterSimpleTypename Character + | ConstDatetimeSimpleTypename ConstDatetime + | ConstIntervalSimpleTypename (Either (Maybe Interval) Iconst) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SimpleTypename where + toTextBuilder settings = \case + GenericTypeSimpleTypename a -> toTextBuilder settings a + NumericSimpleTypename a -> toTextBuilder settings a + BitSimpleTypename a -> toTextBuilder settings a + CharacterSimpleTypename a -> toTextBuilder settings a + ConstDatetimeSimpleTypename a -> toTextBuilder settings a + ConstIntervalSimpleTypename a -> "INTERVAL" <> either (TextBuilders.suffixMaybe (toTextBuilder settings)) (mappend " " . TextBuilders.renderInParens . toTextBuilder settings) a + parser settings = + asum + [ do + Parsers.keyword "interval" + Parser.endHead + asum + [ ConstIntervalSimpleTypename <$> Right <$> (Parsers.space *> Parsers.inParens (parser settings)), + ConstIntervalSimpleTypename <$> Left <$> optional (Parsers.space *> parser settings) + ], + ConstDatetimeSimpleTypename <$> parser settings, + NumericSimpleTypename <$> parser settings, + BitSimpleTypename <$> parser settings, + CharacterSimpleTypename <$> parser settings, + GenericTypeSimpleTypename <$> parser settings + ] + +instance Qc.Arbitrary SimpleTypename where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ GenericTypeSimpleTypename <$> Qc.arbitrary, + NumericSimpleTypename <$> Qc.arbitrary, + BitSimpleTypename <$> Qc.arbitrary, + CharacterSimpleTypename <$> Qc.arbitrary, + ConstDatetimeSimpleTypename <$> Qc.arbitrary, + ConstIntervalSimpleTypename <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SortBy.hs b/library-internal/PostgresqlSyntax/Ast/SortBy.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SortBy.hs @@ -0,0 +1,54 @@ +module PostgresqlSyntax.Ast.SortBy where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.AscDesc +import PostgresqlSyntax.Ast.NullsOrder +import PostgresqlSyntax.Ast.QualAllOp +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, many, some, sortBy, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- sortby: +-- | a_expr USING qual_all_Op opt_nulls_order +-- | a_expr opt_asc_desc opt_nulls_order +-- @ +data SortBy + = UsingSortBy AExpr QualAllOp (Maybe NullsOrder) + | AscDescSortBy AExpr (Maybe AscDesc) (Maybe NullsOrder) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SortBy where + toTextBuilder settings = \case + UsingSortBy a b c -> toTextBuilder settings a <> " USING " <> toTextBuilder settings b <> TextBuilders.suffixMaybe (toTextBuilder settings) c + AscDescSortBy a b c -> toTextBuilder settings a <> TextBuilders.suffixMaybe (toTextBuilder settings) b <> TextBuilders.suffixMaybe (toTextBuilder settings) c + parser settings = do + a <- parser settings + asum + [ do + Parsers.space1 + Parsers.keyword "using" + Parsers.space1 + Parser.endHead + b <- parser settings + c <- optional (Parsers.space1 *> parser settings) + return (UsingSortBy a b c), + do + b <- optional (Parsers.space1 *> parser settings) + c <- optional (Parsers.space1 *> parser settings) + return (AscDescSortBy a b c) + ] + +instance Qc.Arbitrary SortBy where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ UsingSortBy <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary <*> Qc.arbitrary, + AscDescSortBy <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SortClause.hs b/library-internal/PostgresqlSyntax/Ast/SortClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SortClause.hs @@ -0,0 +1,35 @@ +module PostgresqlSyntax.Ast.SortClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SortBy +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, many, some, sortBy, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- sort_clause: +-- | ORDER BY sortby_list +-- +-- sortby_list: +-- | sortby +-- | sortby_list ',' sortby +-- @ +newtype SortClause = SortClause (NonEmpty SortBy) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SortClause where + toTextBuilder settings (SortClause a) = "ORDER BY " <> TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = do + Parsers.keyphrase "order by" + Parser.endHead + Parsers.space1 + SortClause <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary SortClause where + shrink = Qc.genericShrink + arbitrary = SortClause <$> Gens.nonEmptyUpTo 7 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/SubType.hs b/library-internal/PostgresqlSyntax/Ast/SubType.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SubType.hs @@ -0,0 +1,33 @@ +module PostgresqlSyntax.Ast.SubType where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- sub_type: +-- | ANY +-- | SOME +-- | ALL +-- @ +data SubType = AnySubType | SomeSubType | AllSubType + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst SubType where + toTextBuilder _settings = \case + AnySubType -> "ANY" + SomeSubType -> "SOME" + AllSubType -> "ALL" + parser _settings = + asum + [ AnySubType <$ Parsers.keyword "any", + SomeSubType <$ Parsers.keyword "some", + AllSubType <$ Parsers.keyword "all" + ] + +instance Qc.Arbitrary SubType where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/SubqueryOp.hs b/library-internal/PostgresqlSyntax/Ast/SubqueryOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SubqueryOp.hs @@ -0,0 +1,53 @@ +module PostgresqlSyntax.Ast.SubqueryOp where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AllOp +import PostgresqlSyntax.Ast.AnyOperator +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- subquery_Op: +-- | all_Op +-- | OPERATOR '(' any_operator ')' +-- | LIKE +-- | NOT_LA LIKE +-- | ILIKE +-- | NOT_LA ILIKE +-- @ +data SubqueryOp + = AllSubqueryOp AllOp + | AnySubqueryOp AnyOperator + | LikeSubqueryOp Bool + | IlikeSubqueryOp Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SubqueryOp where + toTextBuilder settings = \case + AllSubqueryOp a -> toTextBuilder settings a + AnySubqueryOp a -> "OPERATOR " <> TextBuilders.renderInParens (toTextBuilder settings a) + LikeSubqueryOp a -> bool "" "NOT " a <> "LIKE" + IlikeSubqueryOp a -> bool "" "NOT " a <> "ILIKE" + parser settings = + asum + [ AnySubqueryOp <$> (Parsers.keyword "operator" *> Parsers.space *> Parser.endHead *> Parsers.inParens (parser settings)), + do + a <- Parsers.trueIfPresent (Parsers.keyword "not" *> Parsers.space1) + LikeSubqueryOp a <$ Parsers.keyword "like" <|> IlikeSubqueryOp a <$ Parsers.keyword "ilike", + AllSubqueryOp <$> parser settings + ] + +instance Qc.Arbitrary SubqueryOp where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ AllSubqueryOp <$> Qc.arbitrary, + AnySubqueryOp <$> Qc.arbitrary, + LikeSubqueryOp <$> Qc.arbitrary, + IlikeSubqueryOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SubstrList.hs b/library-internal/PostgresqlSyntax/Ast/SubstrList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SubstrList.hs @@ -0,0 +1,45 @@ +module PostgresqlSyntax.Ast.SubstrList where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.SubstrListFromFor +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- substr_list: +-- | a_expr substr_from substr_for +-- | a_expr substr_for substr_from +-- | a_expr substr_from +-- | a_expr substr_for +-- | expr_list +-- | EMPTY +-- @ +data SubstrList + = ExprSubstrList AExpr SubstrListFromFor + | ExprListSubstrList ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SubstrList where + toTextBuilder settings = \case + ExprSubstrList a b -> toTextBuilder settings a <> " " <> toTextBuilder settings b + ExprListSubstrList a -> toTextBuilder settings a + parser settings = + asum + [ ExprSubstrList <$> Parser.wrapToHead (parser settings) <*> (Parsers.space1 *> parser settings), + ExprListSubstrList <$> parser settings + ] + +instance Qc.Arbitrary SubstrList where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprSubstrList <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + ExprListSubstrList <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SubstrListFromFor.hs b/library-internal/PostgresqlSyntax/Ast/SubstrListFromFor.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SubstrListFromFor.hs @@ -0,0 +1,63 @@ +module PostgresqlSyntax.Ast.SubstrListFromFor where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | a_expr substr_from substr_for +-- | a_expr substr_for substr_from +-- | a_expr substr_from +-- | a_expr substr_for +-- @ +data SubstrListFromFor + = FromForSubstrListFromFor AExpr AExpr + | ForFromSubstrListFromFor AExpr AExpr + | FromSubstrListFromFor AExpr + | ForSubstrListFromFor AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SubstrListFromFor where + toTextBuilder settings = \case + FromForSubstrListFromFor a b -> "FROM " <> toTextBuilder settings a <> " FOR " <> toTextBuilder settings b + ForFromSubstrListFromFor a b -> "FOR " <> toTextBuilder settings a <> " FROM " <> toTextBuilder settings b + FromSubstrListFromFor a -> "FROM " <> toTextBuilder settings a + ForSubstrListFromFor a -> "FOR " <> toTextBuilder settings a + parser settings = + asum + [ do + a <- substrFrom + asum + [ do + b <- Parsers.space1 *> substrFor + return (FromForSubstrListFromFor a b), + return (FromSubstrListFromFor a) + ], + do + a <- substrFor + asum + [ do + b <- Parsers.space1 *> substrFrom + return (ForFromSubstrListFromFor a b), + return (ForSubstrListFromFor a) + ] + ] + where + substrFrom = Parsers.keyword "from" *> Parsers.space1 *> Parser.endHead *> parser settings + substrFor = Parsers.keyword "for" *> Parsers.space1 *> Parser.endHead *> parser settings + +instance Qc.Arbitrary SubstrListFromFor where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ FromForSubstrListFromFor <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + ForFromSubstrListFromFor <$> Gens.downscale Qc.arbitrary <*> Gens.downscale Qc.arbitrary, + FromSubstrListFromFor <$> Gens.downscale Qc.arbitrary, + ForSubstrListFromFor <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/SymbolicExprBinOp.hs b/library-internal/PostgresqlSyntax/Ast/SymbolicExprBinOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/SymbolicExprBinOp.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.SymbolicExprBinOp where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.MathOp +import PostgresqlSyntax.Ast.QualOp +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +data SymbolicExprBinOp + = MathSymbolicExprBinOp MathOp + | QualSymbolicExprBinOp QualOp + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst SymbolicExprBinOp where + toTextBuilder settings = \case + MathSymbolicExprBinOp a -> toTextBuilder settings a + QualSymbolicExprBinOp a -> toTextBuilder settings a + parser settings = + QualSymbolicExprBinOp + <$> parser settings + <|> MathSymbolicExprBinOp + <$> parser settings + +instance Qc.Arbitrary SymbolicExprBinOp where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ MathSymbolicExprBinOp <$> Qc.arbitrary, + QualSymbolicExprBinOp <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/TableFuncElement.hs b/library-internal/PostgresqlSyntax/Ast/TableFuncElement.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TableFuncElement.hs @@ -0,0 +1,40 @@ +module PostgresqlSyntax.Ast.TableFuncElement where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AnyName +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.Typename +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- TableFuncElement: +-- | ColId Typename opt_collate_clause +-- @ +-- +-- @opt_collate_clause@ is a bare alias to 'PostgresqlSyntax.Ast.AnyName'. +data TableFuncElement = TableFuncElement Ident Typename (Maybe AnyName) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TableFuncElement where + toTextBuilder settings (TableFuncElement a b c) = toTextBuilder settings a <> " " <> toTextBuilder settings b <> TextBuilders.suffixMaybe collateClause c + where + collateClause a' = "COLLATE " <> toTextBuilder settings a' + parser settings = do + a <- Parser.wrapToHead (colId settings) + Parsers.space1 + b <- parser settings + c <- optional (Parsers.space1 *> collateClause) + return (TableFuncElement a b c) + where + collateClause = Parsers.keyword "collate" *> Parsers.space1 *> Parser.endHead *> parser settings + +instance Qc.Arbitrary TableFuncElement where + shrink = Qc.genericShrink + arbitrary = TableFuncElement <$> arbitrary <*> arbitrary <*> Gens.terminatingMaybe arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/TableFuncElementList.hs b/library-internal/PostgresqlSyntax/Ast/TableFuncElementList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TableFuncElementList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.TableFuncElementList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.TableFuncElement +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- TableFuncElementList: +-- | TableFuncElement +-- | TableFuncElementList ',' TableFuncElement +-- @ +newtype TableFuncElementList = TableFuncElementList (NonEmpty TableFuncElement) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TableFuncElementList where + toTextBuilder settings (TableFuncElementList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = TableFuncElementList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary TableFuncElementList where + shrink = Qc.genericShrink + arbitrary = TableFuncElementList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/TableRef.hs b/library-internal/PostgresqlSyntax/Ast/TableRef.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TableRef.hs @@ -0,0 +1,165 @@ +module PostgresqlSyntax.Ast.TableRef + ( TableRef (..), + ) +where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.AliasClause +import PostgresqlSyntax.Ast.FuncAliasClause +import PostgresqlSyntax.Ast.FuncTable +import PostgresqlSyntax.Ast.JoinedTable +import PostgresqlSyntax.Ast.RelationExpr +import {-# SOURCE #-} PostgresqlSyntax.Ast.SelectWithParens (SelectWithParens) +import PostgresqlSyntax.Ast.TablesampleClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, head, many, some, tail, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | relation_expr opt_alias_clause +-- | relation_expr opt_alias_clause tablesample_clause +-- | func_table func_alias_clause +-- | LATERAL_P func_table func_alias_clause +-- | xmltable opt_alias_clause +-- | LATERAL_P xmltable opt_alias_clause +-- | select_with_parens opt_alias_clause +-- | LATERAL_P select_with_parens opt_alias_clause +-- | joined_table +-- | '(' joined_table ')' alias_clause +-- +-- TODO: Add xmltable +-- @ +data TableRef + = -- | + -- @ + -- | relation_expr opt_alias_clause + -- | relation_expr opt_alias_clause tablesample_clause + -- @ + RelationExprTableRef RelationExpr (Maybe AliasClause) (Maybe TablesampleClause) + | -- | + -- @ + -- | func_table func_alias_clause + -- | LATERAL_P func_table func_alias_clause + -- @ + FuncTableRef Bool FuncTable (Maybe FuncAliasClause) + | -- | + -- @ + -- | select_with_parens opt_alias_clause + -- | LATERAL_P select_with_parens opt_alias_clause + -- @ + SelectTableRef Bool SelectWithParens (Maybe AliasClause) + | -- | + -- @ + -- | joined_table + -- | '(' joined_table ')' alias_clause + -- @ + JoinTableRef JoinedTable (Maybe AliasClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TableRef where + toTextBuilder settings = \case + RelationExprTableRef a b c -> + TextBuilders.optLexemes + [ Just (toTextBuilder settings a), + fmap (toTextBuilder settings) b, + fmap (toTextBuilder settings) c + ] + FuncTableRef a b c -> + TextBuilders.optLexemes + [ if a then Just "LATERAL" else Nothing, + Just (toTextBuilder settings b), + fmap (toTextBuilder settings) c + ] + SelectTableRef a b c -> + TextBuilders.optLexemes + [ if a then Just "LATERAL" else Nothing, + Just (toTextBuilder settings b), + fmap (toTextBuilder settings) c + ] + JoinTableRef a b -> case b of + Just c -> TextBuilders.renderInParens (toTextBuilder settings a) <> " " <> toTextBuilder settings c + Nothing -> toTextBuilder settings a + + parser settings = Parser.label "table reference" (parseMaybeExtended @JoinedTable settings) + +-- | +-- 'PostgresqlSyntax.Ast.JoinedTable' embeds trivially into a bare, +-- alias-less 'TableRef' (@joined_table@ is one of @table_ref@'s +-- alternatives), and a 'TableRef' of that exact shape is recognizable back +-- as one. See 'PostgresqlSyntax.Algebra.Extends' for how this is used to +-- fold a chain of joins onto a leading 'TableRef'. +instance Refines JoinedTable TableRef where + embed a = JoinTableRef a Nothing + project = \case + JoinTableRef a Nothing -> Just a + _ -> Nothing + +-- | +-- Every @table_ref@ production except the left-recursive ones (those are +-- the @joined_table@ continuations, hosted by +-- "PostgresqlSyntax.Ast.JoinedTable"\'s +-- 'PostgresqlSyntax.Algebra.Extends' instance). +-- +-- The two @joined_table@-shaped alternatives here are /not/ left-recursive: +-- both begin with a parenthesis, so neither can loop back into this parser +-- without consuming input. They reach @'(' joined_table ')'@ through +-- 'JoinedTable'\'s own 'parseBase' rather than through a +-- 'JoinedTable' helper export. +instance LeftRecursive TableRef where + parseBase settings = + asum + [ lateralTableRef, + Parser.wrapToHead nonLateralTableRef, + relationExprTableRef, + joinedTableWithAliasTableRef, + inParensJoinedTableTableRef + ] + where + relationExprTableRef = do + relationExpr <- parser settings + Parser.endHead + optAliasClause <- optional (Parsers.space1 *> parser settings) + optTablesampleClause <- optional (Parsers.space1 *> parser settings) + return (RelationExprTableRef relationExpr optAliasClause optTablesampleClause) + lateralTableRef = do + Parsers.keyword "lateral" + Parsers.space1 + Parser.endHead + lateralableTableRef True + nonLateralTableRef = lateralableTableRef False + lateralableTableRef lateral = + asum + [ do + a <- parser settings + b <- optional (Parsers.space1 *> parser settings) + return (FuncTableRef lateral a b), + do + select <- parser settings + optAliasClause <- optional $ Parsers.space1 *> parser settings + return (SelectTableRef lateral select optAliasClause) + ] + inParensJoinedTableTableRef = JoinTableRef <$> parseBase @JoinedTable settings <*> pure Nothing + joinedTableWithAliasTableRef = do + jt <- Parser.wrapToHead (Parsers.inParens (parser settings)) + Parsers.space1 + alias <- parser settings + return (JoinTableRef jt (Just alias)) + +instance Qc.Arbitrary TableRef where + shrink = Qc.genericShrink + arbitrary = + Qc.sized $ \n -> + if n <= 1 + then RelationExprTableRef <$> Qc.arbitrary <*> pure Nothing <*> pure Nothing + else + Qc.oneof + [ RelationExprTableRef <$> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary, + FuncTableRef <$> Qc.arbitrary <*> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary, + SelectTableRef <$> Qc.arbitrary <*> Gens.downscale Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary, + JoinTableRef <$> Qc.arbitrary <*> Gens.terminatingMaybe Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/TableRef.hs-boot b/library-internal/PostgresqlSyntax/Ast/TableRef.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TableRef.hs-boot @@ -0,0 +1,24 @@ +module PostgresqlSyntax.Ast.TableRef where + +import PostgresqlSyntax.Algebra (IsAst, LeftRecursive, Refines) +import {-# SOURCE #-} PostgresqlSyntax.Ast.JoinedTable (JoinedTable) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data TableRef + +instance Show TableRef + +instance Eq TableRef + +instance Ord TableRef + +instance Data TableRef + +instance IsAst TableRef + +instance Arbitrary TableRef + +instance Refines JoinedTable TableRef + +instance LeftRecursive TableRef diff --git a/library-internal/PostgresqlSyntax/Ast/TablesampleClause.hs b/library-internal/PostgresqlSyntax/Ast/TablesampleClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TablesampleClause.hs @@ -0,0 +1,47 @@ +module PostgresqlSyntax.Ast.TablesampleClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.FuncName +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- tablesample_clause: +-- | TABLESAMPLE func_name '(' expr_list ')' opt_repeatable_clause +-- @ +-- +-- @opt_repeatable_clause@ is a bare alias to 'PostgresqlSyntax.Ast.AExpr'. +data TablesampleClause = TablesampleClause FuncName ExprList (Maybe AExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TablesampleClause where + toTextBuilder settings (TablesampleClause a b c) = + "TABLESAMPLE " <> toTextBuilder settings a <> " (" <> toTextBuilder settings b <> ")" <> TextBuilders.suffixMaybe repeatableClause c + where + repeatableClause a' = "REPEATABLE (" <> toTextBuilder settings a' <> ")" + parser settings = do + Parsers.keyword "tablesample" + Parsers.space1 + Parser.endHead + a <- parser settings + Parsers.space + b <- Parsers.inParens (parser settings) + c <- optional (Parsers.space *> repeatableClause) + return (TablesampleClause a b c) + where + repeatableClause = do + Parsers.keyword "repeatable" + Parsers.space + Parsers.inParens (Parser.endHead *> parser settings) + +instance Qc.Arbitrary TablesampleClause where + shrink = Qc.genericShrink + arbitrary = TablesampleClause <$> arbitrary <*> arbitrary <*> Gens.terminatingMaybe (Gens.downscale arbitrary) diff --git a/library-internal/PostgresqlSyntax/Ast/TargetEl.hs b/library-internal/PostgresqlSyntax/Ast/TargetEl.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TargetEl.hs @@ -0,0 +1,70 @@ +module PostgresqlSyntax.Ast.TargetEl where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- target_el: +-- | a_expr AS ColLabel +-- | a_expr IDENT +-- | a_expr +-- | '*' +-- @ +data TargetEl + = AliasedExprTargetEl AExpr Ident + | ImplicitlyAliasedExprTargetEl AExpr Ident + | ExprTargetEl AExpr + | AsteriskTargetEl + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TargetEl where + toTextBuilder settings = \case + AliasedExprTargetEl a b -> toTextBuilder settings a <> " AS " <> toTextBuilder settings b + ImplicitlyAliasedExprTargetEl a b -> toTextBuilder settings a <> " " <> toTextBuilder settings b + ExprTargetEl a -> toTextBuilder settings a + AsteriskTargetEl -> "*" + + parser settings = + Parser.label "target" $ + asum + [ do + expr <- parser settings + asum + [ do + Parsers.space1 + asum + [ AliasedExprTargetEl expr <$> (Parsers.keyword "as" *> Parsers.space1 *> Parser.endHead *> colLabel), + ImplicitlyAliasedExprTargetEl expr <$> parser settings + ], + pure (ExprTargetEl expr) + ], + AsteriskTargetEl <$ Parsers.char '*' + ] + where + -- Duplicated from "PostgresqlSyntax.Parsing"'s @colLabel@ (a + -- bare-aliased 'PostgresqlSyntax.Ast.Ident' whose own, more + -- permissive parser lives above this module in the dependency + -- order), mirroring the 'PostgresqlSyntax.Ast.AnyName' precedent. + colLabel = + Parser.label "column label" $ + Parsers.keywordNameFromSet UnquotedIdent KeywordSet.keyword + <|> parser settings + +instance Qc.Arbitrary TargetEl where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ pure AsteriskTargetEl, + AliasedExprTargetEl <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + ImplicitlyAliasedExprTargetEl <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + ExprTargetEl <$> Gens.downscale Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/TargetList.hs b/library-internal/PostgresqlSyntax/Ast/TargetList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TargetList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.TargetList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.TargetEl +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- target_list: +-- | target_el +-- | target_list ',' target_el +-- @ +newtype TargetList = TargetList (NonEmpty TargetEl) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TargetList where + toTextBuilder settings (TargetList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = TargetList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary TargetList where + shrink = Qc.genericShrink + arbitrary = TargetList <$> Gens.nonEmptyUpTo 7 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Targeting.hs b/library-internal/PostgresqlSyntax/Ast/Targeting.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Targeting.hs @@ -0,0 +1,65 @@ +module PostgresqlSyntax.Ast.Targeting where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.TargetList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- simple_select: +-- | SELECT opt_all_clause opt_target_list ... +-- | SELECT distinct_clause target_list ... +-- +-- distinct_clause: +-- | DISTINCT +-- | DISTINCT ON '(' expr_list ')' +-- @ +data Targeting + = NormalTargeting TargetList + | AllTargeting (Maybe TargetList) + | DistinctTargeting (Maybe ExprList) TargetList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Targeting where + toTextBuilder settings = \case + NormalTargeting a -> toTextBuilder settings a + AllTargeting a -> "ALL" <> TextBuilders.suffixMaybe (toTextBuilder settings) a + DistinctTargeting a b -> "DISTINCT" <> TextBuilders.suffixMaybe onExpressionsClause a <> " " <> toTextBuilder settings b + where + onExpressionsClause a = "ON (" <> toTextBuilder settings a <> ")" + parser settings = distinct <|> allWithTargetList <|> allP <|> normal + where + normal = NormalTargeting <$> parser settings + allWithTargetList = do + Parsers.keyword "all" + Parsers.space1 + AllTargeting . Just <$> parser settings + allP = Parsers.keyword "all" $> AllTargeting Nothing + distinct = do + Parsers.keyword "distinct" + Parsers.space1 + Parser.endHead + optOn <- optional (onExpressionsClause <* Parsers.space1) + targetList <- parser settings + return (DistinctTargeting optOn targetList) + onExpressionsClause = do + Parsers.keyword "on" + Parsers.space1 + Parser.endHead + ExprList <$> Parsers.inParens (Parsers.sep1 Parsers.commaSeparator (parser settings)) + +instance Qc.Arbitrary Targeting where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ NormalTargeting <$> Qc.arbitrary, + AllTargeting <$> Qc.arbitrary, + DistinctTargeting <$> Gens.terminatingMaybe Qc.arbitrary <*> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/Timezone.hs b/library-internal/PostgresqlSyntax/Ast/Timezone.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Timezone.hs @@ -0,0 +1,30 @@ +module PostgresqlSyntax.Ast.Timezone where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_timezone: +-- | WITH_LA TIME ZONE +-- | WITHOUT TIME ZONE +-- | EMPTY +-- @ +newtype Timezone = Timezone Bool + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Timezone where + toTextBuilder _settings (Timezone a) = if a then "WITHOUT TIME ZONE" else "WITH TIME ZONE" + parser _settings = + Timezone + <$> asum + [ False <$ Parsers.keyphrase "with time zone", + True <$ Parsers.keyphrase "without time zone" + ] + +instance Qc.Arbitrary Timezone where + shrink = Qc.genericShrink + arbitrary = Timezone <$> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/TrimList.hs b/library-internal/PostgresqlSyntax/Ast/TrimList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TrimList.hs @@ -0,0 +1,45 @@ +module PostgresqlSyntax.Ast.TrimList where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- trim_list: +-- | a_expr FROM expr_list +-- | FROM expr_list +-- | expr_list +-- @ +data TrimList + = ExprFromExprListTrimList AExpr ExprList + | FromExprListTrimList ExprList + | ExprListTrimList ExprList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TrimList where + toTextBuilder settings = \case + ExprFromExprListTrimList a b -> toTextBuilder settings a <> " FROM " <> toTextBuilder settings b + FromExprListTrimList a -> "FROM " <> toTextBuilder settings a + ExprListTrimList a -> toTextBuilder settings a + parser settings = + asum + [ ExprFromExprListTrimList <$> Parser.wrapToHead (parser settings) <*> (Parsers.space1 *> Parsers.keyword "from" *> Parsers.space1 *> Parser.endHead *> parser settings), + FromExprListTrimList <$> (Parsers.keyword "from" *> Parsers.space1 *> Parser.endHead *> parser settings), + ExprListTrimList <$> parser settings + ] + +instance Qc.Arbitrary TrimList where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprFromExprListTrimList <$> Gens.downscale Qc.arbitrary <*> Qc.arbitrary, + FromExprListTrimList <$> Qc.arbitrary, + ExprListTrimList <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/TrimModifier.hs b/library-internal/PostgresqlSyntax/Ast/TrimModifier.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TrimModifier.hs @@ -0,0 +1,33 @@ +module PostgresqlSyntax.Ast.TrimModifier where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | TRIM '(' BOTH trim_list ')' +-- | TRIM '(' LEADING trim_list ')' +-- | TRIM '(' TRAILING trim_list ')' +-- @ +data TrimModifier = BothTrimModifier | LeadingTrimModifier | TrailingTrimModifier + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst TrimModifier where + toTextBuilder _settings = \case + BothTrimModifier -> "BOTH" + LeadingTrimModifier -> "LEADING" + TrailingTrimModifier -> "TRAILING" + parser _settings = + BothTrimModifier + <$ Parsers.keyword "both" + <|> LeadingTrimModifier + <$ Parsers.keyword "leading" + <|> TrailingTrimModifier + <$ Parsers.keyword "trailing" + +instance Qc.Arbitrary TrimModifier where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/TypeList.hs b/library-internal/PostgresqlSyntax/Ast/TypeList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TypeList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.TypeList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Typename +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- type_list: +-- | Typename +-- | type_list ',' Typename +-- @ +newtype TypeList = TypeList (NonEmpty Typename) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TypeList where + toTextBuilder settings (TypeList a) = TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = TypeList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary TypeList where + shrink = Qc.genericShrink + arbitrary = TypeList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/Typename.hs b/library-internal/PostgresqlSyntax/Ast/Typename.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Typename.hs @@ -0,0 +1,46 @@ +module PostgresqlSyntax.Ast.Typename where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.SimpleTypename +import PostgresqlSyntax.Ast.TypenameArrayDimensions +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import PostgresqlSyntax.Settings (resolveNullabilityMarkers) +import qualified Test.QuickCheck as Qc + +data Typename + = Typename + Bool + SimpleTypename + Bool + (Maybe (TypenameArrayDimensions, Bool)) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Typename where + toTextBuilder settings (Typename setof base typeNullable arrayDims) = + bool "" "SETOF " setof + <> toTextBuilder settings base + <> marker typeNullable + <> foldMap renderArray arrayDims + where + markersOn = resolveNullabilityMarkers settings + marker flag = if markersOn && flag then "?" else mempty + renderArray (dims, flag) = toTextBuilder settings dims <> marker flag + parser settings = do + setof <- option False (Parsers.keyword "setof" *> Parsers.space1 $> True) + base <- parser settings + Parser.endHead + let marker = if resolveNullabilityMarkers settings then Parsers.trueIfPresent (Parsers.char '?') else pure False + typeNullable <- marker + arrayDims <- optional $ do + dims <- parser settings + flag <- marker + pure (dims, flag) + pure (Typename setof base typeNullable arrayDims) + +instance Qc.Arbitrary Typename where + shrink = Qc.genericShrink + arbitrary = Typename <$> arbitrary <*> arbitrary <*> pure False <*> ((\a -> (,) a False) <$$> arbitrary) + where + (<$$>) = fmap . fmap diff --git a/library-internal/PostgresqlSyntax/Ast/TypenameArrayDimensions.hs b/library-internal/PostgresqlSyntax/Ast/TypenameArrayDimensions.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/TypenameArrayDimensions.hs @@ -0,0 +1,45 @@ +module PostgresqlSyntax.Ast.TypenameArrayDimensions where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ArrayBounds +import PostgresqlSyntax.Ast.Iconst +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- Part of the Typename specification responsible for the choice between the following: +-- | opt_array_bounds +-- | ARRAY '[' Iconst ']' +-- | ARRAY +-- @ +data TypenameArrayDimensions + = BoundsTypenameArrayDimensions ArrayBounds + | ExplicitTypenameArrayDimensions (Maybe Iconst) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst TypenameArrayDimensions where + toTextBuilder settings = \case + BoundsTypenameArrayDimensions a -> toTextBuilder settings a + ExplicitTypenameArrayDimensions a -> " ARRAY" <> foldMap (TextBuilders.renderInBrackets . toTextBuilder settings) a + parser settings = + asum + [ do + Parsers.space1 + Parsers.keyword "array" + Parser.endHead + ExplicitTypenameArrayDimensions <$> optional (Parsers.space *> Parsers.inBrackets (parser settings)), + BoundsTypenameArrayDimensions <$> (Parsers.space *> parser settings) + ] + +instance Qc.Arbitrary TypenameArrayDimensions where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ BoundsTypenameArrayDimensions <$> Qc.arbitrary, + ExplicitTypenameArrayDimensions <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/UpdateStmt.hs b/library-internal/PostgresqlSyntax/Ast/UpdateStmt.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/UpdateStmt.hs @@ -0,0 +1,65 @@ +module PostgresqlSyntax.Ast.UpdateStmt where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FromClause +import PostgresqlSyntax.Ast.RelationExprOptAlias (RelationExprOptAlias) +import PostgresqlSyntax.Ast.ReturningClause +import PostgresqlSyntax.Ast.SetClauseList +import PostgresqlSyntax.Ast.WhereOrCurrentClause +import {-# SOURCE #-} PostgresqlSyntax.Ast.WithClause (WithClause) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- UpdateStmt: +-- | opt_with_clause UPDATE relation_expr_opt_alias +-- SET set_clause_list +-- from_clause +-- where_or_current_clause +-- returning_clause +-- @ +data UpdateStmt = UpdateStmt (Maybe WithClause) RelationExprOptAlias SetClauseList (Maybe FromClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst UpdateStmt where + toTextBuilder settings (UpdateStmt a b c d e f) = + TextBuilders.prefixMaybe (toTextBuilder settings) a + <> "UPDATE " + <> toTextBuilder settings b + <> " " + <> "SET " + <> toTextBuilder settings c + <> TextBuilders.suffixMaybe (toTextBuilder settings) d + <> TextBuilders.suffixMaybe (toTextBuilder settings) e + <> TextBuilders.suffixMaybe (toTextBuilder settings) f + parser settings = do + a <- optional (Parser.wrapToHead (parser settings) <* Parsers.space1) + Parsers.keyword "update" + Parsers.space1 + Parser.endHead + b <- parser settings + Parsers.space1 + Parsers.keyword "set" + Parsers.space1 + c <- parser settings + d <- optional (Parsers.space1 *> parser settings) + e <- optional (Parsers.space1 *> parser settings) + f <- optional (Parsers.space1 *> parser settings) + return (UpdateStmt a b c d e f) + +instance Qc.Arbitrary UpdateStmt where + shrink = Qc.genericShrink + arbitrary = + UpdateStmt + <$> Gens.terminatingMaybe (Gens.downscale Qc.arbitrary) + <*> Qc.arbitrary + <*> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/UsingClause.hs b/library-internal/PostgresqlSyntax/Ast/UsingClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/UsingClause.hs @@ -0,0 +1,28 @@ +module PostgresqlSyntax.Ast.UsingClause where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.FromList +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- using_clause: +-- | USING from_list +-- | /*EMPTY*/ +-- @ +newtype UsingClause = UsingClause FromList + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst UsingClause where + toTextBuilder settings (UsingClause a) = "USING " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "using" + Parsers.space1 + UsingClause <$> parser settings + +instance Qc.Arbitrary UsingClause where + shrink = Qc.genericShrink + arbitrary = UsingClause <$> Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/ValuesClause.hs b/library-internal/PostgresqlSyntax/Ast/ValuesClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/ValuesClause.hs @@ -0,0 +1,40 @@ +module PostgresqlSyntax.Ast.ValuesClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- values_clause: +-- | VALUES '(' expr_list ')' +-- | values_clause ',' '(' expr_list ')' +-- @ +newtype ValuesClause = ValuesClause (NonEmpty ExprList) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst ValuesClause where + toTextBuilder settings (ValuesClause a) = "VALUES " <> TextBuilders.commaNonEmpty (TextBuilders.renderInParens . toTextBuilder settings) a + parser settings = do + Parsers.keyword "values" + Parsers.space + ValuesClause <$> Parsers.sep1 Parsers.commaSeparator row + where + row = do + Parsers.char '(' + Parser.endHead + Parsers.space + a <- ExprList <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + Parsers.space + Parsers.char ')' + return a + +instance Qc.Arbitrary ValuesClause where + shrink = Qc.genericShrink + arbitrary = ValuesClause <$> Gens.nonEmptyUpTo 7 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/VerbalExprBinOp.hs b/library-internal/PostgresqlSyntax/Ast/VerbalExprBinOp.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/VerbalExprBinOp.hs @@ -0,0 +1,38 @@ +module PostgresqlSyntax.Ast.VerbalExprBinOp where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | LIKE +-- | NOT_LA LIKE +-- | ILIKE +-- | NOT_LA ILIKE +-- | SIMILAR TO +-- | NOT_LA SIMILAR TO +-- @ +data VerbalExprBinOp + = LikeVerbalExprBinOp + | IlikeVerbalExprBinOp + | SimilarToVerbalExprBinOp + deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) + +instance IsAst VerbalExprBinOp where + toTextBuilder _settings = \case + LikeVerbalExprBinOp -> "LIKE" + IlikeVerbalExprBinOp -> "ILIKE" + SimilarToVerbalExprBinOp -> "SIMILAR TO" + parser _settings = + asum + [ LikeVerbalExprBinOp <$ Parsers.keyword "like", + IlikeVerbalExprBinOp <$ Parsers.keyword "ilike", + SimilarToVerbalExprBinOp <$ Parsers.keyphrase "similar to" + ] + +instance Qc.Arbitrary VerbalExprBinOp where + shrink = Qc.genericShrink + arbitrary = Qc.elements [minBound .. maxBound] diff --git a/library-internal/PostgresqlSyntax/Ast/WhenClause.hs b/library-internal/PostgresqlSyntax/Ast/WhenClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WhenClause.hs @@ -0,0 +1,35 @@ +module PostgresqlSyntax.Ast.WhenClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- when_clause: +-- | WHEN a_expr THEN a_expr +-- @ +data WhenClause = WhenClause AExpr AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WhenClause where + toTextBuilder settings (WhenClause a b) = "WHEN " <> toTextBuilder settings a <> " THEN " <> toTextBuilder settings b + parser settings = do + Parsers.keyword "when" + Parsers.space1 + Parser.endHead + a <- parser settings + Parsers.space1 + Parsers.keyword "then" + Parsers.space1 + b <- parser settings + return (WhenClause a b) + +instance Qc.Arbitrary WhenClause where + shrink = Qc.genericShrink + arbitrary = WhenClause <$> Gens.downscale arbitrary <*> Gens.downscale arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WhenClauseList.hs b/library-internal/PostgresqlSyntax/Ast/WhenClauseList.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WhenClauseList.hs @@ -0,0 +1,27 @@ +module PostgresqlSyntax.Ast.WhenClauseList where + +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.WhenClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- when_clause_list: +-- | when_clause +-- | when_clause_list when_clause +-- @ +newtype WhenClauseList = WhenClauseList (NonEmpty WhenClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WhenClauseList where + toTextBuilder settings (WhenClauseList a) = TextBuilders.spaceNonEmpty (toTextBuilder settings) a + parser settings = WhenClauseList <$> Parsers.sep1 Parsers.space1 (parser settings) + +instance Qc.Arbitrary WhenClauseList where + shrink = Qc.genericShrink + arbitrary = WhenClauseList <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WhereClause.hs b/library-internal/PostgresqlSyntax/Ast/WhereClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WhereClause.hs @@ -0,0 +1,31 @@ +module PostgresqlSyntax.Ast.WhereClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- where_clause: +-- | WHERE a_expr +-- | /*EMPTY*/ +-- @ +newtype WhereClause = WhereClause AExpr + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WhereClause where + toTextBuilder settings (WhereClause a) = "WHERE " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "where" + Parsers.space1 + Parser.endHead + WhereClause <$> parser settings + +instance Qc.Arbitrary WhereClause where + shrink = Qc.genericShrink + arbitrary = WhereClause <$> Gens.downscale Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WhereOrCurrentClause.hs b/library-internal/PostgresqlSyntax/Ast/WhereOrCurrentClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WhereOrCurrentClause.hs @@ -0,0 +1,52 @@ +module PostgresqlSyntax.Ast.WhereOrCurrentClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import {-# SOURCE #-} PostgresqlSyntax.Ast.AExpr (AExpr) +import PostgresqlSyntax.Ast.Ident +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- | WHERE a_expr +-- | WHERE CURRENT_P OF cursor_name +-- | /*EMPTY*/ +-- @ +-- +-- @cursor_name@ is a bare alias to 'PostgresqlSyntax.Ast.Ident'. +data WhereOrCurrentClause + = ExprWhereOrCurrentClause AExpr + | CursorWhereOrCurrentClause Ident + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WhereOrCurrentClause where + toTextBuilder settings = \case + ExprWhereOrCurrentClause a -> "WHERE " <> toTextBuilder settings a + CursorWhereOrCurrentClause a -> "WHERE CURRENT OF " <> toTextBuilder settings a + parser settings = do + Parsers.keyword "where" + Parsers.space1 + Parser.endHead + asum + [ do + Parsers.keyword "current" + Parsers.space1 + Parsers.keyword "of" + Parsers.space1 + Parser.endHead + a <- colId settings + return (CursorWhereOrCurrentClause a), + ExprWhereOrCurrentClause <$> parser settings + ] + +instance Qc.Arbitrary WhereOrCurrentClause where + shrink = Qc.genericShrink + arbitrary = + Qc.oneof + [ ExprWhereOrCurrentClause <$> Gens.downscale Qc.arbitrary, + CursorWhereOrCurrentClause <$> Qc.arbitrary + ] diff --git a/library-internal/PostgresqlSyntax/Ast/WindowClause.hs b/library-internal/PostgresqlSyntax/Ast/WindowClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WindowClause.hs @@ -0,0 +1,32 @@ +module PostgresqlSyntax.Ast.WindowClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.WindowDefinition +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude hiding (filter, many, some, try) +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- window_clause: +-- | WINDOW window_definition_list +-- | /*EMPTY*/ +-- @ +newtype WindowClause = WindowClause (NonEmpty WindowDefinition) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WindowClause where + toTextBuilder settings (WindowClause a) = "WINDOW " <> TextBuilders.commaNonEmpty (toTextBuilder settings) a + parser settings = do + Parsers.keyword "window" + Parser.endHead + Parsers.space1 + WindowClause <$> Parsers.sep1 Parsers.commaSeparator (parser settings) + +instance Qc.Arbitrary WindowClause where + shrink = Qc.genericShrink + arbitrary = WindowClause <$> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WindowDefinition.hs b/library-internal/PostgresqlSyntax/Ast/WindowDefinition.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WindowDefinition.hs @@ -0,0 +1,26 @@ +module PostgresqlSyntax.Ast.WindowDefinition where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.WindowSpecification +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- window_definition: +-- | ColId AS window_specification +-- @ +data WindowDefinition = WindowDefinition Ident WindowSpecification + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WindowDefinition where + toTextBuilder settings (WindowDefinition a b) = toTextBuilder settings a <> " AS " <> toTextBuilder settings b + parser settings = WindowDefinition <$> (colId settings <* Parsers.space1 <* Parsers.keyword "as" <* Parsers.space1 <* Parser.endHead) <*> parser settings + +instance Qc.Arbitrary WindowDefinition where + shrink = Qc.genericShrink + arbitrary = WindowDefinition <$> arbitrary <*> arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WindowExclusionClause.hs b/library-internal/PostgresqlSyntax/Ast/WindowExclusionClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WindowExclusionClause.hs @@ -0,0 +1,49 @@ +module PostgresqlSyntax.Ast.WindowExclusionClause where + +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- opt_window_exclusion_clause: +-- | EXCLUDE CURRENT_P ROW +-- | EXCLUDE GROUP_P +-- | EXCLUDE TIES +-- | EXCLUDE NO OTHERS +-- | EMPTY +-- @ +data WindowExclusionClause + = CurrentRowWindowExclusionClause + | GroupWindowExclusionClause + | TiesWindowExclusionClause + | NoOthersWindowExclusionClause + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WindowExclusionClause where + toTextBuilder _settings = \case + CurrentRowWindowExclusionClause -> "EXCLUDE CURRENT ROW" + GroupWindowExclusionClause -> "EXCLUDE GROUP" + TiesWindowExclusionClause -> "EXCLUDE TIES" + NoOthersWindowExclusionClause -> "EXCLUDE NO OTHERS" + parser _settings = + CurrentRowWindowExclusionClause + <$ Parsers.keyphrase "exclude current row" + <|> GroupWindowExclusionClause + <$ Parsers.keyphrase "exclude group" + <|> TiesWindowExclusionClause + <$ Parsers.keyphrase "exclude ties" + <|> NoOthersWindowExclusionClause + <$ Parsers.keyphrase "exclude no others" + +instance Qc.Arbitrary WindowExclusionClause where + shrink = Qc.genericShrink + arbitrary = + Qc.elements + [ CurrentRowWindowExclusionClause, + GroupWindowExclusionClause, + TiesWindowExclusionClause, + NoOthersWindowExclusionClause + ] diff --git a/library-internal/PostgresqlSyntax/Ast/WindowSpecification.hs b/library-internal/PostgresqlSyntax/Ast/WindowSpecification.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WindowSpecification.hs @@ -0,0 +1,79 @@ +module PostgresqlSyntax.Ast.WindowSpecification where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.ExprList +import PostgresqlSyntax.Ast.FrameClause +import PostgresqlSyntax.Ast.Ident +import PostgresqlSyntax.Ast.SortClause +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- window_specification: +-- | '(' opt_existing_window_name opt_partition_clause +-- opt_sort_clause opt_frame_clause ')' +-- +-- opt_existing_window_name: +-- | ColId +-- | EMPTY +-- +-- opt_partition_clause: +-- | PARTITION BY expr_list +-- | EMPTY +-- @ +-- +-- @existing_window_name@ and @partition_clause@ are bare aliases to +-- 'PostgresqlSyntax.Ast.Ident' (ColId) and 'PostgresqlSyntax.Ast.ExprList' +-- respectively. +data WindowSpecification = WindowSpecification (Maybe Ident) (Maybe ExprList) (Maybe SortClause) (Maybe FrameClause) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WindowSpecification where + toTextBuilder settings (WindowSpecification a b c d) = + TextBuilders.renderInParens $ + TextBuilders.optLexemes + [ fmap (toTextBuilder settings) a, + fmap (mappend "PARTITION BY " . toTextBuilder settings) b, + fmap (toTextBuilder settings) c, + fmap (toTextBuilder settings) d + ] + parser settings = + Parsers.inParens $ + asum + [ do + a <- parser settings + return (WindowSpecification Nothing Nothing Nothing (Just a)), + do + a <- parser settings + b <- optional (Parsers.space1 *> parser settings) + return (WindowSpecification Nothing Nothing (Just a) b), + do + a <- partitionByClause + b <- optional (Parsers.space1 *> parser settings) + c <- optional (Parsers.space1 *> parser settings) + return (WindowSpecification Nothing (Just a) b c), + do + a <- colId settings + b <- optional (Parsers.space1 *> partitionByClause) + c <- optional (Parsers.space1 *> parser settings) + d <- optional (Parsers.space1 *> parser settings) + return (WindowSpecification (Just a) b c d), + pure (WindowSpecification Nothing Nothing Nothing Nothing) + ] + where + partitionByClause = Parsers.keyphrase "partition by" *> Parsers.space1 *> Parser.endHead *> (ExprList <$> Parsers.sep1 Parsers.commaSeparator (parser settings)) + +instance Qc.Arbitrary WindowSpecification where + shrink = Qc.genericShrink + arbitrary = + WindowSpecification + <$> Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary + <*> Gens.terminatingMaybe Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WithClause.hs b/library-internal/PostgresqlSyntax/Ast/WithClause.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WithClause.hs @@ -0,0 +1,36 @@ +module PostgresqlSyntax.Ast.WithClause where + +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import PostgresqlSyntax.Ast.CommonTableExpr (CommonTableExpr) +import qualified PostgresqlSyntax.Helpers.Gens as Gens +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.TextBuilders as TextBuilders +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- ==== References +-- @ +-- with_clause: +-- | WITH cte_list +-- | WITH_LA cte_list +-- | WITH RECURSIVE cte_list +-- @ +data WithClause = WithClause Bool (NonEmpty CommonTableExpr) + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst WithClause where + toTextBuilder settings (WithClause a b) = + "WITH " <> bool "" "RECURSIVE " a <> TextBuilders.commaNonEmpty (toTextBuilder settings) b + parser settings = Parser.label "with clause" $ do + Parsers.keyword "with" + Parsers.space1 + Parser.endHead + recursive <- option False (True <$ Parsers.keyword "recursive" <* Parsers.space1) + cteList <- Parsers.sep1 Parsers.commaSeparator (parser settings) + return (WithClause recursive cteList) + +instance Qc.Arbitrary WithClause where + shrink = Qc.genericShrink + arbitrary = WithClause <$> arbitrary <*> Gens.nonEmptyUpTo 6 Qc.arbitrary diff --git a/library-internal/PostgresqlSyntax/Ast/WithClause.hs-boot b/library-internal/PostgresqlSyntax/Ast/WithClause.hs-boot new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/WithClause.hs-boot @@ -0,0 +1,19 @@ +module PostgresqlSyntax.Ast.WithClause where + +import PostgresqlSyntax.Algebra (IsAst) +import PostgresqlSyntax.Prelude (Data, Eq, Ord, Show) +import Test.QuickCheck (Arbitrary) + +data WithClause + +instance Show WithClause + +instance Eq WithClause + +instance Ord WithClause + +instance Data WithClause + +instance IsAst WithClause + +instance Arbitrary WithClause diff --git a/library-internal/PostgresqlSyntax/Ast/Xconst.hs b/library-internal/PostgresqlSyntax/Ast/Xconst.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Ast/Xconst.hs @@ -0,0 +1,34 @@ +module PostgresqlSyntax.Ast.Xconst where + +import qualified Data.Text as Text +import qualified HeadedMegaparsec as Parser +import PostgresqlSyntax.Algebra +import qualified PostgresqlSyntax.Helpers.Parsers as Parsers +import qualified PostgresqlSyntax.Helpers.Shrinks as Shrinks +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc +import qualified TextBuilder + +-- | +-- ==== References +-- @ +-- XCONST +-- @ +newtype Xconst = Xconst Text + deriving (Show, Generic, Eq, Ord, Data) + +instance IsAst Xconst where + toTextBuilder _settings (Xconst a) = "X'" <> TextBuilder.text a <> "'" + parser _settings = Parser.label "hex literal" $ do + Parsers.string' "x'" + Parser.endHead + a <- Parsers.takeWhile1P (Just "Hex digit") Predicate.hexDigit + Parsers.char '\'' + return (Xconst a) + +instance Qc.Arbitrary Xconst where + shrink (Xconst a) = Xconst <$> Shrinks.nonEmptyText a + arbitrary = do + len <- Qc.choose (1, 100) + Xconst . Text.pack <$> Qc.vectorOf len (Qc.elements "0123456789abcdefABCDEF") diff --git a/library-internal/PostgresqlSyntax/CharSet.hs b/library-internal/PostgresqlSyntax/CharSet.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/CharSet.hs @@ -0,0 +1,21 @@ +module PostgresqlSyntax.CharSet where + +import qualified Data.Text as Text +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude + +{-# NOINLINE symbolicBinOp #-} +symbolicBinOp :: HashSet Char +symbolicBinOp = KeywordSet.symbolicBinOp & toList & mconcat & Text.unpack & fromList + +{-# NOINLINE hexDigit #-} +hexDigit :: HashSet Char +hexDigit = fromList "0123456789abcdefABCDEF" + +{-# NOINLINE op #-} +op :: HashSet Char +op = fromList "+-*/<>=~!@#%^&|`?" + +{-# NOINLINE prohibitionLiftingOp #-} +prohibitionLiftingOp :: HashSet Char +prohibitionLiftingOp = fromList "~!@#%^&|`?" diff --git a/library-internal/PostgresqlSyntax/Extras/Error.hs b/library-internal/PostgresqlSyntax/Extras/Error.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Extras/Error.hs @@ -0,0 +1,40 @@ +-- | +-- Generic helpers for Error handling in HeadedMegaparsec. +module PostgresqlSyntax.Extras.Error where + +import PostgresqlSyntax.Prelude hiding (head) +import Text.Megaparsec + +-- | Render all Megaparsec parsing errors as a list of position ('Text.Megaparsec.SourcePos') and messages. +errorBundlePrettyStruct :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + NonEmpty (SourcePos, String) +errorBundlePrettyStruct ParseErrorBundle {..} = + fst $ attachSourcePosAndMessage renderError bundleErrors bundlePosState + where + renderError epos e = (epos, parseErrorTextPretty e) + +-- | A custom version of 'Text.Megaparsec.attachSourcePos' to provide the NonEmpty list of errors with their position while only traversing the errors list once. +attachSourcePosAndMessage :: + (TraversableStream s) => + -- | Format function for a single 'ParseError' and its 'SourcePos' + (SourcePos -> ParseError s e -> (SourcePos, String)) -> + -- | The collection of items + NonEmpty (ParseError s e) -> + -- | Initial 'PosState' + PosState s -> + -- | The collection with 'SourcePos'es added and the final 'PosState' + (NonEmpty (SourcePos, String), PosState s) +attachSourcePosAndMessage format xs pst0 = + swap $ mapAccumL step pst0 xs + where + step pst a = + let pst' = reachOffsetNoLine (errorOffset a) pst + in (pst', format (pstateSourcePos pst') a) diff --git a/library-internal/PostgresqlSyntax/Extras/HeadedMegaparsec.hs b/library-internal/PostgresqlSyntax/Extras/HeadedMegaparsec.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Extras/HeadedMegaparsec.hs @@ -0,0 +1,133 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-dodgy-imports -Wno-unused-imports #-} + +-- | +-- Generic helpers for HeadedMegaparsec. +module PostgresqlSyntax.Extras.HeadedMegaparsec where + +import Control.Applicative.Combinators hiding (some) +import Control.Applicative.Combinators.NonEmpty +import qualified Data.Text as Text +import HeadedMegaparsec hiding (string) +import PostgresqlSyntax.Extras.Error (errorBundlePrettyStruct) +import PostgresqlSyntax.Prelude hiding (bit, expr, filter, head, many, option, some, sortBy, tail, try) +import Text.Megaparsec (Parsec, Stream, TraversableStream, VisualStream) +import qualified Text.Megaparsec as Megaparsec +import qualified Text.Megaparsec.Char as MegaparsecChar +import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer + +-- $setup +-- >>> testParser parser = either putStr print . run parser + +-- * Executors + +run :: (Ord err, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent err) => HeadedParsec err strm a -> strm -> Either String a +run p = first Megaparsec.errorBundlePretty . runParser p + +-- | +-- Run the parser but returns all the error messages separated, along with their offset in the parsed message. +runParserWithErrorPos :: (Show (Megaparsec.Token strm), Show e, Ord e, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent e) => HeadedParsec e strm a -> strm -> Either (NonEmpty (Int, String)) a +runParserWithErrorPos p s = case runParser p s of + Left err -> Left (extractor <$> Megaparsec.bundleErrors err) + Right v -> Right v + where + extractor x = (Megaparsec.errorOffset x, Megaparsec.parseErrorPretty x) + +-- | +-- Like 'runParserWithErrorPos' but pairs each error with its +-- ('Megaparsec.SourcePos') in the parsed message instead of a raw offset. +runParserWithSourcePosError :: (Show (Megaparsec.Token strm), Show e, Ord e, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent e) => HeadedParsec e strm a -> strm -> Either (NonEmpty (Megaparsec.SourcePos, String)) a +runParserWithSourcePosError p s = case runParser p s of + Left err -> Left (errorBundlePrettyStruct err) + Right v -> Right v + +runParser :: (Ord e, VisualStream strm, TraversableStream strm) => HeadedParsec e strm a -> strm -> Either (Megaparsec.ParseErrorBundle strm e) a +runParser p = Megaparsec.runParser (toParsec p <* Megaparsec.eof) "" + +-- | +-- Require the given parser to consume all remaining input (after optional +-- surrounding whitespace), asserting the parse reaches end-of-input. +totally :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm a -> HeadedParsec err strm a +totally p = space *> p <* HeadedMegaparsec.endHead <* space <* eof + +-- * Primitives + +-- | +-- Lifted megaparsec\'s `Megaparsec.eof`. +eof :: (Ord err, Stream strm) => HeadedParsec err strm () +eof = parse Megaparsec.eof + +-- | +-- Lifted megaparsec\'s `Megaparsec.space`. +space :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm () +space = parse MegaparsecChar.space + +-- | +-- Lifted megaparsec\'s `Megaparsec.space1`. +space1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm () +space1 = parse MegaparsecChar.space1 + +-- | +-- Lifted megaparsec\'s `Megaparsec.char`. +char :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char +char a = parse (MegaparsecChar.char a) + +-- | +-- Lifted megaparsec\'s `Megaparsec.char'`. +char' :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char +char' a = parse (MegaparsecChar.char' a) + +-- | +-- Lifted megaparsec\'s `Megaparsec.string`. +string :: (Ord err, Stream strm) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm) +string = parse . MegaparsecChar.string + +-- | +-- Lifted megaparsec\'s `Megaparsec.string'`. +string' :: (Ord err, Stream strm, FoldCase (Megaparsec.Tokens strm)) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm) +string' = parse . MegaparsecChar.string' + +-- | +-- Lifted megaparsec\'s `Megaparsec.takeWhileP`. +takeWhileP :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm) +takeWhileP label predicate = parse (Megaparsec.takeWhileP label predicate) + +-- | +-- Lifted megaparsec\'s `Megaparsec.takeWhile1P`. +takeWhile1P :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm) +takeWhile1P label predicate = parse (Megaparsec.takeWhile1P label predicate) + +satisfy :: (Ord err, Stream strm) => (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Token strm) +satisfy = parse . Megaparsec.satisfy + +decimal :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, Integral decimal) => HeadedParsec err strm decimal +decimal = parse MegaparsecLexer.decimal + +float :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, RealFloat float) => HeadedParsec err strm float +float = parse MegaparsecLexer.float + +-- * Combinators + +sep1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separtor -> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a) +sep1 separator parser = do + head <- parser + endHead + tail <- many $ separator *> parser + return (head :| tail) + +sepEnd1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separator -> HeadedParsec err strm end -> HeadedParsec err strm el -> HeadedParsec err strm (NonEmpty el, end) +sepEnd1 sepP endP elP = do + headEl <- elP + let loop !list = do + _ <- sepP + asum + [ do + end <- endP + return (headEl :| reverse list, end), + do + el <- elP + loop (el : list) + ] + in loop [] + +notFollowedBy :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm () +notFollowedBy a = parse (Megaparsec.notFollowedBy (toParsec a)) diff --git a/library-internal/PostgresqlSyntax/Extras/NonEmpty.hs b/library-internal/PostgresqlSyntax/Extras/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Extras/NonEmpty.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} + +module PostgresqlSyntax.Extras.NonEmpty where + +import Data.List.NonEmpty +import PostgresqlSyntax.Prelude hiding (cons, fromList, head, init, last, reverse, tail, uncons) + +-- | +-- >>> intersperseFoldMap ", " id (fromList ["a"]) +-- "a" +-- +-- >>> intersperseFoldMap ", " id (fromList ["a", "b", "c"]) +-- "a, b, c" +intersperseFoldMap :: (Monoid m) => m -> (a -> m) -> NonEmpty a -> m +intersperseFoldMap a b (c :| d) = b c <> foldMap (mappend a . b) d + +unsnoc :: NonEmpty a -> (Maybe (NonEmpty a), a) +unsnoc = + let build1 = \case + a :| b -> build2 a b + build2 a = \case + b : c -> build3 b (a :| []) c + _ -> (Nothing, a) + build3 a b = \case + c : d -> build3 c (cons a b) d + _ -> (Just (reverse b), a) + in build1 + +consAndUnsnoc :: a -> NonEmpty a -> (NonEmpty a, a) +consAndUnsnoc a b = case unsnoc b of + (c, d) -> case c of + Just e -> (cons a e, d) + Nothing -> (pure a, d) diff --git a/library-internal/PostgresqlSyntax/Extras/TextBuilder.hs b/library-internal/PostgresqlSyntax/Extras/TextBuilder.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Extras/TextBuilder.hs @@ -0,0 +1,16 @@ +module PostgresqlSyntax.Extras.TextBuilder where + +import PostgresqlSyntax.Prelude +import TextBuilder + +char7 :: Char -> TextBuilder +char7 = char + +intDec :: Int -> TextBuilder +intDec = decimal + +int64Dec :: Int64 -> TextBuilder +int64Dec = decimal + +doubleDec :: Double -> TextBuilder +doubleDec = fromString . show diff --git a/library-internal/PostgresqlSyntax/Helpers/Gens.hs b/library-internal/PostgresqlSyntax/Helpers/Gens.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Helpers/Gens.hs @@ -0,0 +1,51 @@ +module PostgresqlSyntax.Helpers.Gens where + +import PostgresqlSyntax.Prelude +import Test.QuickCheck + +downscale :: Gen a -> Gen a +downscale = scale (`div` 2) + +recursive :: Gen a -> Gen a -> Gen a +recursive nonRecursiveGen recursiveGen = sized $ \size -> + if size <= 1 + then nonRecursiveGen + else downscale recursiveGen + +oneofRec :: + (Arbitrary a) => + [Gen a] -> + [Gen a] -> + Gen a +oneofRec nonRecursiveGens recursiveGens = sized $ \size -> + if size <= 1 + then oneof nonRecursiveGens + else + frequency + [ (1, oneof nonRecursiveGens), + (3, downscale (oneof recursiveGens)) + ] + +-- | Generate a non-empty list of at most @n + 1@ elements, splitting the size +-- budget across them. +-- +-- The split is what keeps growth bounded: generating every element at the +-- undiminished size would multiply the subtree's cost by the list length at no +-- size cost, and those multipliers compound through the AST. +nonEmptyUpTo :: Int -> Gen a -> Gen (NonEmpty a) +nonEmptyUpTo n gen = sized $ \size -> do + -- The 'max 0' matters: at size 0 the upper bound is negative, and 'choose' + -- silently swaps inverted bounds instead of failing. + tailLen <- choose (0, max 0 (min n (size - 1))) + let totalLen = tailLen + 1 + subsize = size `div` totalLen + subgen = resize subsize gen + x <- subgen + xs <- vectorOf tailLen subgen + pure (x :| xs) + +terminatingMaybe :: Gen a -> Gen (Maybe a) +terminatingMaybe gen = sized $ \size -> + if size <= 1 + then pure Nothing + else Just <$> gen diff --git a/library-internal/PostgresqlSyntax/Helpers/Parsers.hs b/library-internal/PostgresqlSyntax/Helpers/Parsers.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Helpers/Parsers.hs @@ -0,0 +1,229 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-missing-signatures -Wno-dodgy-imports #-} + +module PostgresqlSyntax.Helpers.Parsers + ( module PostgresqlSyntax.Extras.HeadedMegaparsec, + module PostgresqlSyntax.Helpers.Parsers, + ) +where + +import Control.Applicative.Combinators hiding (some) +import qualified Data.HashSet as HashSet +import qualified Data.Text as Text +import HeadedMegaparsec hiding (string) +import PostgresqlSyntax.Algebra hiding (parse, parseWithPosError, toText) +import PostgresqlSyntax.Extras.HeadedMegaparsec hiding (run) +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude hiding (bit, expr, filter, fromList, head, many, option, some, sortBy, tail, try) +import PostgresqlSyntax.Settings (Settings) +import qualified Text.Megaparsec as Megaparsec +import qualified Text.Megaparsec.Char as MegaparsecChar +import qualified TextBuilder + +-- $setup +-- >>> import qualified PostgresqlSyntax.Extras.HeadedMegaparsec as HeadedMegaparsec +-- >>> testParser p = either putStr print . HeadedMegaparsec.run p + +inSpace :: Parser a -> Parser a +inSpace p = space *> p <* space + +commaSeparator :: Parser () +commaSeparator = space *> char ',' *> endHead *> space + +dotSeparator :: Parser () +dotSeparator = space *> char '.' *> endHead *> space + +inBrackets :: Parser a -> Parser a +inBrackets p = char '[' *> space *> p <* endHead <* space <* char ']' + +inBracketsCont :: Parser a -> Parser (Parser a) +inBracketsCont p = char '[' *> endHead *> pure (space *> p <* endHead <* space <* char ']') + +inParens :: Parser a -> Parser a +inParens p = char '(' *> space *> p <* endHead <* space <* char ')' + +inParensCont :: Parser a -> Parser (Parser a) +inParensCont p = char '(' *> endHead *> pure (space *> p <* endHead <* space <* char ')') + +inParensWithLabel :: (label -> content -> result) -> Parser label -> Parser content -> Parser result +inParensWithLabel result labelParser contentParser = do + label <- wrapToHead labelParser + space + char '(' + endHead + space + content <- contentParser + space + char ')' + pure (result label content) + +inParensWithClause :: Parser clause -> Parser content -> Parser content +inParensWithClause = inParensWithLabel (const id) + +trueIfPresent :: Parser a -> Parser Bool +trueIfPresent p = option False (True <$ p) + +-- | +-- >>> testParser (quotedString '\'') "'abc''d'" +-- "abc'd" +quotedString :: Char -> Parser Text +quotedString q = do + char q + endHead + tail <- + parse $ + let collectChunks !bdr = do + chunk <- Megaparsec.takeWhileP Nothing (/= q) + let bdr' = bdr <> TextBuilder.text chunk + Megaparsec.try (consumeEscapedQuote bdr') <|> finish bdr' + consumeEscapedQuote bdr = do + MegaparsecChar.char q + MegaparsecChar.char q + collectChunks (bdr <> TextBuilder.char q) + finish bdr = do + MegaparsecChar.char q + return (TextBuilder.toText bdr) + in collectChunks mempty + return tail + +-- | +-- >>> testParser dollarQuotedSconst "$$it's good$$" +-- "it's good" +dollarQuotedSconst :: Parser Text +dollarQuotedSconst = do + char '$' + quoteTag <- takeWhileP Nothing (/= '$') + let terminator = Megaparsec.chunk $ "$" <> quoteTag <> "$" + char '$' + endHead + tail <- + parse $ do + body <- many $ Megaparsec.notFollowedBy terminator *> Megaparsec.anySingle + terminator + return $ Text.pack body + return tail + +-- * Keyword-matching infrastructure + +-- +-- Ported from "PostgresqlSyntax.Parsing". @keywordNameFromSet@\/@keywordNameByPredicate@ +-- originally built an @Ident@ directly via its @UnquotedIdent@ constructor; +-- here that constructor is taken as an explicit argument (@wrap@) so this +-- module doesn't need to depend on the (still-monolithic-for-now) +-- 'PostgresqlSyntax.Ast.Ident' type. Callers pass @UnquotedIdent@ for it. + +keywordNameFromSet wrap set = keywordNameByPredicate wrap (Predicate.inSet set) + +keywordNameByPredicate wrap predicate = + fmap wrap $ + filter + (\a -> "Reserved keyword " <> show a <> " used as an identifier. If that's what you intend, you have to wrap it in double quotes.") + predicate + anyKeyword + +anyKeyword = parse $ + Megaparsec.label "keyword" $ + do + firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar + remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar + let parsedKeyword = Text.toLower (Text.cons firstChar remainder) + when (parsedKeyword == "nulls") (Megaparsec.notFollowedBy nullsLa) + return parsedKeyword + where + nullsLa = + MegaparsecChar.space1 + *> (MegaparsecChar.string' "first" <|> MegaparsecChar.string' "last") + *> Megaparsec.notFollowedBy (Megaparsec.satisfy Predicate.notFirstIdentifierChar) + +-- | Expected keyword +-- +-- 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. +keyphrase a = + Text.words a + & fmap (void . MegaparsecChar.string') + & intersperse MegaparsecChar.space1 + & sequence_ + & (<* Megaparsec.notFollowedBy (Megaparsec.satisfy Predicate.notFirstIdentifierChar)) + & fmap (const (Text.toUpper a)) + & Megaparsec.label (show a) + & parse + & (<* endHead) + +-- * Cross-type-family helpers + +-- +-- Ported from "PostgresqlSyntax.Parsing". Each of these originally called a +-- single concrete node's parser directly (@typename@, @qualOp@, +-- @symbolicExprBinOp@, @fconst@\/@iconst@); here they're generalized over +-- 'IsAst' so any node module can instantiate them for its own node type(s) +-- without this module depending on any of them. + +typecastExpr :: (IsAst typename) => Settings -> a -> (a -> typename -> a) -> Parser a +typecastExpr settings prefix constr = do + space + string "::" + endHead + space + type' <- parser settings + return (constr prefix type') + +plusedExpr expr = char '+' *> space *> expr + +minusedExpr expr = char '-' *> space *> expr + +qualOpExpr :: (IsAst qualOp) => Settings -> Parser b -> (qualOp -> b -> a) -> Parser a +qualOpExpr settings expr constr = constr <$> wrapToHead (parser settings) <*> (space *> expr) + +symbolicBinOpExpr :: (IsAst symbolicExprBinOp) => Settings -> a -> Parser b -> (a -> symbolicExprBinOp -> b -> c) -> Parser c +symbolicBinOpExpr settings a bParser constr = do + binOp <- label "binary operator" (space *> wrapToHead (parser settings) <* space) + b <- bParser + return (constr a binOp b) + +iconstOrFconst :: (IsAst iconst, IsAst fconst) => Settings -> Parser (Either iconst fconst) +iconstOrFconst settings = Right <$> parser settings <|> Left <$> parser settings + +-- | +-- Shared by 'PostgresqlSyntax.Ast.FuncApplicationParams' and +-- 'PostgresqlSyntax.Ast.SimpleSelect' (@ALL@\/@DISTINCT@ before a func-arg +-- list, and before a @UNION@\/@INTERSECT@\/@EXCEPT@ right-hand side, +-- respectively). +allOrDistinct :: Parser Bool +allOrDistinct = keyword "all" $> False <|> keyword "distinct" $> True + +-- | +-- A ColId-like identifier parser (unreserved keyword ∪ col-name keyword) +-- restricted to exclude the given reserved words — needed wherever a +-- trailing bare word must terminate a construct instead of being consumed +-- as an identifier. Its only caller is +-- 'PostgresqlSyntax.Ast.RelationExprOptAlias', which excludes @SET@ only in +-- its bare (non-@AS@) alias branch, per @gram.y@'s +-- @relation_expr_opt_alias@ shift/reduce resolution. @identParser@ is the +-- identifier type's own plain (unfiltered) parser, tried first, same as +-- plain @ColId@ does. +filteredColIdLike :: (Text -> a) -> Parser a -> [Text] -> Parser a +filteredColIdLike wrap identParser excluded = + label "identifier" $ + identParser + <|> keywordNameFromSet wrap (foldr HashSet.delete (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) excluded) diff --git a/library-internal/PostgresqlSyntax/Helpers/Shrinks.hs b/library-internal/PostgresqlSyntax/Helpers/Shrinks.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Helpers/Shrinks.hs @@ -0,0 +1,30 @@ +-- | +-- Shrink helpers shared by 2+ AST node modules. +module PostgresqlSyntax.Helpers.Shrinks where + +import qualified Data.List as List +import qualified Data.Text as Text +import PostgresqlSyntax.Prelude +import qualified Test.QuickCheck as Qc + +-- | +-- Shrinks a 'Text' value by shrinking it as a 'String' (dropping\/simplifying +-- characters). +text :: Text -> [Text] +text = fmap Text.pack . Qc.shrink . Text.unpack + +-- | +-- Shrinks a 'Text' value, excluding empty results. +nonEmptyText :: Text -> [Text] +nonEmptyText = List.filter (not . Text.null) . text + +-- | +-- Shrinks the tail of a 'Text' value, keeping its first character fixed. +-- Useful for text with constraints on the first character (e.g. identifiers), +-- where shrinking it away could produce an invalid result. +textTail :: Text -> [Text] +textTail a = + case Text.uncons a of + Nothing -> [] + Just (head, tail) -> + Text.cons head <$> nonEmptyText tail diff --git a/library-internal/PostgresqlSyntax/Helpers/TextBuilders.hs b/library-internal/PostgresqlSyntax/Helpers/TextBuilders.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Helpers/TextBuilders.hs @@ -0,0 +1,35 @@ +-- | +-- Rendering helpers shared by 2+ AST node modules. +module PostgresqlSyntax.Helpers.TextBuilders where + +import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty +import PostgresqlSyntax.Prelude + +commaNonEmpty :: (a -> TextBuilder) -> NonEmpty a -> TextBuilder +commaNonEmpty = NonEmpty.intersperseFoldMap ", " + +spaceNonEmpty :: (a -> TextBuilder) -> NonEmpty a -> TextBuilder +spaceNonEmpty = NonEmpty.intersperseFoldMap " " + +lexemes :: [TextBuilder] -> TextBuilder +lexemes = mconcat . intersperse " " + +optLexemes :: [Maybe TextBuilder] -> TextBuilder +optLexemes = lexemes . catMaybes + +renderInParens :: TextBuilder -> TextBuilder +renderInParens a = "(" <> a <> ")" + +renderInBrackets :: TextBuilder -> TextBuilder +renderInBrackets a = "[" <> a <> "]" + +prefixMaybe :: (a -> TextBuilder) -> Maybe a -> TextBuilder +prefixMaybe a = foldMap (flip mappend " " . a) + +suffixMaybe :: (a -> TextBuilder) -> Maybe a -> TextBuilder +suffixMaybe a = foldMap (mappend " " . a) + +renderAllOrDistinct :: Bool -> TextBuilder +renderAllOrDistinct = \case + False -> "ALL" + True -> "DISTINCT" diff --git a/library-internal/PostgresqlSyntax/KeywordSet.hs b/library-internal/PostgresqlSyntax/KeywordSet.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/KeywordSet.hs @@ -0,0 +1,66 @@ +module PostgresqlSyntax.KeywordSet where + +import Data.HashSet +import PostgresqlSyntax.Prelude hiding (fromList, toList) + +{-# NOINLINE keyword #-} +{- +From https://github.com/postgres/postgres/blob/1aac32df89eb19949050f6f27c268122833ad036/src/include/parser/kwlist.h +-} +keyword :: HashSet Text +keyword = fromList ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "all", "also", "alter", "always", "analyse", "analyze", "and", "any", "array", "as", "asc", "assertion", "assignment", "asymmetric", "at", "attach", "attribute", "authorization", "backward", "before", "begin", "between", "bigint", "binary", "bit", "boolean", "both", "by", "cache", "call", "called", "cascade", "cascaded", "case", "cast", "catalog", "chain", "char", "character", "characteristics", "check", "checkpoint", "class", "close", "cluster", "coalesce", "collate", "collation", "column", "columns", "comment", "comments", "commit", "committed", "concurrently", "configuration", "conflict", "connection", "constraint", "constraints", "content", "continue", "conversion", "copy", "cost", "create", "cross", "csv", "cube", "current", "current_catalog", "current_date", "current_role", "current_schema", "current_time", "current_timestamp", "current_user", "cursor", "cycle", "data", "database", "day", "deallocate", "dec", "decimal", "declare", "default", "defaults", "deferrable", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "desc", "detach", "dictionary", "disable", "discard", "distinct", "do", "document", "domain", "double", "drop", "each", "else", "enable", "encoding", "encrypted", "end", "enum", "escape", "event", "except", "exclude", "excluding", "exclusive", "execute", "exists", "explain", "expression", "extension", "external", "extract", "false", "family", "fetch", "filter", "first", "float", "following", "for", "force", "foreign", "forward", "freeze", "from", "full", "function", "functions", "generated", "global", "grant", "granted", "greatest", "group", "grouping", "groups", "handler", "having", "header", "hold", "hour", "identity", "if", "ilike", "immediate", "immutable", "implicit", "import", "in", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "initially", "inline", "inner", "inout", "input", "insensitive", "insert", "instead", "int", "integer", "intersect", "interval", "into", "invoker", "is", "isnull", "isolation", "join", "key", "label", "language", "large", "last", "lateral", "leading", "leakproof", "least", "left", "level", "like", "limit", "listen", "load", "local", "localtime", "localtimestamp", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "national", "natural", "nchar", "new", "next", "nfc", "nfd", "nfkc", "nfkd", "no", "none", "normalize", "normalized", "not", "nothing", "notify", "notnull", "nowait", "null", "nullif", "nulls", "numeric", "object", "of", "off", "offset", "oids", "old", "on", "only", "operator", "option", "options", "or", "order", "ordinality", "others", "out", "outer", "over", "overlaps", "overlay", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "placing", "plans", "policy", "position", "preceding", "precision", "prepare", "prepared", "preserve", "primary", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "real", "reassign", "recheck", "recursive", "ref", "references", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returning", "returns", "revoke", "right", "role", "rollback", "rollup", "routine", "routines", "row", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "select", "sequence", "sequences", "serializable", "server", "session", "session_user", "set", "setof", "sets", "share", "show", "similar", "simple", "skip", "smallint", "snapshot", "some", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "substring", "support", "symmetric", "sysid", "system", "table", "tables", "tablesample", "tablespace", "temp", "template", "temporary", "text", "then", "ties", "time", "timestamp", "to", "trailing", "transaction", "transform", "treat", "trigger", "trim", "true", "truncate", "trusted", "type", "types", "uescape", "unbounded", "uncommitted", "unencrypted", "union", "unique", "unknown", "unlisten", "unlogged", "until", "update", "user", "using", "vacuum", "valid", "validate", "validator", "value", "values", "varchar", "variadic", "varying", "verbose", "version", "view", "views", "volatile", "when", "where", "whitespace", "window", "with", "within", "without", "work", "wrapper", "write", "xml", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable", "year", "yes", "zone"] + +{-# NOINLINE unreservedKeyword #-} +unreservedKeyword :: HashSet Text +unreservedKeyword = fromList ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "also", "alter", "always", "assertion", "assignment", "at", "attach", "attribute", "backward", "before", "begin", "by", "cache", "call", "called", "cascade", "cascaded", "catalog", "chain", "characteristics", "checkpoint", "class", "close", "cluster", "columns", "comment", "comments", "commit", "committed", "configuration", "conflict", "connection", "constraints", "content", "continue", "conversion", "copy", "cost", "csv", "cube", "current", "cursor", "cycle", "data", "database", "day", "deallocate", "declare", "defaults", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "detach", "dictionary", "disable", "discard", "document", "domain", "double", "drop", "each", "enable", "encoding", "encrypted", "enum", "escape", "event", "exclude", "excluding", "exclusive", "execute", "explain", "extension", "external", "family", "filter", "first", "following", "force", "forward", "function", "functions", "generated", "global", "granted", "groups", "handler", "header", "hold", "hour", "identity", "if", "immediate", "immutable", "implicit", "import", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "inline", "input", "insensitive", "insert", "instead", "invoker", "isolation", "key", "label", "language", "large", "last", "leakproof", "level", "listen", "load", "local", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "new", "next", "no", "nothing", "notify", "nowait", "nulls", "object", "of", "off", "oids", "old", "operator", "option", "options", "ordinality", "others", "over", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "plans", "policy", "preceding", "prepare", "prepared", "preserve", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "reassign", "recheck", "recursive", "ref", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returns", "revoke", "role", "rollback", "rollup", "routine", "routines", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "sequence", "sequences", "serializable", "server", "session", "set", "sets", "share", "show", "simple", "skip", "snapshot", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "support", "sysid", "system", "tables", "tablespace", "temp", "template", "temporary", "text", "ties", "transaction", "transform", "trigger", "truncate", "trusted", "type", "types", "unbounded", "uncommitted", "unencrypted", "unknown", "unlisten", "unlogged", "until", "update", "vacuum", "valid", "validate", "validator", "value", "varying", "version", "view", "views", "volatile", "whitespace", "within", "without", "work", "wrapper", "write", "xml", "year", "yes", "zone"] + +{-# NOINLINE colNameKeyword #-} +colNameKeyword :: HashSet Text +colNameKeyword = fromList ["between", "bigint", "bit", "boolean", "char", "character", "coalesce", "dec", "decimal", "exists", "extract", "float", "greatest", "grouping", "inout", "int", "integer", "interval", "least", "national", "nchar", "none", "normalize", "nullif", "numeric", "out", "overlay", "position", "precision", "real", "row", "setof", "smallint", "substring", "time", "timestamp", "treat", "trim", "values", "varchar", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable"] + +{-# NOINLINE typeFuncNameKeyword #-} +typeFuncNameKeyword :: HashSet Text +typeFuncNameKeyword = fromList ["authorization", "binary", "collation", "concurrently", "cross", "current_schema", "freeze", "full", "ilike", "inner", "is", "isnull", "join", "left", "like", "natural", "notnull", "outer", "overlaps", "right", "similar", "tablesample", "verbose"] + +{-# NOINLINE reservedKeyword #-} +reservedKeyword :: HashSet Text +reservedKeyword = fromList ["all", "analyse", "analyze", "and", "any", "array", "as", "asc", "asymmetric", "both", "case", "cast", "check", "collate", "column", "constraint", "create", "current_catalog", "current_date", "current_role", "current_time", "current_timestamp", "current_user", "default", "deferrable", "desc", "distinct", "do", "else", "end", "except", "false", "fetch", "for", "foreign", "from", "grant", "group", "having", "in", "initially", "intersect", "into", "lateral", "leading", "limit", "localtime", "localtimestamp", "not", "null", "offset", "on", "only", "or", "order", "placing", "primary", "references", "returning", "select", "session_user", "some", "symmetric", "table", "then", "to", "trailing", "true", "union", "unique", "user", "using", "variadic", "when", "where", "window", "with"] + +{-# NOINLINE symbolicBinOp #-} +symbolicBinOp :: HashSet Text +symbolicBinOp = fromList ["+", "-", "*", "/", "%", "^", "<", ">", "=", "<=", ">=", "<>", "~~", "~~*", "!~~", "!~~*", "~", "~*", "!~", "!~*"] + +{-# NOINLINE lexicalBinOp #-} +lexicalBinOp :: HashSet Text +lexicalBinOp = fromList ["and", "or"] + +{-# NOINLINE colId #-} +colId :: HashSet Text +colId = unions [unreservedKeyword, colNameKeyword] + +{- +type_function_name: + | IDENT + | unreserved_keyword + | type_func_name_keyword +-} +{-# NOINLINE typeFunctionName #-} +typeFunctionName :: HashSet Text +typeFunctionName = unions [unreservedKeyword, typeFuncNameKeyword] + +-- | +-- As per the following comment from the original scanner definition: +-- +-- /* +-- * Likewise, if what we have left is two chars, and +-- * those match the tokens ">=", "<=", "=>", "<>" or +-- * "!=", then we must return the appropriate token +-- * rather than the generic Op. +-- */ +{-# NOINLINE nonOp #-} +nonOp :: HashSet Text +nonOp = fromList [">=", "<=", "=>", "<>", "!="] <> mathOp + +{-# NOINLINE mathOp #-} +mathOp :: HashSet Text +mathOp = fromList ["<>", ">=", "!=", "<=", "+", "-", "*", "/", "%", "^", "<", ">", "="] diff --git a/library-internal/PostgresqlSyntax/Predicate.hs b/library-internal/PostgresqlSyntax/Predicate.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Predicate.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module PostgresqlSyntax.Predicate where + +import qualified Data.HashSet as HashSet +import qualified PostgresqlSyntax.CharSet as CharSet +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import PostgresqlSyntax.Prelude + +-- * Generic + +-- | +-- >>> test = oneOf [(==3), (==7), (==3), (==5)] +-- >>> test 1 +-- False +-- +-- >>> test 3 +-- True +-- +-- >>> test 5 +-- True +oneOf :: [a -> Bool] -> a -> Bool +oneOf = foldr (\a b c -> a c || b c) (const False) + +inSet :: (Eq a, Hashable a) => HashSet a -> a -> Bool +inSet = flip HashSet.member + +hexDigit :: Char -> Bool +hexDigit = inSet CharSet.hexDigit + +{- +ident_start [A-Za-z\200-\377_] +-} +firstIdentifierChar :: Char -> Bool +firstIdentifierChar x = isAlpha x || x == '_' || x >= '\200' && x <= '\377' + +{- +ident_cont [A-Za-z\200-\377_0-9\$] +-} +notFirstIdentifierChar :: Char -> Bool +notFirstIdentifierChar x = isAlphaNum x || x == '_' || x == '$' || x >= '\200' && x <= '\377' + +keyword :: Text -> Bool +keyword = inSet KeywordSet.keyword + +unreservedKeyword :: Text -> Bool +unreservedKeyword = inSet KeywordSet.unreservedKeyword + +colNameKeyword :: Text -> Bool +colNameKeyword = inSet KeywordSet.colNameKeyword + +typeFuncNameKeyword :: Text -> Bool +typeFuncNameKeyword = inSet KeywordSet.typeFuncNameKeyword + +reservedKeyword :: Text -> Bool +reservedKeyword = inSet KeywordSet.reservedKeyword + +{-# NOINLINE symbolicBinOpChar #-} +symbolicBinOpChar :: Char -> Bool +symbolicBinOpChar = inSet CharSet.symbolicBinOp + +-- ** Op chars + +opChar :: Char -> Bool +opChar = inSet CharSet.op + +prohibitedOpChar :: Char -> Bool +prohibitedOpChar a = a == '+' || a == '-' + +prohibitionLiftingOpChar :: Char -> Bool +prohibitionLiftingOpChar = inSet CharSet.prohibitionLiftingOp diff --git a/library-internal/PostgresqlSyntax/Prelude.hs b/library-internal/PostgresqlSyntax/Prelude.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Prelude.hs @@ -0,0 +1,99 @@ +module PostgresqlSyntax.Prelude + ( module Exports, + suffixRec, + extendMany, + Parser, + ) +where + +import Control.Applicative as Exports +import Control.Applicative.Combinators as Exports (option) +import Control.Arrow as Exports hiding (first, second) +import Control.Category as Exports +import Control.Concurrent as Exports +import Control.Exception as Exports +import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) +import Control.Monad.Fail as Exports +import Control.Monad.Fix as Exports hiding (fix) +import Control.Monad.IO.Class as Exports +import Control.Monad.ST as Exports +import Data.Bifunctor as Exports +import Data.Bits as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.CaseInsensitive as Exports (CI, FoldCase) +import Data.Char as Exports +import Data.Coerce as Exports +import Data.Complex as Exports +import Data.Data as Exports +import Data.Dynamic as Exports +import Data.Either as Exports +import Data.Fixed as Exports +import Data.Foldable as Exports +import Data.Function as Exports hiding (id, (.)) +import Data.Functor as Exports hiding (unzip) +import Data.Functor.Identity as Exports +import Data.HashMap.Strict as Exports (HashMap) +import Data.HashSet as Exports (HashSet) +import Data.Hashable as Exports (Hashable) +import Data.IORef as Exports +import Data.Int as Exports +import Data.Ix as Exports +import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons, unsnoc) +import Data.List.NonEmpty as Exports (NonEmpty (..)) +import Data.Maybe as Exports +import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) +import Data.Ord as Exports +import Data.Proxy as Exports +import Data.Ratio as Exports +import Data.STRef as Exports +import Data.Semigroup as Exports (Semigroup (..), stimes, stimesIdempotent, stimesIdempotentMonoid, stimesMonoid) +import Data.String as Exports +import Data.Text as Exports (Text) +import Data.Traversable as Exports +import Data.Tuple as Exports +import Data.Unique as Exports +import Data.Version as Exports +import Data.Void as Exports +import Data.Word as Exports +import Debug.Trace as Exports +import Foreign.ForeignPtr as Exports +import Foreign.Ptr as Exports +import Foreign.StablePtr as Exports +import Foreign.Storable as Exports hiding (alignment, sizeOf) +import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) +import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) +import GHC.Generics as Exports (Generic, Generic1) +import GHC.IO.Exception as Exports +import qualified HeadedMegaparsec +import Numeric as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) +import System.Environment as Exports +import System.Exit as Exports +import System.IO as Exports +import System.IO.Error as Exports +import System.IO.Unsafe as Exports +import System.Mem as Exports +import System.Mem.StableName as Exports +import System.Timeout as Exports +import Test.QuickCheck as Exports (Arbitrary (..), Gen, choose, elements, listOf, oneof, sized, vectorOf) +import Text.Printf as Exports (hPrintf, printf) +import Text.Read as Exports (Read (..), readEither, readMaybe) +import TextBuilder as Exports (TextBuilder) +import Unsafe.Coerce as Exports + +-- | +-- Compose a monad, which attempts to extend a value, based on the following input. +-- It does so recursively until the suffix alternative fails. +suffixRec :: (MonadPlus m) => m a -> (a -> m a) -> m a +suffixRec base suffix = base >>= extendMany suffix + +extendMany :: (MonadPlus m) => (a -> m a) -> a -> m a +extendMany attempt = loop + where + loop !state = + optional (attempt state) >>= \case + Nothing -> pure state + Just newState -> loop newState + +type Parser = HeadedMegaparsec.HeadedParsec Void Text diff --git a/library-internal/PostgresqlSyntax/Settings.hs b/library-internal/PostgresqlSyntax/Settings.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Settings.hs @@ -0,0 +1,42 @@ +-- | +-- Parse\/render options for the 'PostgresqlSyntax.Algebra' machinery. +-- +-- The type is abstract: build a 'Settings' value with 'nullabilityMarkers' and +-- combine values with their 'Semigroup'\/'Monoid' instances ('mempty' is +-- faithful, standard Postgres). Because no constructor or field selector is +-- exported, a resolved configuration indirection can be introduced later +-- without a breaking change. +module PostgresqlSyntax.Settings + ( Settings, + nullabilityMarkers, + resolveNullabilityMarkers, + ) +where + +import PostgresqlSyntax.Prelude + +-- | +-- Collection of parse\/render options. Use 'nullabilityMarkers' to build a value, and combine values with their 'Semigroup'\/'Monoid' instances ('mempty' is faithful, standard Postgres). +data Settings = Settings {optNullabilityMarkers :: Maybe Bool} + deriving (Show, Eq) + +-- | Per option the right operand wins; an unset ('Nothing') option falls back +-- to the left operand's value. +instance Semigroup Settings where + a <> b = Settings {optNullabilityMarkers = optNullabilityMarkers b <|> optNullabilityMarkers a} + +instance Monoid Settings where + mempty = Settings Nothing + +-- | +-- The only public constructor: opt into (or out of) the +-- 'PostgresqlSyntax.Ast.Typename' @?@ nullability markers. +nullabilityMarkers :: Bool -> Settings +nullabilityMarkers = Settings . Just + +-- | +-- Resolve the nullability-marker option to its effective value, defaulting to +-- @False@ (standard Postgres). Internal — used at parse\/render sites, not +-- re-exported from the "PostgresqlSyntax" facade. +resolveNullabilityMarkers :: Settings -> Bool +resolveNullabilityMarkers = fromMaybe False . optNullabilityMarkers diff --git a/library-internal/PostgresqlSyntax/Validation.hs b/library-internal/PostgresqlSyntax/Validation.hs new file mode 100644 --- /dev/null +++ b/library-internal/PostgresqlSyntax/Validation.hs @@ -0,0 +1,54 @@ +module PostgresqlSyntax.Validation where + +import qualified Data.Text as Text +import qualified PostgresqlSyntax.KeywordSet as KeywordSet +import qualified PostgresqlSyntax.Predicate as Predicate +import PostgresqlSyntax.Prelude + +{- +The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) +characters from the following list: + ++ - * / < > = ~ ! @ # % ^ & | ` ? + +There are a few restrictions on your choice of name: +-- and /* cannot appear anywhere in an operator name, +since they will be taken as the start of a comment. + +A multicharacter operator name cannot end in + or -, +unless the name also contains at least one of these characters: + +~ ! @ # % ^ & | ` ? + +For example, @- is an allowed operator name, but *- is not. +This restriction allows PostgreSQL to parse SQL-compliant +commands without requiring spaces between tokens. +The use of => as an operator name is deprecated. +It may be disallowed altogether in a future release. + +The operator != is mapped to <> on input, +so these two names are always equivalent. +-} +op :: Text -> Maybe Text +op a = + if Text.null a + then Just ("Operator is empty") + else + if Text.any (not . Predicate.opChar) a + then Just ("Operator contains a char that's not a valid operator char: " <> a) + else + if Text.isInfixOf "--" a + then Just ("Operator contains a prohibited \"--\" sequence: " <> a) + else + if Text.isInfixOf "/*" a + then Just ("Operator contains a prohibited \"/*\" sequence: " <> a) + else + if Predicate.inSet KeywordSet.nonOp a + then Just ("Operator is not generic: " <> a) + else + if Text.find Predicate.prohibitionLiftingOpChar a & isJust + then Nothing + else + if Predicate.prohibitedOpChar (Text.last a) + then Just ("Operator ends with a prohibited char: " <> a) + else Nothing diff --git a/library/PostgresqlSyntax.hs b/library/PostgresqlSyntax.hs new file mode 100644 --- /dev/null +++ b/library/PostgresqlSyntax.hs @@ -0,0 +1,32 @@ +-- | +-- Parse Postgres SQL fragments into an AST and render that AST back to text. +-- +-- Pick the 'PostgresqlSyntax.Ast' node type that corresponds to the syntax +-- you want to parse (e.g. 'PostgresqlSyntax.Ast.AExpr' for an expression), +-- then use 'parse' (or one of its error-detail variants) to get a value of +-- that type. Use 'toText' to go the other way and render an AST value back +-- into Postgres SQL syntax. +-- +-- 'Settings' (built via 'nullabilityMarkers' and combined with +-- 'Semigroup'\/'Monoid') control optional parsing\/rendering behavior; pass +-- 'mempty' for standard Postgres syntax. +module PostgresqlSyntax + ( -- * Parsing and rendering + Algebra.IsAst (..), + Algebra.toText, + Algebra.parse, + Algebra.parseWithPosError, + Algebra.parseWithSourcePosError, + + -- * Settings + Settings.Settings, + Settings.nullabilityMarkers, + + -- * AST + module PostgresqlSyntax.Ast, + ) +where + +import qualified PostgresqlSyntax.Algebra as Algebra +import PostgresqlSyntax.Ast +import qualified PostgresqlSyntax.Settings as Settings diff --git a/library/PostgresqlSyntax/Ast.hs b/library/PostgresqlSyntax/Ast.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Ast.hs +++ /dev/null @@ -1,2340 +0,0 @@ --- | --- Names for nodes mostly resemble the according definitions in the @gram.y@ --- original Postgres parser file, except for the cases where we can optimize on that. --- --- For reasoning see the docs of the parsing module of this project. -module PostgresqlSyntax.Ast where - -import PostgresqlSyntax.Prelude - --- * Statement - --- | --- ==== References --- @ --- PreparableStmt: --- | SelectStmt --- | InsertStmt --- | UpdateStmt --- | DeleteStmt --- | CallStmt --- @ -data PreparableStmt - = SelectPreparableStmt SelectStmt - | InsertPreparableStmt InsertStmt - | UpdatePreparableStmt UpdateStmt - | DeletePreparableStmt DeleteStmt - | CallPreparableStmt CallStmt - deriving (Show, Generic, Eq, Ord, Data) - --- * Call - -newtype CallStmt - = CallStmt FuncApplication - deriving (Show, Generic, Eq, Ord, Data) - --- * Insert - --- | --- ==== References --- @ --- InsertStmt: --- | opt_with_clause INSERT INTO insert_target insert_rest --- opt_on_conflict returning_clause --- @ -data InsertStmt = InsertStmt (Maybe WithClause) InsertTarget InsertRest (Maybe OnConflict) (Maybe ReturningClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- insert_target: --- | qualified_name --- | qualified_name AS ColId --- @ -data InsertTarget = InsertTarget QualifiedName (Maybe ColId) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- insert_rest: --- | SelectStmt --- | OVERRIDING override_kind VALUE_P SelectStmt --- | '(' insert_column_list ')' SelectStmt --- | '(' insert_column_list ')' OVERRIDING override_kind VALUE_P SelectStmt --- | DEFAULT VALUES --- @ -data InsertRest - = SelectInsertRest (Maybe InsertColumnList) (Maybe OverrideKind) SelectStmt - | DefaultValuesInsertRest - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- override_kind: --- | USER --- | SYSTEM_P --- @ -data OverrideKind = UserOverrideKind | SystemOverrideKind - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - --- | --- ==== References --- @ --- insert_column_list: --- | insert_column_item --- | insert_column_list ',' insert_column_item --- @ -type InsertColumnList = NonEmpty InsertColumnItem - --- | --- ==== References --- @ --- insert_column_item: --- | ColId opt_indirection --- @ -data InsertColumnItem = InsertColumnItem ColId (Maybe Indirection) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_on_conflict: --- | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause --- | ON CONFLICT opt_conf_expr DO NOTHING --- | EMPTY --- @ -data OnConflict = OnConflict (Maybe ConfExpr) OnConflictDo - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_on_conflict: --- | ON CONFLICT opt_conf_expr DO UPDATE SET set_clause_list where_clause --- | ON CONFLICT opt_conf_expr DO NOTHING --- | EMPTY --- @ -data OnConflictDo - = UpdateOnConflictDo SetClauseList (Maybe WhereClause) - | NothingOnConflictDo - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_conf_expr: --- | '(' index_params ')' where_clause --- | ON CONSTRAINT name --- | EMPTY --- @ -data ConfExpr - = WhereConfExpr IndexParams (Maybe WhereClause) - | ConstraintConfExpr Name - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- returning_clause: --- | RETURNING target_list --- | EMPTY --- @ -type ReturningClause = TargetList - --- * Update - --- | --- ==== References --- @ --- UpdateStmt: --- | opt_with_clause UPDATE relation_expr_opt_alias --- SET set_clause_list --- from_clause --- where_or_current_clause --- returning_clause --- @ -data UpdateStmt = UpdateStmt (Maybe WithClause) RelationExprOptAlias SetClauseList (Maybe FromClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- set_clause_list: --- | set_clause --- | set_clause_list ',' set_clause --- @ -type SetClauseList = NonEmpty SetClause - --- | --- ==== References --- @ --- set_clause: --- | set_target '=' a_expr --- | '(' set_target_list ')' '=' a_expr --- @ -data SetClause - = TargetSetClause SetTarget AExpr - | TargetListSetClause SetTargetList AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- set_target: --- | ColId opt_indirection --- @ -data SetTarget = SetTarget ColId (Maybe Indirection) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- set_target_list: --- | set_target --- | set_target_list ',' set_target --- @ -type SetTargetList = NonEmpty SetTarget - --- * Delete - --- | --- ==== References --- @ --- DeleteStmt: --- | opt_with_clause DELETE_P FROM relation_expr_opt_alias --- using_clause where_or_current_clause returning_clause --- @ -data DeleteStmt = DeleteStmt (Maybe WithClause) RelationExprOptAlias (Maybe UsingClause) (Maybe WhereOrCurrentClause) (Maybe ReturningClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- using_clause: --- | USING from_list --- | EMPTY --- @ -type UsingClause = FromList - --- * Select - --- | --- ==== References --- @ --- SelectStmt: --- | select_no_parens --- | select_with_parens --- @ -type SelectStmt = Either SelectNoParens SelectWithParens - --- | --- ==== References --- @ --- select_with_parens: --- | '(' select_no_parens ')' --- | '(' select_with_parens ')' --- @ -data SelectWithParens - = NoParensSelectWithParens SelectNoParens - | WithParensSelectWithParens SelectWithParens - deriving (Show, Generic, Eq, Ord, Data) - --- | --- Covers the following cases: --- --- @ --- select_no_parens: --- | simple_select --- | select_clause sort_clause --- | select_clause opt_sort_clause for_locking_clause opt_select_limit --- | select_clause opt_sort_clause select_limit opt_for_locking_clause --- | with_clause select_clause --- | with_clause select_clause sort_clause --- | with_clause select_clause opt_sort_clause for_locking_clause opt_select_limit --- | with_clause select_clause opt_sort_clause select_limit opt_for_locking_clause --- @ -data SelectNoParens - = SelectNoParens (Maybe WithClause) SelectClause (Maybe SortClause) (Maybe SelectLimit) (Maybe ForLockingClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- @ --- select_clause: --- | simple_select --- | select_with_parens --- @ -type SelectClause = Either SimpleSelect SelectWithParens - --- | --- ==== References --- @ --- simple_select: --- | SELECT opt_all_clause opt_target_list --- into_clause from_clause where_clause --- group_clause having_clause window_clause --- | SELECT distinct_clause target_list --- into_clause from_clause where_clause --- group_clause having_clause window_clause --- | values_clause --- | TABLE relation_expr --- | select_clause UNION all_or_distinct select_clause --- | select_clause INTERSECT all_or_distinct select_clause --- | select_clause EXCEPT all_or_distinct select_clause --- @ -data SimpleSelect - = NormalSimpleSelect (Maybe Targeting) (Maybe IntoClause) (Maybe FromClause) (Maybe WhereClause) (Maybe GroupClause) (Maybe HavingClause) (Maybe WindowClause) - | ValuesSimpleSelect ValuesClause - | TableSimpleSelect RelationExpr - | BinSimpleSelect SelectBinOp SelectClause (Maybe Bool) SelectClause - deriving (Show, Generic, Eq, Ord, Data) - --- | --- Covers these parts of spec: --- --- ==== References --- @ --- simple_select: --- | SELECT opt_all_clause opt_target_list --- into_clause from_clause where_clause --- group_clause having_clause window_clause --- | SELECT distinct_clause target_list --- into_clause from_clause where_clause --- group_clause having_clause window_clause --- --- distinct_clause: --- | DISTINCT --- | DISTINCT ON '(' expr_list ')' --- @ -data Targeting - = NormalTargeting TargetList - | AllTargeting (Maybe TargetList) - | DistinctTargeting (Maybe ExprList) TargetList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- target_list: --- | target_el --- | target_list ',' target_el --- @ -type TargetList = NonEmpty TargetEl - --- | --- ==== References --- @ --- target_el: --- | a_expr AS ColLabel --- | a_expr IDENT --- | a_expr --- | '*' --- @ -data TargetEl - = AliasedExprTargetEl AExpr Ident - | ImplicitlyAliasedExprTargetEl AExpr Ident - | ExprTargetEl AExpr - | AsteriskTargetEl - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | select_clause UNION all_or_distinct select_clause --- | select_clause INTERSECT all_or_distinct select_clause --- | select_clause EXCEPT all_or_distinct select_clause --- @ -data SelectBinOp = UnionSelectBinOp | IntersectSelectBinOp | ExceptSelectBinOp - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- with_clause: --- | WITH cte_list --- | WITH_LA cte_list --- | WITH RECURSIVE cte_list --- @ -data WithClause = WithClause Bool (NonEmpty CommonTableExpr) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- common_table_expr: --- | name opt_name_list AS opt_materialized '(' PreparableStmt ')' --- opt_materialized: --- | MATERIALIZED --- | NOT MATERIALIZED --- | EMPTY --- @ -data CommonTableExpr = CommonTableExpr Ident (Maybe (NonEmpty Ident)) (Maybe Bool) PreparableStmt - deriving (Show, Generic, Eq, Ord, Data) - -type IntoClause = OptTempTableName - --- | --- ==== References --- @ --- OptTempTableName: --- | TEMPORARY opt_table qualified_name --- | TEMP opt_table qualified_name --- | LOCAL TEMPORARY opt_table qualified_name --- | LOCAL TEMP opt_table qualified_name --- | GLOBAL TEMPORARY opt_table qualified_name --- | GLOBAL TEMP opt_table qualified_name --- | UNLOGGED opt_table qualified_name --- | TABLE qualified_name --- | qualified_name --- @ -data OptTempTableName - = TemporaryOptTempTableName Bool QualifiedName - | TempOptTempTableName Bool QualifiedName - | LocalTemporaryOptTempTableName Bool QualifiedName - | LocalTempOptTempTableName Bool QualifiedName - | GlobalTemporaryOptTempTableName Bool QualifiedName - | GlobalTempOptTempTableName Bool QualifiedName - | UnloggedOptTempTableName Bool QualifiedName - | TableOptTempTableName QualifiedName - | QualifedOptTempTableName QualifiedName - deriving (Show, Generic, Eq, Ord, Data) - -type FromClause = NonEmpty TableRef - -type GroupClause = NonEmpty GroupByItem - --- | --- ==== References --- @ --- group_by_item: --- | a_expr --- | empty_grouping_set --- | cube_clause --- | rollup_clause --- | grouping_sets_clause --- empty_grouping_set: --- | '(' ')' --- rollup_clause: --- | ROLLUP '(' expr_list ')' --- cube_clause: --- | CUBE '(' expr_list ')' --- grouping_sets_clause: --- | GROUPING SETS '(' group_by_list ')' --- @ -data GroupByItem - = ExprGroupByItem AExpr - | EmptyGroupingSetGroupByItem - | RollupGroupByItem ExprList - | CubeGroupByItem ExprList - | GroupingSetsGroupByItem (NonEmpty GroupByItem) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- @ --- having_clause: --- | HAVING a_expr --- | EMPTY --- @ -type HavingClause = AExpr - --- | --- @ --- window_clause: --- | WINDOW window_definition_list --- | EMPTY --- --- window_definition_list: --- | window_definition --- | window_definition_list ',' window_definition --- @ -type WindowClause = NonEmpty WindowDefinition - --- | --- @ --- window_definition: --- | ColId AS window_specification --- @ -data WindowDefinition = WindowDefinition Ident WindowSpecification - deriving (Show, Generic, Eq, Ord, Data) - --- | --- @ --- window_specification: --- | '(' opt_existing_window_name opt_partition_clause --- opt_sort_clause opt_frame_clause ')' --- --- opt_existing_window_name: --- | ColId --- | EMPTY --- --- opt_partition_clause: --- | PARTITION BY expr_list --- | EMPTY --- @ -data WindowSpecification = WindowSpecification (Maybe ExistingWindowName) (Maybe PartitionClause) (Maybe SortClause) (Maybe FrameClause) - deriving (Show, Generic, Eq, Ord, Data) - -type ExistingWindowName = ColId - -type PartitionClause = ExprList - --- | --- ==== References --- @ --- opt_frame_clause: --- | RANGE frame_extent opt_window_exclusion_clause --- | ROWS frame_extent opt_window_exclusion_clause --- | GROUPS frame_extent opt_window_exclusion_clause --- | EMPTY --- @ -data FrameClause = FrameClause FrameClauseMode FrameExtent (Maybe WindowExclusionClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_frame_clause: --- | RANGE frame_extent opt_window_exclusion_clause --- | ROWS frame_extent opt_window_exclusion_clause --- | GROUPS frame_extent opt_window_exclusion_clause --- | EMPTY --- @ -data FrameClauseMode = RangeFrameClauseMode | RowsFrameClauseMode | GroupsFrameClauseMode - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- frame_extent: --- | frame_bound --- | BETWEEN frame_bound AND frame_bound --- @ -data FrameExtent = SingularFrameExtent FrameBound | BetweenFrameExtent FrameBound FrameBound - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- frame_bound: --- | UNBOUNDED PRECEDING --- | UNBOUNDED FOLLOWING --- | CURRENT_P ROW --- | a_expr PRECEDING --- | a_expr FOLLOWING --- @ -data FrameBound - = UnboundedPrecedingFrameBound - | UnboundedFollowingFrameBound - | CurrentRowFrameBound - | PrecedingFrameBound AExpr - | FollowingFrameBound AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_window_exclusion_clause: --- | EXCLUDE CURRENT_P ROW --- | EXCLUDE GROUP_P --- | EXCLUDE TIES --- | EXCLUDE NO OTHERS --- | EMPTY --- @ -data WindowExclusionClause - = CurrentRowWindowExclusionClause - | GroupWindowExclusionClause - | TiesWindowExclusionClause - | NoOthersWindowExclusionClause - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- values_clause: --- | VALUES '(' expr_list ')' --- | values_clause ',' '(' expr_list ')' --- @ -type ValuesClause = NonEmpty ExprList - --- | --- --- sort_clause: --- | ORDER BY sortby_list --- --- sortby_list: --- | sortby --- | sortby_list ',' sortby -type SortClause = NonEmpty SortBy - --- | --- ==== References --- @ --- sortby: --- | a_expr USING qual_all_Op opt_nulls_order --- | a_expr opt_asc_desc opt_nulls_order --- @ -data SortBy - = UsingSortBy AExpr QualAllOp (Maybe NullsOrder) - | AscDescSortBy AExpr (Maybe AscDesc) (Maybe NullsOrder) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- select_limit: --- | limit_clause offset_clause --- | offset_clause limit_clause --- | limit_clause --- | offset_clause --- @ -data SelectLimit - = LimitOffsetSelectLimit LimitClause OffsetClause - | OffsetLimitSelectLimit OffsetClause LimitClause - | LimitSelectLimit LimitClause - | OffsetSelectLimit OffsetClause - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- limit_clause: --- | LIMIT select_limit_value --- | LIMIT select_limit_value ',' select_offset_value --- | FETCH first_or_next select_fetch_first_value row_or_rows ONLY --- | FETCH first_or_next row_or_rows ONLY --- select_offset_value: --- | a_expr --- first_or_next: --- | FIRST_P --- | NEXT --- row_or_rows: --- | ROW --- | ROWS --- @ -data LimitClause - = LimitLimitClause SelectLimitValue (Maybe AExpr) - | FetchOnlyLimitClause Bool (Maybe SelectFetchFirstValue) Bool - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- select_fetch_first_value: --- | c_expr --- | '+' I_or_F_const --- | '-' I_or_F_const --- @ -data SelectFetchFirstValue - = ExprSelectFetchFirstValue CExpr - | NumSelectFetchFirstValue Bool (Either Int64 Double) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- select_limit_value: --- | a_expr --- | ALL --- @ -data SelectLimitValue - = ExprSelectLimitValue AExpr - | AllSelectLimitValue - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- offset_clause: --- | OFFSET select_offset_value --- | OFFSET select_fetch_first_value row_or_rows --- select_offset_value: --- | a_expr --- row_or_rows: --- | ROW --- | ROWS --- @ -data OffsetClause - = ExprOffsetClause AExpr - | FetchFirstOffsetClause SelectFetchFirstValue Bool - deriving (Show, Generic, Eq, Ord, Data) - --- * For Locking - --- | --- ==== References --- @ --- for_locking_clause: --- | for_locking_items --- | FOR READ ONLY --- for_locking_items: --- | for_locking_item --- | for_locking_items for_locking_item --- @ -data ForLockingClause - = ItemsForLockingClause (NonEmpty ForLockingItem) - | ReadOnlyForLockingClause - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- for_locking_item: --- | for_locking_strength locked_rels_list opt_nowait_or_skip --- locked_rels_list: --- | OF qualified_name_list --- | EMPTY --- opt_nowait_or_skip: --- | NOWAIT --- | SKIP LOCKED --- | EMPTY --- @ -data ForLockingItem = ForLockingItem ForLockingStrength (Maybe (NonEmpty QualifiedName)) (Maybe Bool) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- for_locking_strength: --- | FOR UPDATE --- | FOR NO KEY UPDATE --- | FOR SHARE --- | FOR KEY SHARE --- @ -data ForLockingStrength - = UpdateForLockingStrength - | NoKeyUpdateForLockingStrength - | ShareForLockingStrength - | KeyForLockingStrength - deriving (Show, Generic, Eq, Ord, Data) - --- * Table references and joining - --- | --- ==== References --- @ --- from_list: --- | table_ref --- | from_list ',' table_ref --- @ -type FromList = NonEmpty TableRef - --- | --- ==== References --- @ --- | relation_expr opt_alias_clause --- | relation_expr opt_alias_clause tablesample_clause --- | func_table func_alias_clause --- | LATERAL_P func_table func_alias_clause --- | xmltable opt_alias_clause --- | LATERAL_P xmltable opt_alias_clause --- | select_with_parens opt_alias_clause --- | LATERAL_P select_with_parens opt_alias_clause --- | joined_table --- | '(' joined_table ')' alias_clause --- --- TODO: Add xmltable --- @ -data TableRef - = -- | - -- @ - -- | relation_expr opt_alias_clause - -- | relation_expr opt_alias_clause tablesample_clause - -- @ - RelationExprTableRef RelationExpr (Maybe AliasClause) (Maybe TablesampleClause) - | -- | - -- @ - -- | func_table func_alias_clause - -- | LATERAL_P func_table func_alias_clause - -- @ - FuncTableRef Bool FuncTable (Maybe FuncAliasClause) - | -- | - -- @ - -- | select_with_parens opt_alias_clause - -- | LATERAL_P select_with_parens opt_alias_clause - -- @ - SelectTableRef Bool SelectWithParens (Maybe AliasClause) - | -- | - -- @ - -- | joined_table - -- | '(' joined_table ')' alias_clause - -- @ - JoinTableRef JoinedTable (Maybe AliasClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | qualified_name --- | qualified_name '*' --- | ONLY qualified_name --- | ONLY '(' qualified_name ')' --- @ -data RelationExpr - = SimpleRelationExpr - -- | Name. - QualifiedName - -- | Is asterisk present? - Bool - | OnlyRelationExpr - -- | Name. - QualifiedName - -- | Are parentheses present? - Bool - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- relation_expr_opt_alias: --- | relation_expr --- | relation_expr ColId --- | relation_expr AS ColId --- @ -data RelationExprOptAlias = RelationExprOptAlias RelationExpr (Maybe (Bool, ColId)) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- tablesample_clause: --- | TABLESAMPLE func_name '(' expr_list ')' opt_repeatable_clause --- @ -data TablesampleClause = TablesampleClause FuncName ExprList (Maybe RepeatableClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_repeatable_clause: --- | REPEATABLE '(' a_expr ')' --- | EMPTY --- @ -type RepeatableClause = AExpr - --- | --- ==== References --- @ --- func_table: --- | func_expr_windowless opt_ordinality --- | ROWS FROM '(' rowsfrom_list ')' opt_ordinality --- @ -data FuncTable - = FuncExprFuncTable FuncExprWindowless OptOrdinality - | RowsFromFuncTable RowsfromList OptOrdinality - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- rowsfrom_item: --- | func_expr_windowless opt_col_def_list --- @ -data RowsfromItem = RowsfromItem FuncExprWindowless (Maybe ColDefList) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- rowsfrom_list: --- | rowsfrom_item --- | rowsfrom_list ',' rowsfrom_item --- @ -type RowsfromList = NonEmpty RowsfromItem - --- | --- ==== References --- @ --- opt_col_def_list: --- | AS '(' TableFuncElementList ')' --- | EMPTY --- @ -type ColDefList = TableFuncElementList - --- | --- ==== References --- @ --- opt_ordinality: --- | WITH_LA ORDINALITY --- | EMPTY --- @ -type OptOrdinality = Bool - --- | --- ==== References --- @ --- TableFuncElementList: --- | TableFuncElement --- | TableFuncElementList ',' TableFuncElement --- @ -type TableFuncElementList = NonEmpty TableFuncElement - --- | --- ==== References --- @ --- TableFuncElement: --- | ColId Typename opt_collate_clause --- @ -data TableFuncElement = TableFuncElement ColId Typename (Maybe CollateClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_collate_clause: --- | COLLATE any_name --- | EMPTY --- @ -type CollateClause = AnyName - --- | --- ==== References --- @ --- alias_clause: --- | AS ColId '(' name_list ')' --- | AS ColId --- | ColId '(' name_list ')' --- | ColId --- @ -data AliasClause = AliasClause Bool ColId (Maybe NameList) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_alias_clause: --- | alias_clause --- | AS '(' TableFuncElementList ')' --- | AS ColId '(' TableFuncElementList ')' --- | ColId '(' TableFuncElementList ')' --- | EMPTY --- @ -data FuncAliasClause - = AliasFuncAliasClause AliasClause - | AsFuncAliasClause TableFuncElementList - | AsColIdFuncAliasClause ColId TableFuncElementList - | ColIdFuncAliasClause ColId TableFuncElementList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | '(' joined_table ')' --- | table_ref CROSS JOIN table_ref --- | table_ref join_type JOIN table_ref join_qual --- | table_ref JOIN table_ref join_qual --- | table_ref NATURAL join_type JOIN table_ref --- | table_ref NATURAL JOIN table_ref --- --- The options are covered by the `JoinMeth` type. --- @ -data JoinedTable - = InParensJoinedTable JoinedTable - | MethJoinedTable JoinMeth TableRef TableRef - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | table_ref CROSS JOIN table_ref --- | table_ref join_type JOIN table_ref join_qual --- | table_ref JOIN table_ref join_qual --- | table_ref NATURAL join_type JOIN table_ref --- | table_ref NATURAL JOIN table_ref --- @ -data JoinMeth - = CrossJoinMeth - | QualJoinMeth (Maybe JoinType) JoinQual - | NaturalJoinMeth (Maybe JoinType) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | FULL join_outer --- | LEFT join_outer --- | RIGHT join_outer --- | INNER_P --- @ -data JoinType - = FullJoinType Bool - | LeftJoinType Bool - | RightJoinType Bool - | InnerJoinType - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- join_qual: --- | USING '(' name_list ')' --- | ON a_expr --- @ -data JoinQual - = UsingJoinQual (NonEmpty Ident) - | OnJoinQual AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- * Where - -type WhereClause = AExpr - --- | --- ==== References --- @ --- | WHERE a_expr --- | WHERE CURRENT_P OF cursor_name --- | /*EMPTY*/ --- @ -data WhereOrCurrentClause - = ExprWhereOrCurrentClause AExpr - | CursorWhereOrCurrentClause CursorName - deriving (Show, Generic, Eq, Ord, Data) - --- * Expression - -type ExprList = NonEmpty AExpr - --- | --- ==== References --- @ --- a_expr: --- | c_expr --- | a_expr TYPECAST Typename --- | a_expr COLLATE any_name --- | a_expr AT TIME ZONE a_expr --- | '+' a_expr --- | '-' a_expr --- | a_expr '+' a_expr --- | a_expr '-' a_expr --- | a_expr '*' a_expr --- | a_expr '/' a_expr --- | a_expr '%' a_expr --- | a_expr '^' a_expr --- | a_expr '<' a_expr --- | a_expr '>' a_expr --- | a_expr '=' a_expr --- | a_expr LESS_EQUALS a_expr --- | a_expr GREATER_EQUALS a_expr --- | a_expr NOT_EQUALS a_expr --- | a_expr qual_Op a_expr --- | qual_Op a_expr --- | a_expr qual_Op --- | a_expr AND a_expr --- | a_expr OR a_expr --- | NOT a_expr --- | NOT_LA a_expr --- | a_expr LIKE a_expr --- | a_expr LIKE a_expr ESCAPE a_expr --- | a_expr NOT_LA LIKE a_expr --- | a_expr NOT_LA LIKE a_expr ESCAPE a_expr --- | a_expr ILIKE a_expr --- | a_expr ILIKE a_expr ESCAPE a_expr --- | a_expr NOT_LA ILIKE a_expr --- | a_expr NOT_LA ILIKE a_expr ESCAPE a_expr --- | a_expr SIMILAR TO a_expr --- | a_expr SIMILAR TO a_expr ESCAPE a_expr --- | a_expr NOT_LA SIMILAR TO a_expr --- | a_expr NOT_LA SIMILAR TO a_expr ESCAPE a_expr --- | a_expr IS NULL_P --- | a_expr ISNULL --- | a_expr IS NOT NULL_P --- | a_expr NOTNULL --- | row OVERLAPS row --- | a_expr IS TRUE_P --- | a_expr IS NOT TRUE_P --- | a_expr IS FALSE_P --- | a_expr IS NOT FALSE_P --- | a_expr IS UNKNOWN --- | a_expr IS NOT UNKNOWN --- | a_expr IS DISTINCT FROM a_expr --- | a_expr IS NOT DISTINCT FROM a_expr --- | a_expr IS OF '(' type_list ')' --- | a_expr IS NOT OF '(' type_list ')' --- | a_expr BETWEEN opt_asymmetric b_expr AND a_expr --- | a_expr NOT_LA BETWEEN opt_asymmetric b_expr AND a_expr --- | a_expr BETWEEN SYMMETRIC b_expr AND a_expr --- | a_expr NOT_LA BETWEEN SYMMETRIC b_expr AND a_expr --- | a_expr IN_P in_expr --- | a_expr NOT_LA IN_P in_expr --- | a_expr subquery_Op sub_type select_with_parens --- | a_expr subquery_Op sub_type '(' a_expr ')' --- | UNIQUE select_with_parens --- | a_expr IS DOCUMENT_P --- | a_expr IS NOT DOCUMENT_P --- | DEFAULT --- @ -data AExpr - = CExprAExpr CExpr - | TypecastAExpr AExpr Typename - | CollateAExpr AExpr AnyName - | AtTimeZoneAExpr AExpr AExpr - | PlusAExpr AExpr - | MinusAExpr AExpr - | SymbolicBinOpAExpr AExpr SymbolicExprBinOp AExpr - | PrefixQualOpAExpr QualOp AExpr - | SuffixQualOpAExpr AExpr QualOp - | AndAExpr AExpr AExpr - | OrAExpr AExpr AExpr - | NotAExpr AExpr - | VerbalExprBinOpAExpr AExpr Bool VerbalExprBinOp AExpr (Maybe AExpr) - | ReversableOpAExpr AExpr Bool AExprReversableOp - | IsnullAExpr AExpr - | NotnullAExpr AExpr - | OverlapsAExpr Row Row - | SubqueryAExpr AExpr SubqueryOp SubType (Either SelectWithParens AExpr) - | UniqueAExpr SelectWithParens - | DefaultAExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- b_expr: --- | c_expr --- | b_expr TYPECAST Typename --- | '+' b_expr --- | '-' b_expr --- | b_expr '+' b_expr --- | b_expr '-' b_expr --- | b_expr '*' b_expr --- | b_expr '/' b_expr --- | b_expr '%' b_expr --- | b_expr '^' b_expr --- | b_expr '<' b_expr --- | b_expr '>' b_expr --- | b_expr '=' b_expr --- | b_expr LESS_EQUALS b_expr --- | b_expr GREATER_EQUALS b_expr --- | b_expr NOT_EQUALS b_expr --- | b_expr qual_Op b_expr --- | qual_Op b_expr --- | b_expr qual_Op --- | b_expr IS DISTINCT FROM b_expr --- | b_expr IS NOT DISTINCT FROM b_expr --- | b_expr IS OF '(' type_list ')' --- | b_expr IS NOT OF '(' type_list ')' --- | b_expr IS DOCUMENT_P --- | b_expr IS NOT DOCUMENT_P --- @ -data BExpr - = CExprBExpr CExpr - | TypecastBExpr BExpr Typename - | PlusBExpr BExpr - | MinusBExpr BExpr - | SymbolicBinOpBExpr BExpr SymbolicExprBinOp BExpr - | QualOpBExpr QualOp BExpr - | IsOpBExpr BExpr Bool BExprIsOp - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- c_expr: --- | columnref --- | AexprConst --- | PARAM opt_indirection --- | '(' a_expr ')' opt_indirection --- | case_expr --- | func_expr --- | select_with_parens --- | select_with_parens indirection --- | EXISTS select_with_parens --- | ARRAY select_with_parens --- | ARRAY array_expr --- | explicit_row --- | implicit_row --- | GROUPING '(' expr_list ')' --- @ -data CExpr - = ColumnrefCExpr Columnref - | AexprConstCExpr AexprConst - | ParamCExpr Int (Maybe Indirection) - | InParensCExpr AExpr (Maybe Indirection) - | CaseCExpr CaseExpr - | FuncCExpr FuncExpr - | SelectWithParensCExpr SelectWithParens (Maybe Indirection) - | ExistsCExpr SelectWithParens - | ArrayCExpr (Either SelectWithParens ArrayExpr) - | ExplicitRowCExpr ExplicitRow - | ImplicitRowCExpr ImplicitRow - | GroupingCExpr ExprList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- in_expr: --- | select_with_parens --- | '(' expr_list ')' --- @ -data InExpr - = SelectInExpr SelectWithParens - | ExprListInExpr ExprList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- sub_type: --- | ANY --- | SOME --- | ALL --- @ -data SubType = AnySubType | SomeSubType | AllSubType - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - --- | --- ==== References --- @ --- array_expr: --- | '[' expr_list ']' --- | '[' array_expr_list ']' --- | '[' ']' --- @ -data ArrayExpr - = ExprListArrayExpr ExprList - | ArrayExprListArrayExpr ArrayExprList - | EmptyArrayExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- array_expr_list: --- | array_expr --- | array_expr_list ',' array_expr --- @ -type ArrayExprList = NonEmpty ArrayExpr - --- | --- ==== References --- @ --- row: --- | ROW '(' expr_list ')' --- | ROW '(' ')' --- | '(' expr_list ',' a_expr ')' --- @ -data Row - = ExplicitRowRow ExplicitRow - | ImplicitRowRow ImplicitRow - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- explicit_row: --- | ROW '(' expr_list ')' --- | ROW '(' ')' --- @ -type ExplicitRow = Maybe ExprList - --- | --- ==== References --- @ --- implicit_row: --- | '(' expr_list ',' a_expr ')' --- @ -data ImplicitRow = ImplicitRow ExprList AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_expr: --- | func_application within_group_clause filter_clause over_clause --- | func_expr_common_subexpr --- @ -data FuncExpr - = ApplicationFuncExpr FuncApplication (Maybe WithinGroupClause) (Maybe FilterClause) (Maybe OverClause) - | SubexprFuncExpr FuncExprCommonSubexpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_expr_windowless: --- | func_application --- | func_expr_common_subexpr --- @ -data FuncExprWindowless - = ApplicationFuncExprWindowless FuncApplication - | CommonSubexprFuncExprWindowless FuncExprCommonSubexpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- within_group_clause: --- | WITHIN GROUP_P '(' sort_clause ')' --- | EMPTY --- @ -type WithinGroupClause = SortClause - --- | --- ==== References --- @ --- filter_clause: --- | FILTER '(' WHERE a_expr ')' --- | EMPTY --- @ -type FilterClause = AExpr - --- | --- ==== References --- @ --- over_clause: --- | OVER window_specification --- | OVER ColId --- | EMPTY --- @ -data OverClause - = WindowOverClause WindowSpecification - | ColIdOverClause ColId - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_expr_common_subexpr: --- | COLLATION FOR '(' a_expr ')' --- | CURRENT_DATE --- | CURRENT_TIME --- | CURRENT_TIME '(' Iconst ')' --- | CURRENT_TIMESTAMP --- | CURRENT_TIMESTAMP '(' Iconst ')' --- | LOCALTIME --- | LOCALTIME '(' Iconst ')' --- | LOCALTIMESTAMP --- | LOCALTIMESTAMP '(' Iconst ')' --- | CURRENT_ROLE --- | CURRENT_USER --- | SESSION_USER --- | USER --- | CURRENT_CATALOG --- | CURRENT_SCHEMA --- | CAST '(' a_expr AS Typename ')' --- | EXTRACT '(' extract_list ')' --- | OVERLAY '(' overlay_list ')' --- | POSITION '(' position_list ')' --- | SUBSTRING '(' substr_list ')' --- | TREAT '(' a_expr AS Typename ')' --- | TRIM '(' BOTH trim_list ')' --- | TRIM '(' LEADING trim_list ')' --- | TRIM '(' TRAILING trim_list ')' --- | TRIM '(' trim_list ')' --- | NULLIF '(' a_expr ',' a_expr ')' --- | COALESCE '(' expr_list ')' --- | GREATEST '(' expr_list ')' --- | LEAST '(' expr_list ')' --- | XMLCONCAT '(' expr_list ')' --- | XMLELEMENT '(' NAME_P ColLabel ')' --- | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ')' --- | XMLELEMENT '(' NAME_P ColLabel ',' expr_list ')' --- | XMLELEMENT '(' NAME_P ColLabel ',' xml_attributes ',' expr_list ')' --- | XMLEXISTS '(' c_expr xmlexists_argument ')' --- | XMLFOREST '(' xml_attribute_list ')' --- | XMLPARSE '(' document_or_content a_expr xml_whitespace_option ')' --- | XMLPI '(' NAME_P ColLabel ')' --- | XMLPI '(' NAME_P ColLabel ',' a_expr ')' --- | XMLROOT '(' a_expr ',' xml_root_version opt_xml_root_standalone ')' --- | XMLSERIALIZE '(' document_or_content a_expr AS SimpleTypename ')' --- --- TODO: Implement the XML cases --- @ -data FuncExprCommonSubexpr - = CollationForFuncExprCommonSubexpr AExpr - | CurrentDateFuncExprCommonSubexpr - | CurrentTimeFuncExprCommonSubexpr (Maybe Int64) - | CurrentTimestampFuncExprCommonSubexpr (Maybe Int64) - | LocalTimeFuncExprCommonSubexpr (Maybe Int64) - | LocalTimestampFuncExprCommonSubexpr (Maybe Int64) - | CurrentRoleFuncExprCommonSubexpr - | CurrentUserFuncExprCommonSubexpr - | SessionUserFuncExprCommonSubexpr - | UserFuncExprCommonSubexpr - | CurrentCatalogFuncExprCommonSubexpr - | CurrentSchemaFuncExprCommonSubexpr - | CastFuncExprCommonSubexpr AExpr Typename - | ExtractFuncExprCommonSubexpr (Maybe ExtractList) - | OverlayFuncExprCommonSubexpr OverlayList - | PositionFuncExprCommonSubexpr (Maybe PositionList) - | SubstringFuncExprCommonSubexpr (Maybe SubstrList) - | TreatFuncExprCommonSubexpr AExpr Typename - | TrimFuncExprCommonSubexpr (Maybe TrimModifier) TrimList - | NullIfFuncExprCommonSubexpr AExpr AExpr - | CoalesceFuncExprCommonSubexpr ExprList - | GreatestFuncExprCommonSubexpr ExprList - | LeastFuncExprCommonSubexpr ExprList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- extract_list: --- | extract_arg FROM a_expr --- | EMPTY --- @ -data ExtractList = ExtractList ExtractArg AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- extract_arg: --- | IDENT --- | YEAR_P --- | MONTH_P --- | DAY_P --- | HOUR_P --- | MINUTE_P --- | SECOND_P --- | Sconst --- @ -data ExtractArg - = IdentExtractArg Ident - | YearExtractArg - | MonthExtractArg - | DayExtractArg - | HourExtractArg - | MinuteExtractArg - | SecondExtractArg - | SconstExtractArg Sconst - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- overlay_list: --- | a_expr overlay_placing substr_from substr_for --- | a_expr overlay_placing substr_from --- @ -data OverlayList = OverlayList AExpr OverlayPlacing SubstrFrom (Maybe SubstrFor) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- overlay_placing: --- | PLACING a_expr --- @ -type OverlayPlacing = AExpr - --- | --- ==== References --- @ --- position_list: --- | b_expr IN_P b_expr --- | EMPTY --- @ -data PositionList = PositionList BExpr BExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- substr_list: --- | a_expr substr_from substr_for --- | a_expr substr_for substr_from --- | a_expr substr_from --- | a_expr substr_for --- | expr_list --- | EMPTY --- @ -data SubstrList - = ExprSubstrList AExpr SubstrListFromFor - | ExprListSubstrList ExprList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | a_expr substr_from substr_for --- | a_expr substr_for substr_from --- | a_expr substr_from --- | a_expr substr_for --- @ -data SubstrListFromFor - = FromForSubstrListFromFor SubstrFrom SubstrFor - | ForFromSubstrListFromFor SubstrFor SubstrFrom - | FromSubstrListFromFor SubstrFrom - | ForSubstrListFromFor SubstrFor - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- substr_from: --- | FROM a_expr --- @ -type SubstrFrom = AExpr - --- | --- ==== References --- @ --- substr_for: --- | FOR a_expr --- @ -type SubstrFor = AExpr - --- | --- ==== References --- @ --- | TRIM '(' BOTH trim_list ')' --- | TRIM '(' LEADING trim_list ')' --- | TRIM '(' TRAILING trim_list ')' --- @ -data TrimModifier = BothTrimModifier | LeadingTrimModifier | TrailingTrimModifier - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - --- | --- ==== References --- @ --- trim_list: --- | a_expr FROM expr_list --- | FROM expr_list --- | expr_list --- @ -data TrimList - = ExprFromExprListTrimList AExpr ExprList - | FromExprListTrimList ExprList - | ExprListTrimList ExprList - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- case_expr: --- | CASE case_arg when_clause_list case_default END_P --- @ -data CaseExpr = CaseExpr (Maybe CaseArg) WhenClauseList (Maybe CaseDefault) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- case_arg: --- | a_expr --- | EMPTY --- @ -type CaseArg = AExpr - --- | --- ==== References --- @ --- when_clause_list: --- | when_clause --- | when_clause_list when_clause --- @ -type WhenClauseList = NonEmpty WhenClause - --- | --- ==== References --- @ --- case_default: --- | ELSE a_expr --- | EMPTY --- @ -type CaseDefault = AExpr - --- | --- ==== References --- @ --- when_clause: --- | WHEN a_expr THEN a_expr --- @ -data WhenClause = WhenClause AExpr AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_application: --- | func_name '(' ')' --- | func_name '(' func_arg_list opt_sort_clause ')' --- | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')' --- | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')' --- | func_name '(' ALL func_arg_list opt_sort_clause ')' --- | func_name '(' DISTINCT func_arg_list opt_sort_clause ')' --- | func_name '(' '*' ')' --- @ -data FuncApplication = FuncApplication FuncName (Maybe FuncApplicationParams) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_application: --- | func_name '(' ')' --- | func_name '(' func_arg_list opt_sort_clause ')' --- | func_name '(' VARIADIC func_arg_expr opt_sort_clause ')' --- | func_name '(' func_arg_list ',' VARIADIC func_arg_expr opt_sort_clause ')' --- | func_name '(' ALL func_arg_list opt_sort_clause ')' --- | func_name '(' DISTINCT func_arg_list opt_sort_clause ')' --- | func_name '(' '*' ')' --- @ -data FuncApplicationParams - = NormalFuncApplicationParams (Maybe Bool) (NonEmpty FuncArgExpr) (Maybe SortClause) - | VariadicFuncApplicationParams (Maybe (NonEmpty FuncArgExpr)) FuncArgExpr (Maybe SortClause) - | StarFuncApplicationParams - deriving (Show, Generic, Eq, Ord, Data) - -data FuncArgExpr - = ExprFuncArgExpr AExpr - | ColonEqualsFuncArgExpr Ident AExpr - | EqualsGreaterFuncArgExpr Ident AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- * Constants - -type Sconst = Text - -type Iconst = Int64 - -type Fconst = Double - -type Bconst = Text - -type Xconst = Text - --- | --- AexprConst: --- | Iconst --- | FCONST --- | Sconst --- | BCONST --- | XCONST --- | func_name Sconst --- | func_name '(' func_arg_list opt_sort_clause ')' Sconst --- | ConstTypename Sconst --- | ConstInterval Sconst opt_interval --- | ConstInterval '(' Iconst ')' Sconst --- | TRUE_P --- | FALSE_P --- | NULL_P -data AexprConst - = IAexprConst Iconst - | FAexprConst Fconst - | SAexprConst Sconst - | BAexprConst Bconst - | XAexprConst Xconst - | FuncAexprConst FuncName (Maybe FuncConstArgs) Sconst - | ConstTypenameAexprConst ConstTypename Sconst - | StringIntervalAexprConst Sconst (Maybe Interval) - | IntIntervalAexprConst Iconst Sconst - | BoolAexprConst Bool - | NullAexprConst - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | func_name '(' func_arg_list opt_sort_clause ')' Sconst --- @ -data FuncConstArgs = FuncConstArgs (NonEmpty FuncArgExpr) (Maybe SortClause) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- ConstTypename: --- | Numeric --- | ConstBit --- | ConstCharacter --- | ConstDatetime --- @ -data ConstTypename - = NumericConstTypename Numeric - | ConstBitConstTypename ConstBit - | ConstCharacterConstTypename ConstCharacter - | ConstDatetimeConstTypename ConstDatetime - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- Numeric: --- | INT_P --- | INTEGER --- | SMALLINT --- | BIGINT --- | REAL --- | FLOAT_P opt_float --- | DOUBLE_P PRECISION --- | DECIMAL_P opt_type_modifiers --- | DEC opt_type_modifiers --- | NUMERIC opt_type_modifiers --- | BOOLEAN_P --- opt_float: --- | '(' Iconst ')' --- | EMPTY --- opt_type_modifiers: --- | '(' expr_list ')' --- | EMPTY --- @ -data Numeric - = IntNumeric - | IntegerNumeric - | SmallintNumeric - | BigintNumeric - | RealNumeric - | FloatNumeric (Maybe Int64) - | DoublePrecisionNumeric - | DecimalNumeric (Maybe TypeModifiers) - | DecNumeric (Maybe TypeModifiers) - | NumericNumeric (Maybe TypeModifiers) - | BooleanNumeric - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- Bit: --- | BitWithLength --- | BitWithoutLength --- ConstBit: --- | BitWithLength --- | BitWithoutLength --- BitWithLength: --- | BIT opt_varying '(' expr_list ')' --- BitWithoutLength: --- | BIT opt_varying --- @ -data Bit = Bit OptVarying (Maybe ExprList) - deriving (Show, Generic, Eq, Ord, Data) - -type ConstBit = Bit - --- | --- ==== References --- @ --- opt_varying: --- | VARYING --- | EMPTY --- @ -type OptVarying = Bool - --- | --- ==== References --- @ --- Character: --- | CharacterWithLength --- | CharacterWithoutLength --- ConstCharacter: --- | CharacterWithLength --- | CharacterWithoutLength --- CharacterWithLength: --- | character '(' Iconst ')' --- CharacterWithoutLength: --- | character --- @ -data ConstCharacter = ConstCharacter Character (Maybe Int64) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- character: --- | CHARACTER opt_varying --- | CHAR_P opt_varying --- | VARCHAR --- | NATIONAL CHARACTER opt_varying --- | NATIONAL CHAR_P opt_varying --- | NCHAR opt_varying --- @ -data Character - = CharacterCharacter OptVarying - | CharCharacter OptVarying - | VarcharCharacter - | NationalCharacterCharacter OptVarying - | NationalCharCharacter OptVarying - | NcharCharacter OptVarying - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- ConstDatetime: --- | TIMESTAMP '(' Iconst ')' opt_timezone --- | TIMESTAMP opt_timezone --- | TIME '(' Iconst ')' opt_timezone --- | TIME opt_timezone --- @ -data ConstDatetime - = TimestampConstDatetime (Maybe Int64) (Maybe Timezone) - | TimeConstDatetime (Maybe Int64) (Maybe Timezone) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_timezone: --- | WITH_LA TIME ZONE --- | WITHOUT TIME ZONE --- | EMPTY --- @ -type Timezone = Bool - --- | --- ==== References --- @ --- opt_interval: --- | YEAR_P --- | MONTH_P --- | DAY_P --- | HOUR_P --- | MINUTE_P --- | interval_second --- | YEAR_P TO MONTH_P --- | DAY_P TO HOUR_P --- | DAY_P TO MINUTE_P --- | DAY_P TO interval_second --- | HOUR_P TO MINUTE_P --- | HOUR_P TO interval_second --- | MINUTE_P TO interval_second --- | EMPTY --- @ -data Interval - = YearInterval - | MonthInterval - | DayInterval - | HourInterval - | MinuteInterval - | SecondInterval IntervalSecond - | YearToMonthInterval - | DayToHourInterval - | DayToMinuteInterval - | DayToSecondInterval IntervalSecond - | HourToMinuteInterval - | HourToSecondInterval IntervalSecond - | MinuteToSecondInterval IntervalSecond - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- interval_second: --- | SECOND_P --- | SECOND_P '(' Iconst ')' --- @ -type IntervalSecond = Maybe Int64 - --- * Names & References - --- | --- ==== References --- @ --- IDENT --- @ -data Ident = QuotedIdent Text | UnquotedIdent Text - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- ColId: --- | IDENT --- | unreserved_keyword --- | col_name_keyword --- @ -type ColId = Ident - --- | --- ==== References --- @ --- ColLabel: --- | IDENT --- | unreserved_keyword --- | col_name_keyword --- | type_func_name_keyword --- | reserved_keyword --- @ -type ColLabel = Ident - --- | --- ==== References --- @ --- name: --- | ColId --- @ -type Name = ColId - --- | --- ==== References --- @ --- name_list: --- | name --- | name_list ',' name --- @ -type NameList = NonEmpty Name - --- | --- ==== References --- @ --- cursor_name: --- | name --- @ -type CursorName = Name - --- | --- ==== References --- @ --- columnref: --- | ColId --- | ColId indirection --- @ -data Columnref = Columnref ColId (Maybe Indirection) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- any_name: --- | ColId --- | ColId attrs --- @ -data AnyName = AnyName ColId (Maybe Attrs) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- func_name: --- | type_function_name --- | ColId indirection --- @ -data FuncName - = TypeFuncName TypeFunctionName - | IndirectedFuncName ColId Indirection - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- type_function_name: --- | IDENT --- | unreserved_keyword --- | type_func_name_keyword --- @ -type TypeFunctionName = Ident - --- | --- ==== References --- @ --- columnref: --- | ColId --- | ColId indirection --- qualified_name: --- | ColId --- | ColId indirection --- @ -data QualifiedName - = SimpleQualifiedName Ident - | IndirectedQualifiedName Ident Indirection - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- indirection: --- | indirection_el --- | indirection indirection_el --- @ -type Indirection = NonEmpty IndirectionEl - --- | --- ==== References --- @ --- indirection_el: --- | '.' attr_name --- | '.' '*' --- | '[' a_expr ']' --- | '[' opt_slice_bound ':' opt_slice_bound ']' --- opt_slice_bound: --- | a_expr --- | EMPTY --- @ -data IndirectionEl - = AttrNameIndirectionEl Ident - | AllIndirectionEl - | ExprIndirectionEl AExpr - | SliceIndirectionEl (Maybe AExpr) (Maybe AExpr) - deriving (Show, Generic, Eq, Ord, Data) - --- * Types - --- | --- Typename definition extended with custom question-marks for nullability specification. --- --- To match the standard Postgres syntax simply interpret their presence as a parsing error. --- --- ==== References --- @ --- Typename: --- | SimpleTypename opt_array_bounds --- | SETOF SimpleTypename opt_array_bounds --- | SimpleTypename ARRAY '[' Iconst ']' --- | SETOF SimpleTypename ARRAY '[' Iconst ']' --- | SimpleTypename ARRAY --- | SETOF SimpleTypename ARRAY --- @ -data Typename - = Typename - -- | SETOF - Bool - SimpleTypename - -- | Question mark - Bool - -- | Array dimensions possibly followed by a question mark - (Maybe (TypenameArrayDimensions, Bool)) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- Part of the Typename specification responsible for the choice between the following: --- | opt_array_bounds --- | ARRAY '[' Iconst ']' --- | ARRAY --- @ -data TypenameArrayDimensions - = BoundsTypenameArrayDimensions ArrayBounds - | ExplicitTypenameArrayDimensions (Maybe Iconst) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_array_bounds: --- | opt_array_bounds '[' ']' --- | opt_array_bounds '[' Iconst ']' --- | EMPTY --- @ -type ArrayBounds = NonEmpty (Maybe Iconst) - --- | --- ==== References --- @ --- SimpleTypename: --- | GenericType --- | Numeric --- | Bit --- | Character --- | ConstDatetime --- | ConstInterval opt_interval --- | ConstInterval '(' Iconst ')' --- ConstInterval: --- | INTERVAL --- @ -data SimpleTypename - = GenericTypeSimpleTypename GenericType - | NumericSimpleTypename Numeric - | BitSimpleTypename Bit - | CharacterSimpleTypename Character - | ConstDatetimeSimpleTypename ConstDatetime - | ConstIntervalSimpleTypename (Either (Maybe Interval) Iconst) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- GenericType: --- | type_function_name opt_type_modifiers --- | type_function_name attrs opt_type_modifiers --- @ -data GenericType = GenericType TypeFunctionName (Maybe Attrs) (Maybe TypeModifiers) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- attrs: --- | '.' attr_name --- | attrs '.' attr_name --- @ -type Attrs = NonEmpty AttrName - --- | --- ==== References --- @ --- attr_name: --- | ColLabel --- @ -type AttrName = ColLabel - --- | --- ==== References --- @ --- opt_type_modifiers: --- | '(' expr_list ')' --- | EMPTY --- @ -type TypeModifiers = ExprList - --- | --- ==== References --- @ --- type_list: --- | Typename --- | type_list ',' Typename --- @ -type TypeList = NonEmpty Typename - --- * Operators - --- | --- ==== References --- @ --- qual_Op: --- | Op --- | OPERATOR '(' any_operator ')' --- @ -data QualOp - = OpQualOp Op - | OperatorQualOp AnyOperator - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- qual_all_Op: --- | all_Op --- | OPERATOR '(' any_operator ')' --- @ -data QualAllOp - = AllQualAllOp AllOp - | AnyQualAllOp AnyOperator - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) --- characters from the following list: --- --- + - * / < > = ~ ! @ # % ^ & | ` ? --- --- There are a few restrictions on your choice of name: --- -- and /* cannot appear anywhere in an operator name, --- since they will be taken as the start of a comment. --- --- A multicharacter operator name cannot end in + or -, --- unless the name also contains at least one of these characters: --- --- ~ ! @ # % ^ & | ` ? --- --- For example, @- is an allowed operator name, but *- is not. --- This restriction allows PostgreSQL to parse SQL-compliant --- commands without requiring spaces between tokens. --- The use of => as an operator name is deprecated. --- It may be disallowed altogether in a future release. --- --- The operator != is mapped to <> on input, --- so these two names are always equivalent. --- @ -type Op = Text - --- | --- ==== References --- @ --- any_operator: --- | all_Op --- | ColId '.' any_operator --- @ -data AnyOperator - = AllOpAnyOperator AllOp - | QualifiedAnyOperator ColId AnyOperator - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- all_Op: --- | Op --- | MathOp --- @ -data AllOp - = OpAllOp Op - | MathAllOp MathOp - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- MathOp: --- | '+' --- | '-' --- | '*' --- | '/' --- | '%' --- | '^' --- | '<' --- | '>' --- | '=' --- | LESS_EQUALS --- | GREATER_EQUALS --- | NOT_EQUALS --- @ -data MathOp - = PlusMathOp - | MinusMathOp - | AsteriskMathOp - | SlashMathOp - | PercentMathOp - | ArrowUpMathOp - | ArrowLeftMathOp - | ArrowRightMathOp - | EqualsMathOp - | LessEqualsMathOp - | GreaterEqualsMathOp - | ArrowLeftArrowRightMathOp - | ExclamationEqualsMathOp - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - -data SymbolicExprBinOp - = MathSymbolicExprBinOp MathOp - | QualSymbolicExprBinOp QualOp - deriving (Show, Generic, Eq, Ord, Data) - -data VerbalExprBinOp - = LikeVerbalExprBinOp - | IlikeVerbalExprBinOp - | SimilarToVerbalExprBinOp - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - --- | --- ==== References --- @ --- | a_expr IS NULL_P --- | a_expr IS TRUE_P --- | a_expr IS FALSE_P --- | a_expr IS UNKNOWN --- | a_expr IS DISTINCT FROM a_expr --- | a_expr IS OF '(' type_list ')' --- | a_expr BETWEEN opt_asymmetric b_expr AND a_expr --- | a_expr BETWEEN SYMMETRIC b_expr AND a_expr --- | a_expr IN_P in_expr --- | a_expr IS DOCUMENT_P --- @ -data AExprReversableOp - = NullAExprReversableOp - | TrueAExprReversableOp - | FalseAExprReversableOp - | UnknownAExprReversableOp - | DistinctFromAExprReversableOp AExpr - | OfAExprReversableOp TypeList - | BetweenAExprReversableOp Bool BExpr AExpr - | BetweenSymmetricAExprReversableOp BExpr AExpr - | InAExprReversableOp InExpr - | DocumentAExprReversableOp - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | b_expr IS DISTINCT FROM b_expr --- | b_expr IS NOT DISTINCT FROM b_expr --- | b_expr IS OF '(' type_list ')' --- | b_expr IS NOT OF '(' type_list ')' --- | b_expr IS DOCUMENT_P --- | b_expr IS NOT DOCUMENT_P --- @ -data BExprIsOp - = DistinctFromBExprIsOp BExpr - | OfBExprIsOp TypeList - | DocumentBExprIsOp - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- subquery_Op: --- | all_Op --- | OPERATOR '(' any_operator ')' --- | LIKE --- | NOT_LA LIKE --- | ILIKE --- | NOT_LA ILIKE --- @ -data SubqueryOp - = AllSubqueryOp AllOp - | AnySubqueryOp AnyOperator - | LikeSubqueryOp Bool - | IlikeSubqueryOp Bool - deriving (Show, Generic, Eq, Ord, Data) - --- * Indexes - --- | --- ==== References --- @ --- index_params: --- | index_elem --- | index_params ',' index_elem --- @ -type IndexParams = NonEmpty IndexElem - --- | --- ==== References --- @ --- index_elem: --- | ColId opt_collate opt_class opt_asc_desc opt_nulls_order --- | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order --- | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order --- @ -data IndexElem = IndexElem IndexElemDef (Maybe Collate) (Maybe Class) (Maybe AscDesc) (Maybe NullsOrder) - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- | ColId opt_collate opt_class opt_asc_desc opt_nulls_order --- | func_expr_windowless opt_collate opt_class opt_asc_desc opt_nulls_order --- | '(' a_expr ')' opt_collate opt_class opt_asc_desc opt_nulls_order --- @ -data IndexElemDef - = IdIndexElemDef ColId - | FuncIndexElemDef FuncExprWindowless - | ExprIndexElemDef AExpr - deriving (Show, Generic, Eq, Ord, Data) - --- | --- ==== References --- @ --- opt_collate: --- | COLLATE any_name --- | EMPTY --- @ -type Collate = AnyName - --- | --- ==== References --- @ --- opt_class: --- | any_name --- | EMPTY --- @ -type Class = AnyName - --- | --- ==== References --- @ --- opt_asc_desc: --- | ASC --- | DESC --- | EMPTY --- @ -data AscDesc = AscAscDesc | DescAscDesc - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) - --- | --- ==== References --- @ --- opt_nulls_order: --- | NULLS_LA FIRST_P --- | NULLS_LA LAST_P --- | EMPTY --- @ -data NullsOrder = FirstNullsOrder | LastNullsOrder - deriving (Show, Generic, Eq, Ord, Data, Enum, Bounded) diff --git a/library/PostgresqlSyntax/CharSet.hs b/library/PostgresqlSyntax/CharSet.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/CharSet.hs +++ /dev/null @@ -1,21 +0,0 @@ -module PostgresqlSyntax.CharSet where - -import qualified Data.Text as Text -import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import PostgresqlSyntax.Prelude - -{-# NOINLINE symbolicBinOp #-} -symbolicBinOp :: HashSet Char -symbolicBinOp = KeywordSet.symbolicBinOp & toList & mconcat & Text.unpack & fromList - -{-# NOINLINE hexDigit #-} -hexDigit :: HashSet Char -hexDigit = fromList "0123456789abcdefABCDEF" - -{-# NOINLINE op #-} -op :: HashSet Char -op = fromList "+-*/<>=~!@#%^&|`?" - -{-# NOINLINE prohibitionLiftingOp #-} -prohibitionLiftingOp :: HashSet Char -prohibitionLiftingOp = fromList "~!@#%^&|`?" diff --git a/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs b/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Extras/HeadedMegaparsec.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-dodgy-imports -Wno-unused-imports #-} - --- | --- Generic helpers for HeadedMegaparsec. -module PostgresqlSyntax.Extras.HeadedMegaparsec where - -import Control.Applicative.Combinators hiding (some) -import Control.Applicative.Combinators.NonEmpty -import qualified Data.Text as Text -import HeadedMegaparsec hiding (string) -import PostgresqlSyntax.Prelude hiding (bit, expr, filter, head, many, option, some, sortBy, tail, try) -import Text.Megaparsec (Parsec, Stream, TraversableStream, VisualStream) -import qualified Text.Megaparsec as Megaparsec -import qualified Text.Megaparsec.Char as MegaparsecChar -import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer - --- $setup --- >>> testParser parser = either putStr print . run parser - --- * Executors - -run :: (Ord err, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent err) => HeadedParsec err strm a -> strm -> Either String a -run p = first Megaparsec.errorBundlePretty . runParser p - --- | --- Run the parser but returns all the error messages separated, along with their offset in the parsed message. -runParserWithErrorPos :: (Show (Megaparsec.Token strm), Show e, Ord e, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent e) => HeadedParsec e strm a -> strm -> Either (NonEmpty (Int, String)) a -runParserWithErrorPos p s = case runParser p s of - Left err -> Left (extractor <$> Megaparsec.bundleErrors err) - Right v -> Right v - where - extractor x = (Megaparsec.errorOffset x, Megaparsec.parseErrorPretty x) - -runParser :: (Ord e, VisualStream strm, TraversableStream strm) => HeadedParsec e strm a -> strm -> Either (Megaparsec.ParseErrorBundle strm e) a -runParser p = Megaparsec.runParser (toParsec p <* Megaparsec.eof) "" - --- * Primitives - --- | --- Lifted megaparsec\'s `Megaparsec.eof`. -eof :: (Ord err, Stream strm) => HeadedParsec err strm () -eof = parse Megaparsec.eof - --- | --- Lifted megaparsec\'s `Megaparsec.space`. -space :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm () -space = parse MegaparsecChar.space - --- | --- Lifted megaparsec\'s `Megaparsec.space1`. -space1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm () -space1 = parse MegaparsecChar.space1 - --- | --- Lifted megaparsec\'s `Megaparsec.char`. -char :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char -char a = parse (MegaparsecChar.char a) - --- | --- Lifted megaparsec\'s `Megaparsec.char'`. -char' :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char -char' a = parse (MegaparsecChar.char' a) - --- | --- Lifted megaparsec\'s `Megaparsec.string`. -string :: (Ord err, Stream strm) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm) -string = parse . MegaparsecChar.string - --- | --- Lifted megaparsec\'s `Megaparsec.string'`. -string' :: (Ord err, Stream strm, FoldCase (Megaparsec.Tokens strm)) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm) -string' = parse . MegaparsecChar.string' - --- | --- Lifted megaparsec\'s `Megaparsec.takeWhileP`. -takeWhileP :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm) -takeWhileP label predicate = parse (Megaparsec.takeWhileP label predicate) - --- | --- Lifted megaparsec\'s `Megaparsec.takeWhile1P`. -takeWhile1P :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm) -takeWhile1P label predicate = parse (Megaparsec.takeWhile1P label predicate) - -satisfy :: (Ord err, Stream strm) => (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Token strm) -satisfy = parse . Megaparsec.satisfy - -decimal :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, Integral decimal) => HeadedParsec err strm decimal -decimal = parse MegaparsecLexer.decimal - -float :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, RealFloat float) => HeadedParsec err strm float -float = parse MegaparsecLexer.float - --- * Combinators - -sep1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separtor -> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a) -sep1 separator parser = do - head <- parser - endHead - tail <- many $ separator *> parser - return (head :| tail) - -sepEnd1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separator -> HeadedParsec err strm end -> HeadedParsec err strm el -> HeadedParsec err strm (NonEmpty el, end) -sepEnd1 sepP endP elP = do - headEl <- elP - let loop !list = do - _ <- sepP - asum - [ do - end <- endP - return (headEl :| reverse list, end), - do - el <- elP - loop (el : list) - ] - in loop [] - -notFollowedBy :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm () -notFollowedBy a = parse (Megaparsec.notFollowedBy (toParsec a)) diff --git a/library/PostgresqlSyntax/Extras/NonEmpty.hs b/library/PostgresqlSyntax/Extras/NonEmpty.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Extras/NonEmpty.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# OPTIONS_GHC -Wno-dodgy-imports #-} - -module PostgresqlSyntax.Extras.NonEmpty where - -import Data.List.NonEmpty -import PostgresqlSyntax.Prelude hiding (cons, fromList, head, init, last, reverse, tail, uncons) - --- | --- >>> intersperseFoldMap ", " id (fromList ["a"]) --- "a" --- --- >>> intersperseFoldMap ", " id (fromList ["a", "b", "c"]) --- "a, b, c" -intersperseFoldMap :: (Monoid m) => m -> (a -> m) -> NonEmpty a -> m -intersperseFoldMap a b (c :| d) = b c <> foldMap (mappend a . b) d - -unsnoc :: NonEmpty a -> (Maybe (NonEmpty a), a) -unsnoc = - let build1 = \case - a :| b -> build2 a b - build2 a = \case - b : c -> build3 b (a :| []) c - _ -> (Nothing, a) - build3 a b = \case - c : d -> build3 c (cons a b) d - _ -> (Just (reverse b), a) - in build1 - -consAndUnsnoc :: a -> NonEmpty a -> (NonEmpty a, a) -consAndUnsnoc a b = case unsnoc b of - (c, d) -> case c of - Just e -> (cons a e, d) - Nothing -> (pure a, d) diff --git a/library/PostgresqlSyntax/Extras/TextBuilder.hs b/library/PostgresqlSyntax/Extras/TextBuilder.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Extras/TextBuilder.hs +++ /dev/null @@ -1,16 +0,0 @@ -module PostgresqlSyntax.Extras.TextBuilder where - -import PostgresqlSyntax.Prelude -import TextBuilder - -char7 :: Char -> TextBuilder -char7 = char - -intDec :: Int -> TextBuilder -intDec = decimal - -int64Dec :: Int64 -> TextBuilder -int64Dec = decimal - -doubleDec :: Double -> TextBuilder -doubleDec = fromString . show diff --git a/library/PostgresqlSyntax/KeywordSet.hs b/library/PostgresqlSyntax/KeywordSet.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/KeywordSet.hs +++ /dev/null @@ -1,66 +0,0 @@ -module PostgresqlSyntax.KeywordSet where - -import Data.HashSet -import PostgresqlSyntax.Prelude hiding (fromList, toList) - -{-# NOINLINE keyword #-} -{- -From https://github.com/postgres/postgres/blob/1aac32df89eb19949050f6f27c268122833ad036/src/include/parser/kwlist.h --} -keyword :: HashSet Text -keyword = fromList ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "all", "also", "alter", "always", "analyse", "analyze", "and", "any", "array", "as", "asc", "assertion", "assignment", "asymmetric", "at", "attach", "attribute", "authorization", "backward", "before", "begin", "between", "bigint", "binary", "bit", "boolean", "both", "by", "cache", "call", "called", "cascade", "cascaded", "case", "cast", "catalog", "chain", "char", "character", "characteristics", "check", "checkpoint", "class", "close", "cluster", "coalesce", "collate", "collation", "column", "columns", "comment", "comments", "commit", "committed", "concurrently", "configuration", "conflict", "connection", "constraint", "constraints", "content", "continue", "conversion", "copy", "cost", "create", "cross", "csv", "cube", "current", "current_catalog", "current_date", "current_role", "current_schema", "current_time", "current_timestamp", "current_user", "cursor", "cycle", "data", "database", "day", "deallocate", "dec", "decimal", "declare", "default", "defaults", "deferrable", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "desc", "detach", "dictionary", "disable", "discard", "distinct", "do", "document", "domain", "double", "drop", "each", "else", "enable", "encoding", "encrypted", "end", "enum", "escape", "event", "except", "exclude", "excluding", "exclusive", "execute", "exists", "explain", "expression", "extension", "external", "extract", "false", "family", "fetch", "filter", "first", "float", "following", "for", "force", "foreign", "forward", "freeze", "from", "full", "function", "functions", "generated", "global", "grant", "granted", "greatest", "group", "grouping", "groups", "handler", "having", "header", "hold", "hour", "identity", "if", "ilike", "immediate", "immutable", "implicit", "import", "in", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "initially", "inline", "inner", "inout", "input", "insensitive", "insert", "instead", "int", "integer", "intersect", "interval", "into", "invoker", "is", "isnull", "isolation", "join", "key", "label", "language", "large", "last", "lateral", "leading", "leakproof", "least", "left", "level", "like", "limit", "listen", "load", "local", "localtime", "localtimestamp", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "national", "natural", "nchar", "new", "next", "nfc", "nfd", "nfkc", "nfkd", "no", "none", "normalize", "normalized", "not", "nothing", "notify", "notnull", "nowait", "null", "nullif", "nulls", "numeric", "object", "of", "off", "offset", "oids", "old", "on", "only", "operator", "option", "options", "or", "order", "ordinality", "others", "out", "outer", "over", "overlaps", "overlay", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "placing", "plans", "policy", "position", "preceding", "precision", "prepare", "prepared", "preserve", "primary", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "real", "reassign", "recheck", "recursive", "ref", "references", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returning", "returns", "revoke", "right", "role", "rollback", "rollup", "routine", "routines", "row", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "select", "sequence", "sequences", "serializable", "server", "session", "session_user", "set", "setof", "sets", "share", "show", "similar", "simple", "skip", "smallint", "snapshot", "some", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "substring", "support", "symmetric", "sysid", "system", "table", "tables", "tablesample", "tablespace", "temp", "template", "temporary", "text", "then", "ties", "time", "timestamp", "to", "trailing", "transaction", "transform", "treat", "trigger", "trim", "true", "truncate", "trusted", "type", "types", "uescape", "unbounded", "uncommitted", "unencrypted", "union", "unique", "unknown", "unlisten", "unlogged", "until", "update", "user", "using", "vacuum", "valid", "validate", "validator", "value", "values", "varchar", "variadic", "varying", "verbose", "version", "view", "views", "volatile", "when", "where", "whitespace", "window", "with", "within", "without", "work", "wrapper", "write", "xml", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable", "year", "yes", "zone"] - -{-# NOINLINE unreservedKeyword #-} -unreservedKeyword :: HashSet Text -unreservedKeyword = fromList ["abort", "absolute", "access", "action", "add", "admin", "after", "aggregate", "also", "alter", "always", "assertion", "assignment", "at", "attach", "attribute", "backward", "before", "begin", "by", "cache", "call", "called", "cascade", "cascaded", "catalog", "chain", "characteristics", "checkpoint", "class", "close", "cluster", "columns", "comment", "comments", "commit", "committed", "configuration", "conflict", "connection", "constraints", "content", "continue", "conversion", "copy", "cost", "csv", "cube", "current", "cursor", "cycle", "data", "database", "day", "deallocate", "declare", "defaults", "deferred", "definer", "delete", "delimiter", "delimiters", "depends", "detach", "dictionary", "disable", "discard", "document", "domain", "double", "drop", "each", "enable", "encoding", "encrypted", "enum", "escape", "event", "exclude", "excluding", "exclusive", "execute", "explain", "extension", "external", "family", "filter", "first", "following", "force", "forward", "function", "functions", "generated", "global", "granted", "groups", "handler", "header", "hold", "hour", "identity", "if", "immediate", "immutable", "implicit", "import", "include", "including", "increment", "index", "indexes", "inherit", "inherits", "inline", "input", "insensitive", "insert", "instead", "invoker", "isolation", "key", "label", "language", "large", "last", "leakproof", "level", "listen", "load", "local", "location", "lock", "locked", "logged", "mapping", "match", "materialized", "maxvalue", "method", "minute", "minvalue", "mode", "month", "move", "name", "names", "new", "next", "no", "nothing", "notify", "nowait", "nulls", "object", "of", "off", "oids", "old", "operator", "option", "options", "ordinality", "others", "over", "overriding", "owned", "owner", "parallel", "parser", "partial", "partition", "passing", "password", "plans", "policy", "preceding", "prepare", "prepared", "preserve", "prior", "privileges", "procedural", "procedure", "procedures", "program", "publication", "quote", "range", "read", "reassign", "recheck", "recursive", "ref", "referencing", "refresh", "reindex", "relative", "release", "rename", "repeatable", "replace", "replica", "reset", "restart", "restrict", "returns", "revoke", "role", "rollback", "rollup", "routine", "routines", "rows", "rule", "savepoint", "schema", "schemas", "scroll", "search", "second", "security", "sequence", "sequences", "serializable", "server", "session", "set", "sets", "share", "show", "simple", "skip", "snapshot", "sql", "stable", "standalone", "start", "statement", "statistics", "stdin", "stdout", "storage", "stored", "strict", "strip", "subscription", "support", "sysid", "system", "tables", "tablespace", "temp", "template", "temporary", "text", "ties", "transaction", "transform", "trigger", "truncate", "trusted", "type", "types", "unbounded", "uncommitted", "unencrypted", "unknown", "unlisten", "unlogged", "until", "update", "vacuum", "valid", "validate", "validator", "value", "varying", "version", "view", "views", "volatile", "whitespace", "within", "without", "work", "wrapper", "write", "xml", "year", "yes", "zone"] - -{-# NOINLINE colNameKeyword #-} -colNameKeyword :: HashSet Text -colNameKeyword = fromList ["between", "bigint", "bit", "boolean", "char", "character", "coalesce", "dec", "decimal", "exists", "extract", "float", "greatest", "grouping", "inout", "int", "integer", "interval", "least", "national", "nchar", "none", "normalize", "nullif", "numeric", "out", "overlay", "position", "precision", "real", "row", "setof", "smallint", "substring", "time", "timestamp", "treat", "trim", "values", "varchar", "xmlattributes", "xmlconcat", "xmlelement", "xmlexists", "xmlforest", "xmlnamespaces", "xmlparse", "xmlpi", "xmlroot", "xmlserialize", "xmltable"] - -{-# NOINLINE typeFuncNameKeyword #-} -typeFuncNameKeyword :: HashSet Text -typeFuncNameKeyword = fromList ["authorization", "binary", "collation", "concurrently", "cross", "current_schema", "freeze", "full", "ilike", "inner", "is", "isnull", "join", "left", "like", "natural", "notnull", "outer", "overlaps", "right", "similar", "tablesample", "verbose"] - -{-# NOINLINE reservedKeyword #-} -reservedKeyword :: HashSet Text -reservedKeyword = fromList ["all", "analyse", "analyze", "and", "any", "array", "as", "asc", "asymmetric", "both", "case", "cast", "check", "collate", "column", "constraint", "create", "current_catalog", "current_date", "current_role", "current_time", "current_timestamp", "current_user", "default", "deferrable", "desc", "distinct", "do", "else", "end", "except", "false", "fetch", "for", "foreign", "from", "grant", "group", "having", "in", "initially", "intersect", "into", "lateral", "leading", "limit", "localtime", "localtimestamp", "not", "null", "offset", "on", "only", "or", "order", "placing", "primary", "references", "returning", "select", "session_user", "some", "symmetric", "table", "then", "to", "trailing", "true", "union", "unique", "user", "using", "variadic", "when", "where", "window", "with"] - -{-# NOINLINE symbolicBinOp #-} -symbolicBinOp :: HashSet Text -symbolicBinOp = fromList ["+", "-", "*", "/", "%", "^", "<", ">", "=", "<=", ">=", "<>", "~~", "~~*", "!~~", "!~~*", "~", "~*", "!~", "!~*"] - -{-# NOINLINE lexicalBinOp #-} -lexicalBinOp :: HashSet Text -lexicalBinOp = fromList ["and", "or"] - -{-# NOINLINE colId #-} -colId :: HashSet Text -colId = unions [unreservedKeyword, colNameKeyword] - -{- -type_function_name: - | IDENT - | unreserved_keyword - | type_func_name_keyword --} -{-# NOINLINE typeFunctionName #-} -typeFunctionName :: HashSet Text -typeFunctionName = unions [unreservedKeyword, typeFuncNameKeyword] - --- | --- As per the following comment from the original scanner definition: --- --- /* --- * Likewise, if what we have left is two chars, and --- * those match the tokens ">=", "<=", "=>", "<>" or --- * "!=", then we must return the appropriate token --- * rather than the generic Op. --- */ -{-# NOINLINE nonOp #-} -nonOp :: HashSet Text -nonOp = fromList [">=", "<=", "=>", "<>", "!="] <> mathOp - -{-# NOINLINE mathOp #-} -mathOp :: HashSet Text -mathOp = fromList ["<>", ">=", "!=", "<=", "+", "-", "*", "/", "%", "^", "<", ">", "="] diff --git a/library/PostgresqlSyntax/Parsing.hs b/library/PostgresqlSyntax/Parsing.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Parsing.hs +++ /dev/null @@ -1,2290 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-missing-signatures -Wno-dodgy-imports #-} - --- | --- --- Our parsing strategy is to port the original Postgres parser as closely as possible. --- --- We're using the @gram.y@ Postgres source file, which is the closest thing we have --- to a Postgres syntax spec. Here's a link to it: --- https://github.com/postgres/postgres/blob/master/src/backend/parser/gram.y. --- --- Here's the essence of how the original parser is implemented, citing from --- [PostgreSQL Wiki](https://wiki.postgresql.org/wiki/Developer_FAQ): --- --- scan.l defines the lexer, i.e. the algorithm that splits a string --- (containing an SQL statement) into a stream of tokens. --- A token is usually a single word --- (i.e., doesn't contain spaces but is delimited by spaces), --- but can also be a whole single or double-quoted string for example. --- The lexer is basically defined in terms of regular expressions --- which describe the different token types. --- --- gram.y defines the grammar (the syntactical structure) of SQL statements, --- using the tokens generated by the lexer as basic building blocks. --- The grammar is defined in BNF notation. --- BNF resembles regular expressions but works on the level of tokens, not characters. --- Also, patterns (called rules or productions in BNF) are named, and may be recursive, --- i.e. use themselves as sub-patterns. -module PostgresqlSyntax.Parsing where - -import Control.Applicative.Combinators hiding (some) -import Control.Applicative.Combinators.NonEmpty -import qualified Data.HashSet as HashSet -import qualified Data.Text as Text -import HeadedMegaparsec hiding (string) -import PostgresqlSyntax.Ast -import PostgresqlSyntax.Extras.HeadedMegaparsec hiding (run) -import qualified PostgresqlSyntax.Extras.HeadedMegaparsec as Extras -import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty -import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import qualified PostgresqlSyntax.Predicate as Predicate -import PostgresqlSyntax.Prelude hiding (bit, expr, filter, fromList, head, many, option, some, sortBy, tail, try) -import qualified PostgresqlSyntax.Validation as Validation -import qualified Text.Megaparsec as Megaparsec -import qualified Text.Megaparsec.Char as MegaparsecChar -import qualified TextBuilder - --- $setup --- >>> testParser parser = either putStr print . run parser - -type Parser = HeadedParsec Void Text - --- * Executors - -run :: Parser a -> Text -> Either String a -run = Extras.run - -runWithPosError :: Parser a -> Text -> Either (NonEmpty (Int, String)) a -runWithPosError = Extras.runParserWithErrorPos - --- * Helpers - -inSpace :: Parser a -> Parser a -inSpace p = space *> p <* space - -commaSeparator :: Parser () -commaSeparator = space *> char ',' *> endHead *> space - -dotSeparator :: Parser () -dotSeparator = space *> char '.' *> endHead *> space - -inBrackets :: Parser a -> Parser a -inBrackets p = char '[' *> space *> p <* endHead <* space <* char ']' - -inBracketsCont :: Parser a -> Parser (Parser a) -inBracketsCont p = char '[' *> endHead *> pure (space *> p <* endHead <* space <* char ']') - -inParens :: Parser a -> Parser a -inParens p = char '(' *> space *> p <* endHead <* space <* char ')' - -inParensCont :: Parser a -> Parser (Parser a) -inParensCont p = char '(' *> endHead *> pure (space *> p <* endHead <* space <* char ')') - -inParensWithLabel :: (label -> content -> result) -> Parser label -> Parser content -> Parser result -inParensWithLabel result labelParser contentParser = do - label <- wrapToHead labelParser - space - char '(' - endHead - space - content <- contentParser - space - char ')' - pure (result label content) - -inParensWithClause :: Parser clause -> Parser content -> Parser content -inParensWithClause = inParensWithLabel (const id) - -trueIfPresent :: Parser a -> Parser Bool -trueIfPresent p = option False (True <$ p) - --- | --- >>> testParser (quotedString '\'') "'abc''d'" --- "abc'd" -quotedString :: Char -> Parser Text -quotedString q = do - char q - endHead - tail <- - parse - $ let collectChunks !bdr = do - chunk <- Megaparsec.takeWhileP Nothing (/= q) - let bdr' = bdr <> TextBuilder.text chunk - Megaparsec.try (consumeEscapedQuote bdr') <|> finish bdr' - consumeEscapedQuote bdr = do - MegaparsecChar.char q - MegaparsecChar.char q - collectChunks (bdr <> TextBuilder.char q) - finish bdr = do - MegaparsecChar.char q - return (TextBuilder.toText bdr) - in collectChunks mempty - return tail - --- | --- >>> testParser dollarQuotedSconst "$$it's good$$" --- "it's good" -dollarQuotedSconst :: Parser Text -dollarQuotedSconst = do - char '$' - quoteTag <- takeWhileP Nothing (/= '$') - let terminator = Megaparsec.chunk $ "$" <> quoteTag <> "$" - char '$' - endHead - tail <- - parse $ do - body <- many $ Megaparsec.notFollowedBy terminator *> Megaparsec.anySingle - terminator - return $ Text.pack body - return tail - -atEnd :: Parser a -> Parser a -atEnd p = space *> p <* endHead <* space <* eof - --- * PreparableStmt - -preparableStmt = - asum - [ SelectPreparableStmt <$> selectStmt, - InsertPreparableStmt <$> insertStmt, - UpdatePreparableStmt <$> updateStmt, - DeletePreparableStmt <$> deleteStmt, - CallPreparableStmt <$> callStmt - ] - --- * Call - -callStmt = do - keyword "call" - space1 - CallStmt <$> funcApplication - --- * Insert - -insertStmt = do - a <- optional (wrapToHead withClause <* space1) - keyword "insert" - space1 - endHead - keyword "into" - space1 - b <- insertTarget - space1 - c <- insertRest - d <- optional (space1 *> onConflict) - e <- optional (space1 *> returningClause) - return (InsertStmt a b c d e) - -insertTarget = do - a <- qualifiedName - endHead - b <- optional (space1 *> keyword "as" *> space1 *> endHead *> colId) - return (InsertTarget a b) - -insertRest = - asum - [ DefaultValuesInsertRest <$ (keyword "default" *> space1 *> endHead *> keyword "values"), - do - a <- optional (inParens insertColumnList <* space1) - b <- optional $ do - keyword "overriding" - space1 - endHead - b <- overrideKind - space1 - keyword "value" - space1 - return b - c <- selectStmt - return (SelectInsertRest a b c) - ] - -overrideKind = - asum - [ UserOverrideKind <$ keyword "user", - SystemOverrideKind <$ keyword "system" - ] - -insertColumnList = sep1 commaSeparator insertColumnItem - -insertColumnItem = do - a <- colId - endHead - b <- optional (space1 *> indirection) - return (InsertColumnItem a b) - -onConflict = do - keyword "on" - space1 - keyword "conflict" - space1 - endHead - a <- optional (confExpr <* space1) - keyword "do" - space1 - b <- onConflictDo - return (OnConflict a b) - -confExpr = - asum - [ WhereConfExpr <$> inParens indexParams <*> optional (space *> whereClause), - ConstraintConfExpr <$> (keyword "on" *> space1 *> keyword "constraint" *> space1 *> endHead *> name) - ] - -onConflictDo = - asum - [ NothingOnConflictDo <$ keyword "nothing", - do - keyword "update" - space1 - endHead - keyword "set" - space1 - a <- setClauseList - b <- optional (space1 *> whereClause) - return (UpdateOnConflictDo a b) - ] - -returningClause = do - keyword "returning" - space1 - endHead - targetList - --- * Update - -updateStmt = do - a <- optional (wrapToHead withClause <* space1) - keyword "update" - space1 - endHead - b <- relationExprOptAlias ["set"] - space1 - keyword "set" - space1 - c <- setClauseList - d <- optional (space1 *> fromClause) - e <- optional (space1 *> whereOrCurrentClause) - f <- optional (space1 *> returningClause) - return (UpdateStmt a b c d e f) - -setClauseList = sep1 commaSeparator setClause - -setClause = - asum - [ do - a <- inParens setTargetList - space - char '=' - space - b <- aExpr - return (TargetListSetClause a b), - do - a <- setTarget - space - char '=' - space - b <- aExpr - return (TargetSetClause a b) - ] - -setTarget = do - a <- colId - endHead - b <- optional (space1 *> indirection) - return (SetTarget a b) - -setTargetList = sep1 commaSeparator setTarget - --- * Delete - -deleteStmt = do - a <- optional (wrapToHead withClause <* space1) - keyword "delete" - space1 - endHead - keyword "from" - space1 - b <- relationExprOptAlias ["using", "where", "returning"] - c <- optional (space1 *> usingClause) - d <- optional (space1 *> whereOrCurrentClause) - e <- optional (space1 *> returningClause) - return (DeleteStmt a b c d e) - -usingClause = do - keyword "using" - space1 - fromList - --- * Select - --- | --- >>> test = testParser selectStmt --- --- >>> test "select id from as" --- ... --- | --- 1 | select id from as --- | ^ --- 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 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 - --- | --- '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) - where - limitFirst = do - limit <- space1 *> selectLimit - forLocking <- optional (space1 *> forLockingClause) - pure (Just limit, forLocking) - forLockingFirst = do - forLocking <- space1 *> forLockingClause - limit <- optional (space1 *> selectLimit) - pure (limit, Just forLocking) - --- | --- The one that doesn't start with \"WITH\". --- --- ==== References --- @ --- | simple_select --- | select_clause sort_clause --- | select_clause opt_sort_clause for_locking_clause opt_select_limit --- | select_clause opt_sort_clause select_limit opt_for_locking_clause --- @ -simpleSelectNoParens = sharedSelectNoParens Nothing - -withSelectNoParens = do - with <- wrapToHead withClause - space1 - sharedSelectNoParens (Just with) - -selectClause = selectClauseBase >>= extendMany selectClauseSuffix - -selectClauseBase = - asum - [ Right <$> selectWithParens, - Left <$> baseSimpleSelect - ] - -selectClauseSuffix a = Left <$> extensionSimpleSelect a - -baseSimpleSelect = - asum - [ do - keyword "select" - notFollowedBy $ satisfy $ isAlphaNum - endHead - targeting <- optional (space1 *> targeting) - intoClause <- optional (space1 *> keyword "into" *> endHead *> space1 *> optTempTableName) - fromClause <- optional (space1 *> fromClause) - whereClause <- optional (space1 *> whereClause) - groupClause <- optional (space1 *> keyphrase "group by" *> endHead *> space1 *> sep1 commaSeparator groupByItem) - havingClause <- optional (space1 *> keyword "having" *> endHead *> space1 *> aExpr) - windowClause <- optional (space1 *> keyword "window" *> endHead *> space1 *> sep1 commaSeparator windowDefinition) - return (NormalSimpleSelect targeting intoClause fromClause whereClause groupClause havingClause windowClause), - do - keyword "table" - space1 - endHead - TableSimpleSelect <$> relationExpr, - ValuesSimpleSelect <$> valuesClause - ] - -extensionSimpleSelect headSelectClause = do - op <- space1 *> selectBinOp <* space1 - endHead - allOrDistinct <- optional (allOrDistinct <* space1) - selectClause <- selectClause - return (BinSimpleSelect op headSelectClause allOrDistinct selectClause) - -allOrDistinct = keyword "all" $> False <|> keyword "distinct" $> True - -selectBinOp = - asum - [ keyword "union" $> UnionSelectBinOp, - keyword "intersect" $> IntersectSelectBinOp, - keyword "except" $> ExceptSelectBinOp - ] - -valuesClause = do - keyword "values" - space - sep1 commaSeparator $ do - char '(' - endHead - space - a <- sep1 commaSeparator aExpr - space - char ')' - return a - -withClause = label "with clause" $ do - keyword "with" - space1 - endHead - recursive <- option False (True <$ keyword "recursive" <* space1) - cteList <- sep1 commaSeparator commonTableExpr - return (WithClause recursive cteList) - -commonTableExpr = label "common table expression" $ do - name <- colId <* space <* endHead - nameList <- optional (inParens (sep1 commaSeparator colId) <* space1) - keyword "as" - space1 - materialized <- optional (materialized <* space1) - stmt <- inParens preparableStmt - return (CommonTableExpr name nameList materialized stmt) - -materialized = - True <$ keyword "materialized" - <|> False <$ keyphrase "not materialized" - -targeting = distinct <|> allWithTargetList <|> all <|> normal - where - normal = NormalTargeting <$> targetList - allWithTargetList = do - keyword "all" - space1 - AllTargeting <$> Just <$> targetList - all = keyword "all" $> AllTargeting Nothing - distinct = do - keyword "distinct" - space1 - endHead - optOn <- optional (onExpressionsClause <* space1) - targetList <- targetList - return (DistinctTargeting optOn targetList) - -targetList = sep1 commaSeparator targetEl - --- | --- >>> testParser targetEl "a.b as c" --- AliasedExprTargetEl (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") (Just (AttrNameIndirectionEl (UnquotedIdent "b") :| []))))) (UnquotedIdent "c") -targetEl = - label "target" - $ asum - [ do - expr <- aExpr - asum - [ do - space1 - asum - [ AliasedExprTargetEl expr <$> (keyword "as" *> space1 *> endHead *> colLabel), - ImplicitlyAliasedExprTargetEl expr <$> ident - ], - pure (ExprTargetEl expr) - ], - AsteriskTargetEl <$ char '*' - ] - -onExpressionsClause = do - keyword "on" - space1 - endHead - inParens (sep1 commaSeparator aExpr) - --- * Into clause details - --- | --- ==== References --- @ --- OptTempTableName: --- | TEMPORARY opt_table qualified_name --- | TEMP opt_table qualified_name --- | LOCAL TEMPORARY opt_table qualified_name --- | LOCAL TEMP opt_table qualified_name --- | GLOBAL TEMPORARY opt_table qualified_name --- | GLOBAL TEMP opt_table qualified_name --- | UNLOGGED opt_table qualified_name --- | TABLE qualified_name --- | qualified_name --- @ -optTempTableName = - asum - [ do - a <- - asum - [ TemporaryOptTempTableName <$ keyword "temporary" <* space1, - TempOptTempTableName <$ keyword "temp" <* space1, - LocalTemporaryOptTempTableName <$ keyphrase "local temporary" <* space1, - LocalTempOptTempTableName <$ keyphrase "local temp" <* space1, - GlobalTemporaryOptTempTableName <$ keyphrase "global temporary" <* space1, - GlobalTempOptTempTableName <$ keyphrase "global temp" <* space1, - UnloggedOptTempTableName <$ keyword "unlogged" <* space1 - ] - b <- option False (True <$ keyword "table" <* space1) - c <- qualifiedName - return (a b c), - do - keyword "table" - space1 - endHead - TableOptTempTableName <$> qualifiedName, - QualifedOptTempTableName <$> qualifiedName - ] - --- * Group by details - -groupByItem = - asum - [ EmptyGroupingSetGroupByItem <$ (char '(' *> space *> char ')'), - RollupGroupByItem <$> (keyword "rollup" *> endHead *> space *> inParens (sep1 commaSeparator aExpr)), - CubeGroupByItem <$> (keyword "cube" *> endHead *> space *> inParens (sep1 commaSeparator aExpr)), - GroupingSetsGroupByItem <$> (keyphrase "grouping sets" *> endHead *> space *> inParens (sep1 commaSeparator groupByItem)), - ExprGroupByItem <$> aExpr - ] - --- * Window clause details - -windowDefinition = WindowDefinition <$> (colId <* space1 <* keyword "as" <* space1 <* endHead) <*> windowSpecification - --- | --- ==== References --- @ --- window_specification: --- | '(' opt_existing_window_name opt_partition_clause --- opt_sort_clause opt_frame_clause ')' --- @ -windowSpecification = - inParens - $ asum - [ do - a <- frameClause - return (WindowSpecification Nothing Nothing Nothing (Just a)), - do - a <- sortClause - b <- optional (space1 *> frameClause) - return (WindowSpecification Nothing Nothing (Just a) b), - do - a <- partitionByClause - b <- optional (space1 *> sortClause) - c <- optional (space1 *> frameClause) - return (WindowSpecification Nothing (Just a) b c), - do - a <- colId - b <- optional (space1 *> partitionByClause) - c <- optional (space1 *> sortClause) - d <- optional (space1 *> frameClause) - return (WindowSpecification (Just a) b c d), - pure (WindowSpecification Nothing Nothing Nothing Nothing) - ] - -partitionByClause = keyphrase "partition by" *> space1 *> endHead *> sep1 commaSeparator aExpr - --- | --- ==== References --- @ --- opt_frame_clause: --- | RANGE frame_extent opt_window_exclusion_clause --- | ROWS frame_extent opt_window_exclusion_clause --- | GROUPS frame_extent opt_window_exclusion_clause --- | EMPTY --- @ -frameClause = do - a <- frameClauseMode <* space1 <* endHead - b <- frameExtent - c <- optional (space1 *> windowExclusionClause) - return (FrameClause a b c) - -frameClauseMode = - asum - [ RangeFrameClauseMode <$ keyword "range", - RowsFrameClauseMode <$ keyword "rows", - GroupsFrameClauseMode <$ keyword "groups" - ] - -frameExtent = - BetweenFrameExtent <$> (keyword "between" *> space1 *> endHead *> frameBound <* space1 <* keyword "and" <* space1) <*> frameBound - <|> SingularFrameExtent <$> frameBound - --- | --- ==== References --- @ --- | UNBOUNDED PRECEDING --- | UNBOUNDED FOLLOWING --- | CURRENT_P ROW --- | a_expr PRECEDING --- | a_expr FOLLOWING --- @ -frameBound = - UnboundedPrecedingFrameBound <$ keyphrase "unbounded preceding" - <|> UnboundedFollowingFrameBound <$ keyphrase "unbounded following" - <|> CurrentRowFrameBound <$ keyphrase "current row" - <|> do - a <- aExpr - space1 - PrecedingFrameBound a <$ keyword "preceding" <|> FollowingFrameBound a <$ keyword "following" - -windowExclusionClause = - CurrentRowWindowExclusionClause <$ keyphrase "exclude current row" - <|> GroupWindowExclusionClause <$ keyphrase "exclude group" - <|> TiesWindowExclusionClause <$ keyphrase "exclude ties" - <|> NoOthersWindowExclusionClause <$ keyphrase "exclude no others" - --- * Table refs - -fromList = sep1 commaSeparator tableRef - -fromClause = keyword "from" *> endHead *> space1 *> fromList - --- | --- >>> testParser tableRef "a left join b on (a.i = b.i)" --- JoinTableRef (MethJoinedTable (QualJoinMeth... -tableRef = - label "table reference" - $ do - tr <- nonTrailingTableRef - recur tr - where - recur tr = - asum - [ do - tr2 <- wrapToHead (space1 *> trailingTableRef tr) - endHead - recur tr2, - pure tr - ] - -nonTrailingTableRef = - asum - [ lateralTableRef - <|> wrapToHead nonLateralTableRef - <|> relationExprTableRef - <|> joinedTableWithAliasTableRef - <|> inParensJoinedTableTableRef - ] - where - relationExprTableRef = do - relationExpr <- relationExpr - endHead - optAliasClause <- optional (space1 *> aliasClause) - optTablesampleClause <- optional (space1 *> tablesampleClause) - return (RelationExprTableRef relationExpr optAliasClause optTablesampleClause) - - lateralTableRef = do - keyword "lateral" - space1 - endHead - lateralableTableRef True - - nonLateralTableRef = lateralableTableRef False - - lateralableTableRef lateral = - asum - [ do - a <- funcTable - b <- optional (space1 *> funcAliasClause) - return (FuncTableRef lateral a b), - do - select <- selectWithParens - optAliasClause <- optional $ space1 *> aliasClause - return (SelectTableRef lateral select optAliasClause) - ] - - inParensJoinedTableTableRef = JoinTableRef <$> inParensJoinedTable <*> pure Nothing - - joinedTableWithAliasTableRef = do - joinedTable <- wrapToHead (inParens joinedTable) - space1 - alias <- aliasClause - return (JoinTableRef joinedTable (Just alias)) - -trailingTableRef tableRef = - JoinTableRef <$> trailingJoinedTable tableRef <*> pure Nothing - -relationExpr = - label "relation expression" - $ asum - [ do - keyword "only" - space1 - name <- qualifiedName - return (OnlyRelationExpr name False), - inParensWithClause (keyword "only") qualifiedName <&> \a -> OnlyRelationExpr a True, - do - name <- qualifiedName - asterisk <- - asum - [ True <$ (space1 *> char '*'), - pure False - ] - return (SimpleRelationExpr name asterisk) - ] - -relationExprOptAlias reservedKeywords = do - a <- relationExpr - b <- optional $ do - space1 - b <- trueIfPresent (keyword "as" *> space1) - c <- filteredColId reservedKeywords - return (b, c) - return (RelationExprOptAlias a b) - -tablesampleClause = do - keyword "tablesample" - space1 - endHead - a <- funcName - space - b <- inParens exprList - c <- optional (space *> repeatableClause) - return (TablesampleClause a b c) - -repeatableClause = do - keyword "repeatable" - space - inParens (endHead *> aExpr) - -funcTable = - asum - [ do - keyword "rows" - space1 - keyword "from" - space - a <- inParens (endHead *> rowsfromList) - b <- trueIfPresent (space *> optOrdinality) - return (RowsFromFuncTable a b), - do - a <- funcExprWindowless - b <- trueIfPresent (space1 *> optOrdinality) - return (FuncExprFuncTable a b) - ] - -rowsfromItem = do - a <- funcExprWindowless - endHead - b <- optional (space1 *> colDefList) - return (RowsfromItem a b) - -rowsfromList = sep1 commaSeparator rowsfromItem - -colDefList = keyword "as" *> space *> inParens (endHead *> tableFuncElementList) - -optOrdinality = keyword "with" *> space1 *> keyword "ordinality" - -tableFuncElementList = sep1 commaSeparator tableFuncElement - -tableFuncElement = do - a <- wrapToHead colId - space1 - b <- typename - c <- optional (space1 *> collateClause) - return (TableFuncElement a b c) - -collateClause = keyword "collate" *> space1 *> endHead *> anyName - -funcAliasClause = - asum - [ do - _ <- keyword "as" - asum - [ do - space - inParens $ do - endHead - AsFuncAliasClause <$> tableFuncElementList, - do - space1 - a <- colId - asum - [ do - space - inParens $ do - endHead - asum - [ AsColIdFuncAliasClause a <$> wrapToHead tableFuncElementList, - AliasFuncAliasClause <$> AliasClause True a <$> Just <$> nameList - ], - pure (AliasFuncAliasClause (AliasClause True a Nothing)) - ] - ], - do - a <- colId - asum - [ do - space - inParens $ do - endHead - asum - [ ColIdFuncAliasClause a <$> wrapToHead tableFuncElementList, - AliasFuncAliasClause <$> AliasClause False a <$> Just <$> nameList - ], - pure (AliasFuncAliasClause (AliasClause False a Nothing)) - ] - ] - -joinedTable = - head >>= tail - where - head = - asum - [ do - tr <- wrapToHead nonTrailingTableRef - space1 - trailingJoinedTable tr, - inParensJoinedTable - ] - tail jt = - asum - [ do - jt2 <- wrapToHead (space1 *> trailingJoinedTable (JoinTableRef jt Nothing)) - endHead - tail jt2, - pure jt - ] - --- | --- ==== References --- @ --- | '(' joined_table ')' --- @ -inParensJoinedTable = InParensJoinedTable <$> inParens joinedTable - --- | --- ==== References --- @ --- | table_ref CROSS JOIN table_ref --- | table_ref join_type JOIN table_ref join_qual --- | table_ref JOIN table_ref join_qual --- | table_ref NATURAL join_type JOIN table_ref --- | table_ref NATURAL JOIN table_ref --- @ -trailingJoinedTable tr1 = - asum - [ do - keyphrase "cross join" - endHead - space1 - tr2 <- nonTrailingTableRef - return (MethJoinedTable CrossJoinMeth tr1 tr2), - do - jt <- joinTypedJoin - endHead - space1 - tr2 <- tableRef - space1 - jq <- joinQual - return (MethJoinedTable (QualJoinMeth jt jq) tr1 tr2), - do - keyword "natural" - endHead - space1 - jt <- joinTypedJoin - space1 - tr2 <- nonTrailingTableRef - return (MethJoinedTable (NaturalJoinMeth jt) tr1 tr2) - ] - where - joinTypedJoin = - Just <$> (joinType <* endHead <* space1 <* keyword "join") - <|> Nothing <$ keyword "join" - -joinType = - asum - [ do - keyword "full" - endHead - outer <- outerAfterSpace - return (FullJoinType outer), - do - keyword "left" - endHead - outer <- outerAfterSpace - return (LeftJoinType outer), - do - keyword "right" - endHead - outer <- outerAfterSpace - return (RightJoinType outer), - keyword "inner" $> InnerJoinType - ] - where - outerAfterSpace = (space1 *> keyword "outer") $> True <|> pure False - -joinQual = - asum - [ keyword "using" *> space1 *> inParens (sep1 commaSeparator colId) <&> UsingJoinQual, - keyword "on" *> space1 *> aExpr <&> OnJoinQual - ] - -aliasClause = do - (as, alias) <- (True,) <$> (keyword "as" *> space1 *> endHead *> colId) <|> (False,) <$> colId - columnAliases <- optional (space1 *> inParens (sep1 commaSeparator colId)) - return (AliasClause as alias columnAliases) - --- * Where - -whereClause = keyword "where" *> space1 *> endHead *> aExpr - -whereOrCurrentClause = do - keyword "where" - space1 - endHead - asum - [ do - keyword "current" - space1 - keyword "of" - space1 - endHead - a <- cursorName - return (CursorWhereOrCurrentClause a), - ExprWhereOrCurrentClause <$> aExpr - ] - --- * Sorting - -sortClause = do - keyphrase "order by" - endHead - space1 - a <- sep1 commaSeparator sortBy - return a - -sortBy = do - a <- filteredAExpr ["using", "asc", "desc", "nulls"] - asum - [ do - space1 - keyword "using" - space1 - endHead - b <- qualAllOp - c <- optional (space1 *> nullsOrder) - return (UsingSortBy a b c), - do - b <- optional (space1 *> ascDesc) - c <- optional (space1 *> nullsOrder) - return (AscDescSortBy a b c) - ] - --- * Expressions - -exprList = sep1 commaSeparator aExpr - -exprListInParens = inParens exprList - --- | --- Notice that the tree constructed by this parser does not reflect --- the precedence order of Postgres. --- For the purposes of this library it simply doesn't matter, --- so we're not bothering with that. --- --- ==== Composite on the right: --- --- >>> testParser aExpr "a = b :: int4" --- SymbolicBinOpAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing))) (MathSymbolicExprBinOp EqualsMathOp) (TypecastAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing))) (Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing)) --- --- ==== Composite on the left: --- --- >>> testParser aExpr "a = b :: int4 and c" --- SymbolicBinOpAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "a") Nothing))) (MathSymbolicExprBinOp EqualsMathOp) (AndAExpr (TypecastAExpr (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "b") Nothing))) (Typename False (GenericTypeSimpleTypename (GenericType (UnquotedIdent "int4") Nothing Nothing)) False Nothing)) (CExprAExpr (ColumnrefCExpr (Columnref (UnquotedIdent "c") Nothing)))) -aExpr = customizedAExpr cExpr - -filteredAExpr = customizedAExpr . customizedCExpr . filteredColumnref - -customizedAExpr cExpr = suffixRec base suffix - where - aExpr = customizedAExpr cExpr - base = - asum - [ DefaultAExpr <$ keyword "default", - UniqueAExpr <$> (keyword "unique" *> space1 *> selectWithParens), - qualOpExpr aExpr PrefixQualOpAExpr, - PlusAExpr <$> plusedExpr aExpr, - MinusAExpr <$> minusedExpr aExpr, - NotAExpr <$> (keyword "not" *> space1 *> aExpr), - CExprAExpr <$> cExpr - ] - suffix a = - asum - [ overlapsSuffix a, - do - space1 - b <- wrapToHead subqueryOp - space1 - c <- wrapToHead subType - space - d <- Left <$> wrapToHead selectWithParens <|> Right <$> inParens aExpr - return (SubqueryAExpr a b c d), - typecastExpr a TypecastAExpr, - CollateAExpr a <$> (space1 *> keyword "collate" *> space1 *> endHead *> anyName), - AtTimeZoneAExpr a <$> (space1 *> keyphrase "at time zone" *> space1 *> endHead *> aExpr), - symbolicBinOpExpr a aExpr SymbolicBinOpAExpr, - SuffixQualOpAExpr a <$> (space *> qualOp), - AndAExpr a <$> (space1 *> keyword "and" *> space1 *> endHead *> aExpr), - OrAExpr a <$> (space1 *> keyword "or" *> space1 *> endHead *> aExpr), - do - space1 - b <- trueIfPresent (keyword "not" *> space1) - c <- - asum - [ LikeVerbalExprBinOp <$ keyword "like", - IlikeVerbalExprBinOp <$ keyword "ilike", - SimilarToVerbalExprBinOp <$ keyphrase "similar to" - ] - space1 - endHead - d <- aExpr - e <- optional (space1 *> keyword "escape" *> space1 *> endHead *> aExpr) - return (VerbalExprBinOpAExpr a b c d e), - do - space1 - keyword "is" - space1 - endHead - b <- trueIfPresent (keyword "not" *> space1) - c <- - asum - [ NullAExprReversableOp <$ keyword "null", - TrueAExprReversableOp <$ keyword "true", - FalseAExprReversableOp <$ keyword "false", - UnknownAExprReversableOp <$ keyword "unknown", - DistinctFromAExprReversableOp <$> (keyword "distinct" *> space1 *> keyword "from" *> space1 *> endHead *> aExpr), - OfAExprReversableOp <$> (keyword "of" *> space1 *> endHead *> inParens typeList), - DocumentAExprReversableOp <$ keyword "document" - ] - return (ReversableOpAExpr a b c), - do - space1 - b <- trueIfPresent (keyword "not" *> space1) - keyword "between" - space1 - endHead - c <- - asum - [ BetweenSymmetricAExprReversableOp <$ (keyword "symmetric" *> space1), - BetweenAExprReversableOp True <$ (keyword "asymmetric" *> space1), - pure (BetweenAExprReversableOp False) - ] - d <- bExpr - space1 - keyword "and" - space1 - e <- aExpr - return (ReversableOpAExpr a b (c d e)), - do - space1 - b <- trueIfPresent (keyword "not" *> space1) - keyword "in" - space - c <- InAExprReversableOp <$> inExpr - return (ReversableOpAExpr a b c), - IsnullAExpr a <$ (space1 *> keyword "isnull"), - 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 - where - bExpr = customizedBExpr cExpr - base = - asum - [ qualOpExpr bExpr QualOpBExpr, - PlusBExpr <$> plusedExpr bExpr, - MinusBExpr <$> minusedExpr bExpr, - CExprBExpr <$> cExpr - ] - suffix a = - asum - [ typecastExpr a TypecastBExpr, - symbolicBinOpExpr a bExpr SymbolicBinOpBExpr, - do - space1 - keyword "is" - space1 - endHead - b <- trueIfPresent (keyword "not" *> space1) - c <- - asum - [ DistinctFromBExprIsOp <$> (keyphrase "distinct from" *> space1 *> endHead *> bExpr), - OfBExprIsOp <$> (keyword "of" *> space1 *> endHead *> inParens typeList), - DocumentBExprIsOp <$ keyword "document" - ] - return (IsOpBExpr a b c) - ] - -cExpr = customizedCExpr columnref - -customizedCExpr columnref = - asum - [ ParamCExpr <$> (char '$' *> decimal <* endHead) <*> optional (space *> indirection), - CaseCExpr <$> caseExpr, - ExplicitRowCExpr <$> explicitRow, - inParensWithClause (keyword "grouping") (GroupingCExpr <$> sep1 commaSeparator aExpr), - keyword "exists" *> space *> (ExistsCExpr <$> selectWithParens), - do - keyword "array" - space - join - $ asum - [ fmap (fmap (ArrayCExpr . Right)) arrayExprCont, - fmap (fmap (ArrayCExpr . Left) . pure) selectWithParens - ], - do - a <- wrapToHead selectWithParens - endHead - b <- optional (space *> indirection) - return (SelectWithParensCExpr a b), - 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 = - asum - [ AnySubqueryOp <$> (keyword "operator" *> space *> endHead *> inParens anyOperator), - do - a <- trueIfPresent (keyword "not" *> space1) - LikeSubqueryOp a <$ keyword "like" <|> IlikeSubqueryOp a <$ keyword "ilike", - AllSubqueryOp <$> allOp - ] - -subType = - asum - [ AnySubType <$ keyword "any", - SomeSubType <$ keyword "some", - AllSubType <$ keyword "all" - ] - -inExpr = - (ExprListInExpr <$> parse (Megaparsec.try (toParsec (inParens exprList)))) - <|> (SelectInExpr <$> wrapToHead selectWithParens) - -symbolicBinOpExpr a bParser constr = do - binOp <- label "binary operator" (space *> wrapToHead symbolicExprBinOp <* space) - b <- bParser - return (constr a binOp b) - -typecastExpr :: a -> (a -> Typename -> a) -> HeadedParsec Void Text a -typecastExpr prefix constr = do - space - string "::" - endHead - space - type' <- typename - return (constr prefix type') - -plusedExpr expr = char '+' *> space *> expr - -minusedExpr expr = char '-' *> space *> expr - -qualOpExpr expr constr = constr <$> wrapToHead qualOp <*> (space *> expr) - -row = ExplicitRowRow <$> explicitRow <|> ImplicitRowRow <$> implicitRow - -explicitRow = keyword "row" *> space *> inParens (optional exprList) - -implicitRow = inParens $ do - a <- wrapToHead aExpr - commaSeparator - b <- exprList - return $ case NonEmpty.consAndUnsnoc a b of - (c, d) -> ImplicitRow c d - -arrayExprCont = - inBracketsCont - $ asum - [ ArrayExprListArrayExpr <$> sep1 commaSeparator (join arrayExprCont), - ExprListArrayExpr <$> exprList, - pure EmptyArrayExpr - ] - -caseExpr = label "case expression" $ do - keyword "case" - space1 - endHead - arg <- optional (aExpr <* space1) - whenClauses <- sep1 space1 whenClause - space1 - default' <- optional elseClause - keyword "end" - pure $ CaseExpr arg whenClauses default' - -whenClause = do - keyword "when" - space1 - endHead - a <- aExpr - space1 - keyword "then" - space1 - b <- aExpr - return (WhenClause a b) - -elseClause = do - keyword "else" - space1 - endHead - a <- aExpr - space1 - return a - -funcExpr = - asum - [ SubexprFuncExpr <$> funcExprCommonSubexpr, - do - a <- funcApplication - endHead - b <- optional (space1 *> withinGroupClause) - c <- optional (space1 *> filterClause) - d <- optional (space1 *> overClause) - return (ApplicationFuncExpr a b c d) - ] - -funcExprWindowless = - asum - [ CommonSubexprFuncExprWindowless <$> funcExprCommonSubexpr, - ApplicationFuncExprWindowless <$> funcApplication - ] - -withinGroupClause = do - keyphrase "within group" - endHead - space - inParens sortClause - -filterClause = do - keyword "filter" - endHead - space - inParens (keyword "where" *> space1 *> aExpr) - -overClause = do - keyword "over" - space1 - endHead - asum - [ WindowOverClause <$> windowSpecification, - ColIdOverClause <$> colId - ] - -funcExprCommonSubexpr = - asum - [ CollationForFuncExprCommonSubexpr <$> (inParensWithClause (keyphrase "collation for") aExpr), - CurrentDateFuncExprCommonSubexpr <$ keyword "current_date", - CurrentTimestampFuncExprCommonSubexpr <$> labeledIconst "current_timestamp", - CurrentTimeFuncExprCommonSubexpr <$> labeledIconst "current_time", - LocalTimestampFuncExprCommonSubexpr <$> labeledIconst "localtimestamp", - LocalTimeFuncExprCommonSubexpr <$> labeledIconst "localtime", - CurrentRoleFuncExprCommonSubexpr <$ keyword "current_role", - CurrentUserFuncExprCommonSubexpr <$ keyword "current_user", - SessionUserFuncExprCommonSubexpr <$ keyword "session_user", - UserFuncExprCommonSubexpr <$ keyword "user", - CurrentCatalogFuncExprCommonSubexpr <$ keyword "current_catalog", - CurrentSchemaFuncExprCommonSubexpr <$ keyword "current_schema", - inParensWithClause (keyword "cast") (CastFuncExprCommonSubexpr <$> aExpr <*> (space1 *> keyword "as" *> space1 *> typename)), - inParensWithClause (keyword "extract") (ExtractFuncExprCommonSubexpr <$> optional extractList), - inParensWithClause (keyword "overlay") (OverlayFuncExprCommonSubexpr <$> overlayList), - inParensWithClause (keyword "position") (PositionFuncExprCommonSubexpr <$> optional positionList), - inParensWithClause (keyword "substring") (SubstringFuncExprCommonSubexpr <$> optional substrList), - inParensWithClause (keyword "treat") (TreatFuncExprCommonSubexpr <$> aExpr <*> (space1 *> keyword "as" *> space1 *> typename)), - inParensWithClause (keyword "trim") (TrimFuncExprCommonSubexpr <$> optional (trimModifier <* space1) <*> trimList), - inParensWithClause (keyword "nullif") (NullIfFuncExprCommonSubexpr <$> aExpr <*> (commaSeparator *> aExpr)), - inParensWithClause (keyword "coalesce") (CoalesceFuncExprCommonSubexpr <$> exprList), - inParensWithClause (keyword "greatest") (GreatestFuncExprCommonSubexpr <$> exprList), - inParensWithClause (keyword "least") (LeastFuncExprCommonSubexpr <$> exprList) - ] - where - labeledIconst label = keyword label *> endHead *> optional (space *> inParens iconst) - -extractList = ExtractList <$> extractArg <*> (space1 *> keyword "from" *> space1 *> aExpr) - -extractArg = - asum - [ YearExtractArg <$ keyword "year", - MonthExtractArg <$ keyword "month", - DayExtractArg <$ keyword "day", - HourExtractArg <$ keyword "hour", - MinuteExtractArg <$ keyword "minute", - SecondExtractArg <$ keyword "second", - SconstExtractArg <$> sconst, - IdentExtractArg <$> ident - ] - -overlayList = do - a <- aExpr - space1 - b <- overlayPlacing - space1 - c <- substrFrom - d <- optional (space1 *> substrFor) - return (OverlayList a b c d) - -overlayPlacing = keyword "placing" *> space1 *> endHead *> aExpr - -positionList = PositionList <$> bExpr <*> (space1 *> keyword "in" *> space1 *> bExpr) - -substrList = - asum - [ ExprSubstrList <$> wrapToHead aExpr <*> (space1 *> substrListFromFor), - ExprListSubstrList <$> exprList - ] - -substrListFromFor = - asum - [ do - a <- substrFrom - asum - [ do - b <- space1 *> substrFor - return (FromForSubstrListFromFor a b), - return (FromSubstrListFromFor a) - ], - do - a <- substrFor - asum - [ do - b <- space1 *> substrFrom - return (ForFromSubstrListFromFor a b), - return (ForSubstrListFromFor a) - ] - ] - -substrFrom = keyword "from" *> space1 *> endHead *> aExpr - -substrFor = keyword "for" *> space1 *> endHead *> aExpr - -trimModifier = - BothTrimModifier <$ keyword "both" - <|> LeadingTrimModifier <$ keyword "leading" - <|> TrailingTrimModifier <$ keyword "trailing" - -trimList = - asum - [ ExprFromExprListTrimList <$> wrapToHead aExpr <*> (space1 *> keyword "from" *> space1 *> endHead *> exprList), - FromExprListTrimList <$> (keyword "from" *> space1 *> endHead *> exprList), - ExprListTrimList <$> exprList - ] - --- | --- \"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 - [ starFuncApplicationParams, - listVariadicFuncApplicationParams, - singleVariadicFuncApplicationParams, - normalFuncApplicationParams - ] - -normalFuncApplicationParams = do - optAllOrDistinct <- optional (allOrDistinct <* space1) - argList <- sep1 commaSeparator funcArgExpr - endHead - optSortClause <- optional (space1 *> sortClause) - return (NormalFuncApplicationParams optAllOrDistinct argList optSortClause) - -singleVariadicFuncApplicationParams = do - keyword "variadic" - space1 - endHead - arg <- funcArgExpr - optSortClause <- optional (space1 *> sortClause) - return (VariadicFuncApplicationParams Nothing arg optSortClause) - -listVariadicFuncApplicationParams = do - (argList, _) <- wrapToHead $ sepEnd1 commaSeparator (keyword "variadic" <* space1) funcArgExpr - endHead - arg <- funcArgExpr - optSortClause <- optional (space1 *> sortClause) - return (VariadicFuncApplicationParams (Just argList) arg optSortClause) - -starFuncApplicationParams = space *> char '*' *> endHead *> space $> StarFuncApplicationParams - --- | --- ==== References --- @ --- func_arg_expr: --- | a_expr --- | param_name COLON_EQUALS a_expr --- | param_name EQUALS_GREATER a_expr --- param_name: --- | type_function_name --- @ -funcArgExpr = - asum - [ do - a <- wrapToHead typeFunctionName - space - asum - [ do - string ":=" - endHead - b <- space *> aExpr - return (ColonEqualsFuncArgExpr a b), - do - string "=>" - endHead - b <- space *> aExpr - return (EqualsGreaterFuncArgExpr a b) - ], - ExprFuncArgExpr <$> aExpr - ] - --- * Ops - -symbolicExprBinOp = - QualSymbolicExprBinOp <$> qualOp - <|> MathSymbolicExprBinOp <$> mathOp - -lexicalExprBinOp = asum $ fmap keyphrase $ ["and", "or", "is distinct from", "is not distinct from"] - -qualOp = - asum - [ OpQualOp <$> op, - OperatorQualOp <$> inParensWithClause (keyword "operator") anyOperator - ] - -qualAllOp = - asum - [ AnyQualAllOp <$> (keyword "operator" *> space *> inParens (endHead *> anyOperator)), - AllQualAllOp <$> allOp - ] - -op = do - a <- takeWhile1P Nothing Predicate.opChar - case Validation.op a of - Nothing -> return a - Just err -> fail (Text.unpack err) - -anyOperator = - asum - [ AllOpAnyOperator <$> allOp, - QualifiedAnyOperator <$> colId <*> (space *> char '.' *> space *> anyOperator) - ] - -allOp = - asum - [ OpAllOp <$> op, - MathAllOp <$> mathOp - ] - -mathOp = - asum - [ ArrowLeftArrowRightMathOp <$ string' "<>", - GreaterEqualsMathOp <$ string' ">=", - ExclamationEqualsMathOp <$ string' "!=", - LessEqualsMathOp <$ string' "<=", - PlusMathOp <$ char '+', - MinusMathOp <$ char '-', - AsteriskMathOp <$ char '*', - SlashMathOp <$ char '/', - PercentMathOp <$ char '%', - ArrowUpMathOp <$ char '^', - ArrowLeftMathOp <$ char '<', - ArrowRightMathOp <$ char '>', - EqualsMathOp <$ char '=' - ] - --- * Constants - --- | --- >>> testParser aexprConst "32948023849023" --- IAexprConst 32948023849023 --- --- >>> testParser aexprConst "'abc''de'" --- SAexprConst "abc'de" --- --- >>> testParser aexprConst "23.43234" --- FAexprConst 23.43234 --- --- >>> testParser aexprConst "32423423.324324872" --- FAexprConst 3.2423423324324872e7 --- --- >>> testParser aexprConst "NULL" --- NullAexprConst --- --- ==== References --- @ --- AexprConst: Iconst --- | FCONST --- | Sconst --- | BCONST --- | XCONST --- | func_name Sconst --- | func_name '(' func_arg_list opt_sort_clause ')' Sconst --- | ConstTypename Sconst --- | ConstInterval Sconst opt_interval --- | ConstInterval '(' Iconst ')' Sconst --- | TRUE_P --- | FALSE_P --- | NULL_P --- @ -aexprConst = - asum - [ do - keyword "interval" - space1 - endHead - a <- - asum - [ do - a <- sconst - endHead - b <- optional (space1 *> interval) - return (StringIntervalAexprConst a b), - do - a <- inParens iconst - space1 - endHead - b <- sconst - return (IntIntervalAexprConst a b) - ] - return a, - do - a <- constTypename - space1 - endHead - b <- sconst - return (ConstTypenameAexprConst a b), - BoolAexprConst True <$ keyword "true", - BoolAexprConst False <$ keyword "false", - NullAexprConst <$ keyword "null" <* parse (Megaparsec.notFollowedBy MegaparsecChar.alphaNumChar), - either IAexprConst FAexprConst <$> iconstOrFconst, - SAexprConst <$> sconst, - label "bit literal" $ do - string' "b'" - endHead - a <- takeWhile1P (Just "0 or 1") (\b -> b == '0' || b == '1') - char '\'' - return (BAexprConst a), - label "hex literal" $ do - string' "x'" - endHead - a <- takeWhile1P (Just "Hex digit") Predicate.hexDigit - char '\'' - return (XAexprConst a), - wrapToHead $ do - a <- funcName - space - char '(' - space - b <- sep1 commaSeparator funcArgExpr - c <- optional (space1 *> sortClause) - space - char ')' - space1 - d <- sconst - return (FuncAexprConst a (Just (FuncConstArgs b c)) d), - FuncAexprConst <$> (wrapToHead funcName <* space1) <*> pure Nothing <*> sconst - ] - -iconstOrFconst = Right <$> fconst <|> Left <$> iconst - -iconst = decimal - -fconst = float - -sconst = quotedString '\'' <|> dollarQuotedSconst - -constTypename = - asum - [ NumericConstTypename <$> numeric, - ConstBitConstTypename <$> constBit, - ConstCharacterConstTypename <$> constCharacter, - ConstDatetimeConstTypename <$> constDatetime - ] - -numeric = - asum - [ IntegerNumeric <$ keyword "integer", - IntNumeric <$ keyword "int", - SmallintNumeric <$ keyword "smallint", - BigintNumeric <$ keyword "bigint", - RealNumeric <$ keyword "real", - FloatNumeric <$> (keyword "float" *> endHead *> optional (space *> inParens iconst)), - DoublePrecisionNumeric <$ keyphrase "double precision", - DecimalNumeric <$> (keyword "decimal" *> endHead *> optional (space *> exprListInParens)), - DecNumeric <$> (keyword "dec" *> endHead *> optional (space *> exprListInParens)), - NumericNumeric <$> (keyword "numeric" *> endHead *> optional (space *> exprListInParens)), - BooleanNumeric <$ keyword "boolean" - ] - -bit = do - keyword "bit" - a <- option False (True <$ space1 <* keyword "varying") - b <- optional (space1 *> exprListInParens) - return (Bit a b) - -constBit = bit - -constCharacter = ConstCharacter <$> (character <* endHead) <*> optional (space *> inParens iconst) - -character = - asum - [ CharacterCharacter <$> (keyword "character" *> optVaryingAfterSpace), - CharCharacter <$> (keyword "char" *> optVaryingAfterSpace), - VarcharCharacter <$ keyword "varchar", - NationalCharacterCharacter <$> (keyphrase "national character" *> optVaryingAfterSpace), - NationalCharCharacter <$> (keyphrase "national char" *> optVaryingAfterSpace), - NcharCharacter <$> (keyword "nchar" *> optVaryingAfterSpace) - ] - where - optVaryingAfterSpace = True <$ space1 <* keyword "varying" <|> pure False - --- | --- ==== References --- @ --- ConstDatetime: --- | TIMESTAMP '(' Iconst ')' opt_timezone --- | TIMESTAMP opt_timezone --- | TIME '(' Iconst ')' opt_timezone --- | TIME opt_timezone --- @ -constDatetime = - asum - [ do - keyword "timestamp" - a <- optional (space1 *> inParens iconst) - b <- optional (space1 *> timezone) - return (TimestampConstDatetime a b), - do - keyword "time" - a <- optional (space1 *> inParens iconst) - b <- optional (space1 *> timezone) - return (TimeConstDatetime a b) - ] - -timezone = - asum - [ False <$ keyphrase "with time zone", - True <$ keyphrase "without time zone" - ] - -interval = - asum - [ YearToMonthInterval <$ keyphrase "year to month", - DayToHourInterval <$ keyphrase "day to hour", - DayToMinuteInterval <$ keyphrase "day to minute", - DayToSecondInterval <$> (keyphrase "day to" *> space1 *> endHead *> intervalSecond), - HourToMinuteInterval <$ keyphrase "hour to minute", - HourToSecondInterval <$> (keyphrase "hour to" *> space1 *> endHead *> intervalSecond), - MinuteToSecondInterval <$> (keyphrase "minute to" *> space1 *> endHead *> intervalSecond), - YearInterval <$ keyword "year", - MonthInterval <$ keyword "month", - DayInterval <$ keyword "day", - HourInterval <$ keyword "hour", - MinuteInterval <$ keyword "minute", - SecondInterval <$> intervalSecond - ] - -intervalSecond = do - keyword "second" - a <- optional (space *> inParens iconst) - return a - --- * Clauses - --- | --- ==== References --- @ --- select_limit: --- | limit_clause offset_clause --- | offset_clause limit_clause --- | limit_clause --- | offset_clause --- @ -selectLimit = - asum - [ do - a <- limitClause - LimitOffsetSelectLimit a <$> (space1 *> offsetClause) <|> pure (LimitSelectLimit a), - do - a <- offsetClause - OffsetLimitSelectLimit a <$> (space1 *> limitClause) <|> pure (OffsetSelectLimit a) - ] - --- | --- ==== References --- @ --- limit_clause: --- | LIMIT select_limit_value --- | LIMIT select_limit_value ',' select_offset_value --- | FETCH first_or_next select_fetch_first_value row_or_rows ONLY --- | FETCH first_or_next row_or_rows ONLY --- @ -limitClause = - ( do - keyword "limit" - endHead - space1 - a <- selectLimitValue - b <- optional $ do - commaSeparator - aExpr - return (LimitLimitClause a b) - ) - <|> ( do - keyword "fetch" - endHead - space1 - a <- firstOrNext - space1 - asum - [ do - b <- rowOrRows - space1 - keyword "only" - return (FetchOnlyLimitClause a Nothing b), - do - b <- selectFetchFirstValue - space1 - c <- rowOrRows - space1 - keyword "only" - return (FetchOnlyLimitClause a (Just b) c) - ] - ) - -offsetClause = do - keyword "offset" - endHead - space1 - offsetClauseParams - -offsetClauseParams = - FetchFirstOffsetClause <$> wrapToHead selectFetchFirstValue <*> (space1 *> rowOrRows) - <|> ExprOffsetClause <$> aExpr - --- | --- ==== References --- @ --- select_limit_value: --- | a_expr --- | ALL --- @ -selectLimitValue = - AllSelectLimitValue <$ keyword "all" - <|> ExprSelectLimitValue <$> aExpr - -rowOrRows = - True <$ keyword "rows" - <|> False <$ keyword "row" - -firstOrNext = - False <$ keyword "first" - <|> True <$ keyword "next" - -selectFetchFirstValue = - ExprSelectFetchFirstValue <$> cExpr - <|> NumSelectFetchFirstValue <$> (plusOrMinus <* endHead <* space) <*> iconstOrFconst - -plusOrMinus = False <$ char '+' <|> True <$ char '-' - --- * For Locking - --- | --- ==== References --- @ --- for_locking_clause: --- | for_locking_items --- | FOR READ ONLY --- for_locking_items: --- | for_locking_item --- | for_locking_items for_locking_item --- @ -forLockingClause = readOnly <|> items - where - readOnly = ReadOnlyForLockingClause <$ keyphrase "for read only" - items = ItemsForLockingClause <$> sep1 space1 forLockingItem - --- | --- ==== References --- @ --- for_locking_item: --- | for_locking_strength locked_rels_list opt_nowait_or_skip --- locked_rels_list: --- | OF qualified_name_list --- | EMPTY --- opt_nowait_or_skip: --- | NOWAIT --- | SKIP LOCKED --- | EMPTY --- @ -forLockingItem = do - strength <- forLockingStrength - rels <- optional $ space1 *> keyword "of" *> space1 *> endHead *> sep1 commaSeparator qualifiedName - nowaitOrSkip <- optional (space1 *> nowaitOrSkip) - return (ForLockingItem strength rels nowaitOrSkip) - --- | --- ==== References --- @ --- for_locking_strength: --- | FOR UPDATE --- | FOR NO KEY UPDATE --- | FOR SHARE --- | FOR KEY SHARE --- @ -forLockingStrength = - UpdateForLockingStrength <$ keyphrase "for update" - <|> NoKeyUpdateForLockingStrength <$ keyphrase "for no key update" - <|> ShareForLockingStrength <$ keyphrase "for share" - <|> KeyForLockingStrength <$ keyphrase "for key share" - -nowaitOrSkip = False <$ keyword "nowait" <|> True <$ keyphrase "skip locked" - --- * References & Names - -quotedName = filter (const "Empty name") (not . Text.null) (quotedString '"') & fmap QuotedIdent - --- | --- ==== References --- @ --- ident_start [A-Za-z\200-\377_] --- ident_cont [A-Za-z\200-\377_0-9\$] --- identifier {ident_start}{ident_cont}* --- @ -ident = quotedName <|> keywordNameByPredicate (not . Predicate.keyword) - --- | --- ==== References --- @ --- ColId: --- | IDENT --- | unreserved_keyword --- | col_name_keyword --- @ -{-# NOINLINE colId #-} -colId = - label "identifier" - $ ident - <|> keywordNameFromSet (KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword) - -{-# NOINLINE filteredColId #-} -filteredColId = - let originalSet = KeywordSet.unreservedKeyword <> KeywordSet.colNameKeyword - filteredSet = foldr HashSet.delete originalSet - in \reservedKeywords -> label "identifier" $ ident <|> keywordNameFromSet (filteredSet reservedKeywords) - --- | --- ==== References --- @ --- ColLabel: --- | IDENT --- | unreserved_keyword --- | col_name_keyword --- | type_func_name_keyword --- | reserved_keyword --- @ -colLabel = - label "column label" - $ keywordNameFromSet KeywordSet.keyword - <|> ident - --- | --- >>> testParser qualifiedName "a.b" --- IndirectedQualifiedName (UnquotedIdent "a") (AttrNameIndirectionEl (UnquotedIdent "b") :| []) --- --- >>> testParser qualifiedName "a.-" --- ... --- expecting '*', column label, or white space --- --- ==== References --- @ --- qualified_name: --- | ColId --- | ColId indirection --- @ -qualifiedName = - IndirectedQualifiedName <$> wrapToHead colId <*> (space *> indirection) - <|> SimpleQualifiedName <$> colId - -columnref = customizedColumnref colId - -filteredColumnref keywords = customizedColumnref (filteredColId keywords) - -customizedColumnref colId = do - a <- wrapToHead colId - endHead - b <- optional (space *> indirection) - return (Columnref a b) - -anyName = customizedAnyName colId - -filteredAnyName keywords = customizedAnyName (filteredColId keywords) - -customizedAnyName colId = do - a <- wrapToHead colId - endHead - b <- optional (space *> attrs) - return (AnyName a b) - -name = colId - -nameList = sep1 commaSeparator name - -cursorName = name - --- | --- ==== References --- @ --- func_name: --- | type_function_name --- | ColId indirection --- @ -funcName = - IndirectedFuncName <$> wrapToHead colId <*> (space *> indirection) - <|> TypeFuncName <$> typeFunctionName - --- | --- ==== References --- @ --- type_function_name: --- | IDENT --- | unreserved_keyword --- | type_func_name_keyword --- @ -typeFunctionName = - keywordNameFromSet KeywordSet.typeFunctionName - <|> ident - --- | --- ==== References --- @ --- indirection: --- | indirection_el --- | indirection indirection_el --- @ -indirection = some indirectionEl - --- | --- ==== References --- @ --- indirection_el: --- | '.' attr_name --- | '.' '*' --- | '[' a_expr ']' --- | '[' opt_slice_bound ':' opt_slice_bound ']' --- opt_slice_bound: --- | a_expr --- | EMPTY --- @ -indirectionEl = - asum - [ do - char '.' - endHead - space - AllIndirectionEl <$ char '*' <|> AttrNameIndirectionEl <$> attrName, - do - char '[' - endHead - space - a <- - asum - [ do - char ':' - endHead - space - b <- optional aExpr - return (SliceIndirectionEl Nothing b), - do - a <- aExpr - asum - [ do - space - char ':' - space - b <- optional aExpr - return (SliceIndirectionEl (Just a) b), - return (ExprIndirectionEl a) - ] - ] - space - char ']' - return a - ] - --- | --- ==== References --- @ --- attr_name: --- | ColLabel --- @ -attrName = colLabel - -keywordNameFromSet set = keywordNameByPredicate (Predicate.inSet set) - -keywordNameByPredicate predicate = - fmap UnquotedIdent - $ filter - (\a -> "Reserved keyword " <> show a <> " used as an identifier. If that's what you intend, you have to wrap it in double quotes.") - predicate - anyKeyword - -anyKeyword = parse - $ Megaparsec.label "keyword" - $ do - firstChar <- Megaparsec.satisfy Predicate.firstIdentifierChar - remainder <- Megaparsec.takeWhileP Nothing Predicate.notFirstIdentifierChar - return (Text.toLower (Text.cons firstChar remainder)) - --- | Expected keyword --- --- 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. -keyphrase a = - Text.words a - & fmap (void . MegaparsecChar.string') - & intersperse MegaparsecChar.space1 - & sequence_ - & (<* Megaparsec.notFollowedBy (Megaparsec.satisfy Predicate.notFirstIdentifierChar)) - & fmap (const (Text.toUpper a)) - & Megaparsec.label (show a) - & parse - & (<* endHead) - --- * Typename - -typeList = sep1 commaSeparator typename - -typename = - do - a <- option False (keyword "setof" *> space1 $> True) - b <- simpleTypename - endHead - c <- trueIfPresent (space *> char '?') - asum - [ do - space1 - keyword "array" - endHead - d <- optional (space *> inBrackets iconst) - e <- trueIfPresent (space *> char '?') - return (Typename a b c (Just (ExplicitTypenameArrayDimensions d, e))), - do - space - d <- arrayBounds - endHead - e <- trueIfPresent (space *> char '?') - return (Typename a b c (Just (BoundsTypenameArrayDimensions d, e))), - return (Typename a b c Nothing) - ] - -arrayBounds = sep1 space (inBrackets (optional iconst)) - -simpleTypename = - asum - $ [ do - keyword "interval" - endHead - asum - [ ConstIntervalSimpleTypename <$> Right <$> (space *> inParens iconst), - ConstIntervalSimpleTypename <$> Left <$> optional (space *> interval) - ], - ConstDatetimeSimpleTypename <$> constDatetime, - NumericSimpleTypename <$> numeric, - BitSimpleTypename <$> bit, - CharacterSimpleTypename <$> character, - GenericTypeSimpleTypename <$> genericType - ] - -genericType = do - a <- typeFunctionName - endHead - b <- optional (space *> attrs) - c <- optional (space1 *> typeModifiers) - return (GenericType a b c) - -attrs = some (char '.' *> endHead *> space *> attrName) - -typeModifiers = inParens exprList - --- * Indexes - -indexParams = sep1 commaSeparator indexElem - -indexElem = - IndexElem - <$> (indexElemDef <* endHead) - <*> optional (space1 *> collate) - <*> optional (space1 *> class_) - <*> optional (space1 *> ascDesc) - <*> optional (space1 *> nullsOrder) - -indexElemDef = - ExprIndexElemDef <$> inParens aExpr - <|> FuncIndexElemDef <$> funcExprWindowless - <|> IdIndexElemDef <$> colId - -collate = keyword "collate" *> space1 *> endHead *> anyName - -class_ = filteredAnyName ["asc", "desc", "nulls"] - -ascDesc = keyword "asc" $> AscAscDesc <|> keyword "desc" $> DescAscDesc - -nullsOrder = keyword "nulls" *> space1 *> endHead *> (FirstNullsOrder <$ keyword "first" <|> LastNullsOrder <$ keyword "last") diff --git a/library/PostgresqlSyntax/Predicate.hs b/library/PostgresqlSyntax/Predicate.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Predicate.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - -module PostgresqlSyntax.Predicate where - -import qualified Data.HashSet as HashSet -import qualified PostgresqlSyntax.CharSet as CharSet -import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import PostgresqlSyntax.Prelude - --- * Generic - --- | --- >>> test = oneOf [(==3), (==7), (==3), (==5)] --- >>> test 1 --- False --- --- >>> test 3 --- True --- --- >>> test 5 --- True -oneOf :: [a -> Bool] -> a -> Bool -oneOf = foldr (\a b c -> a c || b c) (const False) - -inSet :: (Eq a, Hashable a) => HashSet a -> a -> Bool -inSet = flip HashSet.member - -hexDigit :: Char -> Bool -hexDigit = inSet CharSet.hexDigit - -{- -ident_start [A-Za-z\200-\377_] --} -firstIdentifierChar :: Char -> Bool -firstIdentifierChar x = isAlpha x || x == '_' || x >= '\200' && x <= '\377' - -{- -ident_cont [A-Za-z\200-\377_0-9\$] --} -notFirstIdentifierChar :: Char -> Bool -notFirstIdentifierChar x = isAlphaNum x || x == '_' || x == '$' || x >= '\200' && x <= '\377' - -keyword :: Text -> Bool -keyword = inSet KeywordSet.keyword - -unreservedKeyword :: Text -> Bool -unreservedKeyword = inSet KeywordSet.unreservedKeyword - -colNameKeyword :: Text -> Bool -colNameKeyword = inSet KeywordSet.colNameKeyword - -typeFuncNameKeyword :: Text -> Bool -typeFuncNameKeyword = inSet KeywordSet.typeFuncNameKeyword - -reservedKeyword :: Text -> Bool -reservedKeyword = inSet KeywordSet.reservedKeyword - -{-# NOINLINE symbolicBinOpChar #-} -symbolicBinOpChar :: Char -> Bool -symbolicBinOpChar = inSet CharSet.symbolicBinOp - --- ** Op chars - -opChar :: Char -> Bool -opChar = inSet CharSet.op - -prohibitedOpChar :: Char -> Bool -prohibitedOpChar a = a == '+' || a == '-' - -prohibitionLiftingOpChar :: Char -> Bool -prohibitionLiftingOpChar = inSet CharSet.prohibitionLiftingOp diff --git a/library/PostgresqlSyntax/Prelude.hs b/library/PostgresqlSyntax/Prelude.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Prelude.hs +++ /dev/null @@ -1,96 +0,0 @@ -module PostgresqlSyntax.Prelude - ( module Exports, - showAsText, - suffixRec, - extendMany, - ) -where - -import Control.Applicative as Exports -import Control.Arrow as Exports hiding (first, second) -import Control.Category as Exports -import Control.Concurrent as Exports -import Control.Exception as Exports -import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) -import Control.Monad.Fail as Exports -import Control.Monad.Fix as Exports hiding (fix) -import Control.Monad.IO.Class as Exports -import Control.Monad.ST as Exports -import Data.Bifunctor as Exports -import Data.Bits as Exports -import Data.Bool as Exports -import Data.ByteString as Exports (ByteString) -import Data.CaseInsensitive as Exports (CI, FoldCase) -import Data.Char as Exports -import Data.Coerce as Exports -import Data.Complex as Exports -import Data.Data as Exports -import Data.Dynamic as Exports -import Data.Either as Exports -import Data.Fixed as Exports -import Data.Foldable as Exports -import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports hiding (unzip) -import Data.Functor.Identity as Exports -import Data.HashMap.Strict as Exports (HashMap) -import Data.HashSet as Exports (HashSet) -import Data.Hashable as Exports (Hashable) -import Data.IORef as Exports -import Data.Int as Exports -import Data.Ix as Exports -import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons, unsnoc) -import Data.List.NonEmpty as Exports (NonEmpty (..)) -import Data.Maybe as Exports -import Data.Monoid as Exports hiding (First (..), Last (..), (<>)) -import Data.Ord as Exports -import Data.Proxy as Exports -import Data.Ratio as Exports -import Data.STRef as Exports -import Data.Semigroup as Exports -import Data.String as Exports -import Data.Text as Exports (Text) -import Data.Traversable as Exports -import Data.Tuple as Exports -import Data.Unique as Exports -import Data.Version as Exports -import Data.Void as Exports -import Data.Word as Exports -import Debug.Trace as Exports -import Foreign.ForeignPtr as Exports -import Foreign.Ptr as Exports -import Foreign.StablePtr as Exports -import Foreign.Storable as Exports hiding (alignment, sizeOf) -import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) -import GHC.Exts as Exports (IsList (Item, fromList), groupWith, inline, lazy, sortWith) -import GHC.Generics as Exports (Generic, Generic1) -import GHC.IO.Exception as Exports -import Numeric as Exports -import System.Environment as Exports -import System.Exit as Exports -import System.IO as Exports -import System.IO.Error as Exports -import System.IO.Unsafe as Exports -import System.Mem as Exports -import System.Mem.StableName as Exports -import System.Timeout as Exports -import Text.Printf as Exports (hPrintf, printf) -import Text.Read as Exports (Read (..), readEither, readMaybe) -import Unsafe.Coerce as Exports -import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) - -showAsText :: (Show a) => a -> Text -showAsText = show >>> fromString - --- | --- Compose a monad, which attempts to extend a value, based on the following input. --- It does so recursively until the suffix alternative fails. -suffixRec :: (MonadPlus m) => m a -> (a -> m a) -> m a -suffixRec base suffix = base >>= extendMany suffix - -extendMany :: (MonadPlus m) => (a -> m a) -> a -> m a -extendMany attempt = loop - where - loop !state = - optional (attempt state) >>= \case - Nothing -> pure state - Just newState -> loop newState diff --git a/library/PostgresqlSyntax/Rendering.hs b/library/PostgresqlSyntax/Rendering.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Rendering.hs +++ /dev/null @@ -1,921 +0,0 @@ -{-# OPTIONS_GHC -Wno-missing-signatures -Wno-dodgy-imports #-} - -module PostgresqlSyntax.Rendering - ( toText, - module PostgresqlSyntax.Rendering, - ) -where - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import PostgresqlSyntax.Ast -import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty -import PostgresqlSyntax.Extras.TextBuilder -import PostgresqlSyntax.Prelude hiding (aExpr, bit, fromList, many, option, sortBy, try) -import TextBuilder - --- * Execution - -toByteString :: TextBuilder -> ByteString -toByteString = Text.encodeUtf8 . toText - --- * Helpers - -commaNonEmpty :: (a -> TextBuilder) -> NonEmpty a -> TextBuilder -commaNonEmpty = NonEmpty.intersperseFoldMap ", " - -spaceNonEmpty :: (a -> TextBuilder) -> NonEmpty a -> TextBuilder -spaceNonEmpty = NonEmpty.intersperseFoldMap " " - -lexemes :: [TextBuilder] -> TextBuilder -lexemes = mconcat . intersperse " " - -optLexemes :: [Maybe TextBuilder] -> TextBuilder -optLexemes = lexemes . catMaybes - -inParens :: TextBuilder -> TextBuilder -inParens a = "(" <> a <> ")" - -inBrackets :: TextBuilder -> TextBuilder -inBrackets a = "[" <> a <> "]" - -prefixMaybe :: (a -> TextBuilder) -> Maybe a -> TextBuilder -prefixMaybe a = foldMap (flip mappend " " . a) - -suffixMaybe :: (a -> TextBuilder) -> Maybe a -> TextBuilder -suffixMaybe a = foldMap (mappend " " . a) - --- * Statements - -preparableStmt = \case - SelectPreparableStmt a -> selectStmt a - InsertPreparableStmt a -> insertStmt a - UpdatePreparableStmt a -> updateStmt a - DeletePreparableStmt a -> deleteStmt a - CallPreparableStmt a -> callStmt a - --- * Call - -callStmt (CallStmt a) = - "CALL " <> funcApplication a - --- * Insert - -insertStmt (InsertStmt a b c d e) = - prefixMaybe withClause a - <> "INSERT INTO " - <> insertTarget b - <> " " - <> insertRest c - <> suffixMaybe onConflict d - <> suffixMaybe returningClause e - -insertTarget (InsertTarget a b) = - qualifiedName a <> foldMap (mappend " AS " . colId) b - -insertRest = \case - SelectInsertRest a b c -> - optLexemes - [ fmap (inParens . insertColumnList) a, - fmap insertRestOverriding b, - Just (selectStmt c) - ] - DefaultValuesInsertRest -> "DEFAULT VALUES" - -insertRestOverriding a = "OVERRIDING " <> overrideKind a <> " VALUE" - -overrideKind = \case - UserOverrideKind -> "USER" - SystemOverrideKind -> "SYSTEM" - -insertColumnList = commaNonEmpty insertColumnItem - -insertColumnItem (InsertColumnItem a b) = colId a <> suffixMaybe indirection b - -onConflict (OnConflict a b) = "ON CONFLICT" <> suffixMaybe confExpr a <> " DO " <> onConflictDo b - -onConflictDo = \case - UpdateOnConflictDo a b -> "UPDATE SET " <> setClauseList a <> suffixMaybe whereClause b - NothingOnConflictDo -> "NOTHING" - -confExpr = \case - WhereConfExpr a b -> inParens (indexParams a) <> suffixMaybe whereClause b - ConstraintConfExpr a -> "ON CONSTRAINT " <> name a - -returningClause = mappend "RETURNING " . targetList - --- * Update - -updateStmt (UpdateStmt a b c d e f) = - prefixMaybe withClause a - <> "UPDATE " - <> relationExprOptAlias b - <> " " - <> "SET " - <> setClauseList c - <> suffixMaybe fromClause d - <> suffixMaybe whereOrCurrentClause e - <> suffixMaybe returningClause f - -setClauseList = commaNonEmpty setClause - -setClause = \case - TargetSetClause a b -> setTarget a <> " = " <> aExpr b - TargetListSetClause a b -> inParens (setTargetList a) <> " = " <> aExpr b - -setTarget (SetTarget a b) = colId a <> suffixMaybe indirection b - -setTargetList = commaNonEmpty setTarget - --- * Delete - -deleteStmt (DeleteStmt a b c d e) = - prefixMaybe withClause a - <> "DELETE FROM " - <> relationExprOptAlias b - <> suffixMaybe usingClause c - <> suffixMaybe whereOrCurrentClause d - <> suffixMaybe returningClause e - -usingClause = mappend "USING " . fromList - --- * Select - -selectStmt = \case - Left a -> selectNoParens a - Right a -> selectWithParens a - -selectNoParens (SelectNoParens a b c d e) = - optLexemes - [ fmap withClause a, - Just (selectClause b), - fmap sortClause c, - fmap selectLimit d, - fmap forLockingClause e - ] - -selectWithParens = - inParens . \case - NoParensSelectWithParens a -> selectNoParens a - WithParensSelectWithParens a -> selectWithParens a - -withClause (WithClause a b) = - "WITH " <> bool "" "RECURSIVE " a <> commaNonEmpty commonTableExpr b - -commonTableExpr (CommonTableExpr a b c d) = - optLexemes - [ Just (ident a), - fmap (inParens . commaNonEmpty ident) b, - Just "AS", - fmap materialization c, - Just (inParens (preparableStmt d)) - ] - -materialization = bool "NOT MATERIALIZED" "MATERIALIZED" - -selectLimit = \case - LimitOffsetSelectLimit a b -> lexemes [limitClause a, offsetClause b] - OffsetLimitSelectLimit a b -> lexemes [offsetClause a, limitClause b] - LimitSelectLimit a -> limitClause a - OffsetSelectLimit a -> offsetClause a - -limitClause = \case - LimitLimitClause a b -> "LIMIT " <> selectLimitValue a <> foldMap (mappend ", " . aExpr) b - FetchOnlyLimitClause a b c -> - optLexemes - [ Just "FETCH", - Just (firstOrNext a), - fmap selectFetchFirstValue b, - Just (rowOrRows c), - Just "ONLY" - ] - -firstOrNext = bool "FIRST" "NEXT" - -rowOrRows = bool "ROW" "ROWS" - -selectFetchFirstValue = \case - ExprSelectFetchFirstValue a -> cExpr a - NumSelectFetchFirstValue a b -> bool "+" "-" a <> intOrFloat b - -intOrFloat = either int64Dec doubleDec - -selectLimitValue = \case - ExprSelectLimitValue a -> aExpr a - AllSelectLimitValue -> "ALL" - -offsetClause = \case - ExprOffsetClause a -> "OFFSET " <> aExpr a - FetchFirstOffsetClause a b -> "OFFSET " <> selectFetchFirstValue a <> " " <> rowOrRows b - -forLockingClause = \case - ItemsForLockingClause a -> spaceNonEmpty forLockingItem a - ReadOnlyForLockingClause -> "FOR READ ONLY" - -forLockingItem (ForLockingItem a b c) = - optLexemes - [ Just (forLockingStrength a), - fmap lockedRelsList b, - fmap nowaitOrSkip c - ] - -forLockingStrength = \case - UpdateForLockingStrength -> "FOR UPDATE" - NoKeyUpdateForLockingStrength -> "FOR NO KEY UPDATE" - ShareForLockingStrength -> "FOR SHARE" - KeyForLockingStrength -> "FOR KEY SHARE" - -lockedRelsList a = "OF " <> commaNonEmpty qualifiedName a - -nowaitOrSkip = bool "NOWAIT" "SKIP LOCKED" - -selectClause = either simpleSelect selectWithParens - -simpleSelect = \case - NormalSimpleSelect a b c d e f g -> - optLexemes - [ Just "SELECT", - fmap targeting a, - fmap intoClause b, - fmap fromClause c, - fmap whereClause d, - fmap groupClause e, - fmap havingClause f, - fmap windowClause g - ] - ValuesSimpleSelect a -> valuesClause a - TableSimpleSelect a -> "TABLE " <> relationExpr a - BinSimpleSelect a b c d -> selectClause b <> " " <> selectBinOp a <> foldMap (mappend " " . allOrDistinct) c <> " " <> selectClause d - -selectBinOp = \case - UnionSelectBinOp -> "UNION" - IntersectSelectBinOp -> "INTERSECT" - ExceptSelectBinOp -> "EXCEPT" - -targeting = \case - NormalTargeting a -> targetList a - AllTargeting a -> "ALL" <> suffixMaybe targetList a - DistinctTargeting a b -> "DISTINCT" <> suffixMaybe onExpressionsClause a <> " " <> commaNonEmpty targetEl b - -targetList = commaNonEmpty targetEl - -onExpressionsClause a = "ON (" <> commaNonEmpty aExpr a <> ")" - -targetEl = \case - AliasedExprTargetEl a b -> aExpr a <> " AS " <> ident b - ImplicitlyAliasedExprTargetEl a b -> aExpr a <> " " <> ident b - ExprTargetEl a -> aExpr a - AsteriskTargetEl -> "*" - --- * Select Into - -intoClause a = "INTO " <> optTempTableName a - -optTempTableName = \case - TemporaryOptTempTableName a b -> optLexemes [Just "TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - TempOptTempTableName a b -> optLexemes [Just "TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - LocalTemporaryOptTempTableName a b -> optLexemes [Just "LOCAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - LocalTempOptTempTableName a b -> optLexemes [Just "LOCAL TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - GlobalTemporaryOptTempTableName a b -> optLexemes [Just "GLOBAL TEMPORARY", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - GlobalTempOptTempTableName a b -> optLexemes [Just "GLOBAL TEMP", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - UnloggedOptTempTableName a b -> optLexemes [Just "UNLOGGED", bool Nothing (Just "TABLE") a, Just (qualifiedName b)] - TableOptTempTableName a -> "TABLE " <> qualifiedName a - QualifedOptTempTableName a -> qualifiedName a - --- * From - -fromClause a = "FROM " <> fromList a - -fromList = commaNonEmpty tableRef - -tableRef = \case - RelationExprTableRef a b c -> - optLexemes - [ Just (relationExpr a), - fmap aliasClause b, - fmap tablesampleClause c - ] - FuncTableRef a b c -> - optLexemes - [ if a then Just "LATERAL" else Nothing, - Just (funcTable b), - fmap funcAliasClause c - ] - SelectTableRef a b c -> - optLexemes - [ if a then Just "LATERAL" else Nothing, - Just (selectWithParens b), - fmap aliasClause c - ] - JoinTableRef a b -> case b of - Just c -> inParens (joinedTable a) <> " " <> aliasClause c - Nothing -> joinedTable a - -relationExpr = \case - SimpleRelationExpr a b -> qualifiedName a <> bool "" " *" b - OnlyRelationExpr a b -> "ONLY " <> bool qualifiedName (inParens . qualifiedName) b a - -relationExprOptAlias (RelationExprOptAlias a b) = relationExpr a <> suffixMaybe optAlias b - -optAlias (a, b) = bool "" "AS " a <> colId b - -tablesampleClause (TablesampleClause a b c) = - "TABLESAMPLE " <> funcName a <> " (" <> exprList b <> ")" <> suffixMaybe repeatableClause c - -repeatableClause a = "REPEATABLE (" <> aExpr a <> ")" - -funcTable = \case - FuncExprFuncTable a b -> funcExprWindownless a <> bool "" " WITH ORDINALITY" b - RowsFromFuncTable a b -> "ROWS FROM (" <> rowsfromList a <> ")" <> bool "" " WITH ORDINALITY" b - -rowsfromItem (RowsfromItem a b) = funcExprWindownless a <> suffixMaybe colDefList b - -rowsfromList = commaNonEmpty rowsfromItem - -colDefList a = "AS (" <> tableFuncElementList a <> ")" - -tableFuncElementList = commaNonEmpty tableFuncElement - -tableFuncElement (TableFuncElement a b c) = colId a <> " " <> typename b <> suffixMaybe collateClause c - -collateClause a = "COLLATE " <> anyName a - -aliasClause (AliasClause a b c) = - optLexemes - [ if a then Just "AS" else Nothing, - Just (ident b), - fmap (inParens . commaNonEmpty ident) c - ] - -funcAliasClause = \case - AliasFuncAliasClause a -> aliasClause a - AsFuncAliasClause a -> "AS (" <> tableFuncElementList a <> ")" - AsColIdFuncAliasClause a b -> "AS " <> colId a <> " (" <> tableFuncElementList b <> ")" - ColIdFuncAliasClause a b -> colId a <> " (" <> tableFuncElementList b <> ")" - -joinedTable = \case - InParensJoinedTable a -> inParens (joinedTable a) - MethJoinedTable a b c -> case a of - CrossJoinMeth -> tableRef b <> " CROSS JOIN " <> tableRef c - QualJoinMeth d e -> tableRef b <> suffixMaybe joinType d <> " JOIN " <> tableRef c <> " " <> joinQual e - NaturalJoinMeth d -> tableRef b <> " NATURAL" <> suffixMaybe joinType d <> " JOIN " <> tableRef c - -joinType = \case - FullJoinType a -> "FULL" <> if a then " OUTER" else "" - LeftJoinType a -> "LEFT" <> if a then " OUTER" else "" - RightJoinType a -> "RIGHT" <> if a then " OUTER" else "" - InnerJoinType -> "INNER" - -joinQual = \case - UsingJoinQual a -> "USING (" <> commaNonEmpty ident a <> ")" - OnJoinQual a -> "ON " <> aExpr a - --- * Where - -whereClause a = "WHERE " <> aExpr a - -whereOrCurrentClause = \case - ExprWhereOrCurrentClause a -> "WHERE " <> aExpr a - CursorWhereOrCurrentClause a -> "WHERE CURRENT OF " <> cursorName a - --- * Group By - -groupClause a = "GROUP BY " <> commaNonEmpty groupByItem a - -groupByItem = \case - ExprGroupByItem a -> aExpr a - EmptyGroupingSetGroupByItem -> "()" - RollupGroupByItem a -> "ROLLUP (" <> commaNonEmpty aExpr a <> ")" - CubeGroupByItem a -> "CUBE (" <> commaNonEmpty aExpr a <> ")" - GroupingSetsGroupByItem a -> "GROUPING SETS (" <> commaNonEmpty groupByItem a <> ")" - --- * Having - -havingClause a = "HAVING " <> aExpr a - --- * Window - -windowClause a = "WINDOW " <> commaNonEmpty windowDefinition a - -windowDefinition (WindowDefinition a b) = ident a <> " AS " <> windowSpecification b - -windowSpecification (WindowSpecification a b c d) = - inParens - $ optLexemes - [ fmap ident a, - fmap partitionClause b, - fmap sortClause c, - fmap frameClause d - ] - -partitionClause a = "PARTITION BY " <> commaNonEmpty aExpr a - -frameClause (FrameClause a b c) = - optLexemes - [ Just (frameClauseMode a), - Just (frameExtent b), - fmap windowExclusionCause c - ] - -frameClauseMode = \case - RangeFrameClauseMode -> "RANGE" - RowsFrameClauseMode -> "ROWS" - GroupsFrameClauseMode -> "GROUPS" - -frameExtent = \case - SingularFrameExtent a -> frameBound a - BetweenFrameExtent a b -> "BETWEEN " <> frameBound a <> " AND " <> frameBound b - -frameBound = \case - UnboundedPrecedingFrameBound -> "UNBOUNDED PRECEDING" - UnboundedFollowingFrameBound -> "UNBOUNDED FOLLOWING" - CurrentRowFrameBound -> "CURRENT ROW" - PrecedingFrameBound a -> aExpr a <> " PRECEDING" - FollowingFrameBound a -> aExpr a <> " FOLLOWING" - -windowExclusionCause = \case - CurrentRowWindowExclusionClause -> "EXCLUDE CURRENT ROW" - GroupWindowExclusionClause -> "EXCLUDE GROUP" - TiesWindowExclusionClause -> "EXCLUDE TIES" - NoOthersWindowExclusionClause -> "EXCLUDE NO OTHERS" - --- * Order By - -sortClause a = "ORDER BY " <> commaNonEmpty sortBy a - -sortBy = \case - UsingSortBy a b c -> aExpr a <> " USING " <> qualAllOp b <> suffixMaybe nullsOrder c - AscDescSortBy a b c -> aExpr a <> suffixMaybe ascDesc b <> suffixMaybe nullsOrder c - --- * Values - -valuesClause a = "VALUES " <> commaNonEmpty (inParens . commaNonEmpty aExpr) a - --- * Exprs - -exprList = commaNonEmpty aExpr - -aExpr = \case - CExprAExpr a -> cExpr a - TypecastAExpr a b -> aExpr a <> " :: " <> typename b - CollateAExpr a b -> aExpr a <> " COLLATE " <> anyName b - AtTimeZoneAExpr a b -> aExpr a <> " AT TIME ZONE " <> aExpr b - PlusAExpr a -> "+ " <> aExpr a - MinusAExpr a -> "- " <> aExpr a - SymbolicBinOpAExpr a b c -> aExpr a <> " " <> symbolicExprBinOp b <> " " <> aExpr c - PrefixQualOpAExpr a b -> qualOp a <> " " <> aExpr b - SuffixQualOpAExpr a b -> aExpr a <> " " <> qualOp b - AndAExpr a b -> aExpr a <> " AND " <> aExpr b - OrAExpr a b -> aExpr a <> " OR " <> aExpr b - NotAExpr a -> "NOT " <> aExpr a - VerbalExprBinOpAExpr a b c d e -> aExpr a <> " " <> verbalExprBinOp b c <> " " <> aExpr d <> foldMap (mappend " ESCAPE " . aExpr) e - ReversableOpAExpr a b c -> aExpr a <> " " <> aExprReversableOp b c - IsnullAExpr a -> aExpr a <> " ISNULL" - NotnullAExpr a -> aExpr a <> " NOTNULL" - OverlapsAExpr a b -> row a <> " OVERLAPS " <> row b - SubqueryAExpr a b c d -> aExpr a <> " " <> subqueryOp b <> " " <> subType c <> " " <> either selectWithParens (inParens . aExpr) d - UniqueAExpr a -> "UNIQUE " <> selectWithParens a - DefaultAExpr -> "DEFAULT" - -bExpr = \case - CExprBExpr a -> cExpr a - TypecastBExpr a b -> bExpr a <> " :: " <> typename b - PlusBExpr a -> "+ " <> bExpr a - MinusBExpr a -> "- " <> bExpr a - SymbolicBinOpBExpr a b c -> bExpr a <> " " <> symbolicExprBinOp b <> " " <> bExpr c - QualOpBExpr a b -> qualOp a <> " " <> bExpr b - IsOpBExpr a b c -> bExpr a <> " " <> bExprIsOp b c - -cExpr = \case - ColumnrefCExpr a -> columnref a - AexprConstCExpr a -> aexprConst a - ParamCExpr a b -> "$" <> intDec a <> foldMap indirection b - InParensCExpr a b -> inParens (aExpr a) <> foldMap indirection b - CaseCExpr a -> caseExpr a - FuncCExpr a -> funcExpr a - SelectWithParensCExpr a b -> selectWithParens a <> foldMap indirection b - ExistsCExpr a -> "EXISTS " <> selectWithParens a - ArrayCExpr a -> "ARRAY " <> either selectWithParens arrayExpr a - ExplicitRowCExpr a -> explicitRow a - ImplicitRowCExpr a -> implicitRow a - GroupingCExpr a -> "GROUPING " <> inParens (exprList a) - --- * Ops - -aExprReversableOp a = \case - NullAExprReversableOp -> bool "IS " "IS NOT " a <> "NULL" - TrueAExprReversableOp -> bool "IS " "IS NOT " a <> "TRUE" - FalseAExprReversableOp -> bool "IS " "IS NOT " a <> "FALSE" - UnknownAExprReversableOp -> bool "IS " "IS NOT " a <> "UNKNOWN" - DistinctFromAExprReversableOp b -> bool "IS " "IS NOT " a <> "DISTINCT FROM " <> aExpr b - OfAExprReversableOp b -> bool "IS " "IS NOT " a <> "OF " <> inParens (typeList b) - BetweenAExprReversableOp b c d -> bool "" "NOT " a <> bool "BETWEEN " "BETWEEN ASYMMETRIC " b <> bExpr c <> " AND " <> aExpr d - BetweenSymmetricAExprReversableOp b c -> bool "" "NOT " a <> "BETWEEN SYMMETRIC " <> bExpr b <> " AND " <> aExpr c - InAExprReversableOp b -> bool "" "NOT " a <> "IN " <> inExpr b - DocumentAExprReversableOp -> bool "IS " "IS NOT " a <> "DOCUMENT" - -verbalExprBinOp a = - mappend (bool "" "NOT " a) . \case - LikeVerbalExprBinOp -> "LIKE" - IlikeVerbalExprBinOp -> "ILIKE" - SimilarToVerbalExprBinOp -> "SIMILAR TO" - -subqueryOp = \case - AllSubqueryOp a -> allOp a - AnySubqueryOp a -> "OPERATOR " <> inParens (anyOperator a) - LikeSubqueryOp a -> bool "" "NOT " a <> "LIKE" - IlikeSubqueryOp a -> bool "" "NOT " a <> "ILIKE" - -bExprIsOp a = - mappend (bool "IS " "IS NOT " a) . \case - DistinctFromBExprIsOp b -> "DISTINCT FROM " <> bExpr b - OfBExprIsOp a -> "OF " <> inParens (typeList a) - DocumentBExprIsOp -> "DOCUMENT" - -symbolicExprBinOp = \case - MathSymbolicExprBinOp a -> mathOp a - QualSymbolicExprBinOp a -> qualOp a - -qualOp = \case - OpQualOp a -> op a - OperatorQualOp a -> "OPERATOR (" <> anyOperator a <> ")" - -qualAllOp = \case - AllQualAllOp a -> allOp a - AnyQualAllOp a -> "OPERATOR (" <> anyOperator a <> ")" - -op = text - -anyOperator = \case - AllOpAnyOperator a -> allOp a - QualifiedAnyOperator a b -> colId a <> "." <> anyOperator b - -allOp = \case - OpAllOp a -> op a - MathAllOp a -> mathOp a - -mathOp = \case - PlusMathOp -> char7 '+' - MinusMathOp -> char7 '-' - AsteriskMathOp -> char7 '*' - SlashMathOp -> char7 '/' - PercentMathOp -> char7 '%' - ArrowUpMathOp -> char7 '^' - ArrowLeftMathOp -> char7 '<' - ArrowRightMathOp -> char7 '>' - EqualsMathOp -> char7 '=' - LessEqualsMathOp -> "<=" - GreaterEqualsMathOp -> ">=" - ArrowLeftArrowRightMathOp -> "<>" - ExclamationEqualsMathOp -> "!=" - -inExpr = \case - SelectInExpr a -> selectWithParens a - ExprListInExpr a -> inParens (exprList a) - -caseExpr (CaseExpr a b c) = - optLexemes - [ Just "CASE", - fmap aExpr a, - Just (spaceNonEmpty whenClause b), - fmap caseDefault c, - Just "END" - ] - -whenClause (WhenClause a b) = "WHEN " <> aExpr a <> " THEN " <> aExpr b - -caseDefault a = "ELSE " <> aExpr a - -arrayExpr = - inBrackets . \case - ExprListArrayExpr a -> exprList a - ArrayExprListArrayExpr a -> arrayExprList a - EmptyArrayExpr -> mempty - -arrayExprList = commaNonEmpty arrayExpr - -row = \case - ExplicitRowRow a -> explicitRow a - ImplicitRowRow a -> implicitRow a - -explicitRow a = "ROW " <> inParens (foldMap exprList a) - -implicitRow (ImplicitRow a b) = inParens (exprList a <> ", " <> aExpr b) - -funcApplication (FuncApplication a b) = - funcName a <> "(" <> foldMap funcApplicationParams b <> ")" - -funcApplicationParams = \case - NormalFuncApplicationParams a b c -> - optLexemes - [ fmap allOrDistinct a, - Just (commaNonEmpty funcArgExpr b), - fmap sortClause c - ] - VariadicFuncApplicationParams a b c -> - optLexemes - [ fmap (flip mappend "," . commaNonEmpty funcArgExpr) a, - Just "VARIADIC", - Just (funcArgExpr b), - fmap sortClause c - ] - StarFuncApplicationParams -> "*" - -allOrDistinct = \case - False -> "ALL" - True -> "DISTINCT" - -funcArgExpr = \case - ExprFuncArgExpr a -> aExpr a - ColonEqualsFuncArgExpr a b -> ident a <> " := " <> aExpr b - EqualsGreaterFuncArgExpr a b -> ident a <> " => " <> aExpr b - --- ** Func Expr - -funcExpr = \case - ApplicationFuncExpr a b c d -> - optLexemes - [ Just (funcApplication a), - fmap withinGroupClause b, - fmap filterClause c, - fmap overClause d - ] - SubexprFuncExpr a -> funcExprCommonSubexpr a - -funcExprWindownless = \case - ApplicationFuncExprWindowless a -> funcApplication a - CommonSubexprFuncExprWindowless a -> funcExprCommonSubexpr a - -withinGroupClause a = "WITHIN GROUP (" <> sortClause a <> ")" - -filterClause a = "FILTER (WHERE " <> aExpr a <> ")" - -overClause = \case - WindowOverClause a -> "OVER " <> windowSpecification a - ColIdOverClause a -> "OVER " <> colId a - -funcExprCommonSubexpr = \case - CollationForFuncExprCommonSubexpr a -> "COLLATION FOR (" <> aExpr a <> ")" - CurrentDateFuncExprCommonSubexpr -> "CURRENT_DATE" - CurrentTimeFuncExprCommonSubexpr a -> "CURRENT_TIME" <> suffixMaybe (inParens . iconst) a - CurrentTimestampFuncExprCommonSubexpr a -> "CURRENT_TIMESTAMP" <> suffixMaybe (inParens . iconst) a - LocalTimeFuncExprCommonSubexpr a -> "LOCALTIME" <> suffixMaybe (inParens . iconst) a - LocalTimestampFuncExprCommonSubexpr a -> "LOCALTIMESTAMP" <> suffixMaybe (inParens . iconst) a - CurrentRoleFuncExprCommonSubexpr -> "CURRENT_ROLE" - CurrentUserFuncExprCommonSubexpr -> "CURRENT_USER" - SessionUserFuncExprCommonSubexpr -> "SESSION_USER" - UserFuncExprCommonSubexpr -> "USER" - CurrentCatalogFuncExprCommonSubexpr -> "CURRENT_CATALOG" - CurrentSchemaFuncExprCommonSubexpr -> "CURRENT_SCHEMA" - CastFuncExprCommonSubexpr a b -> "CAST (" <> aExpr a <> " AS " <> typename b <> ")" - ExtractFuncExprCommonSubexpr a -> "EXTRACT (" <> foldMap extractList a <> ")" - OverlayFuncExprCommonSubexpr a -> "OVERLAY (" <> overlayList a <> ")" - PositionFuncExprCommonSubexpr a -> "POSITION (" <> foldMap positionList a <> ")" - SubstringFuncExprCommonSubexpr a -> "SUBSTRING (" <> foldMap substrList a <> ")" - TreatFuncExprCommonSubexpr a b -> "TREAT (" <> aExpr a <> " AS " <> typename b <> ")" - TrimFuncExprCommonSubexpr a b -> "TRIM (" <> prefixMaybe trimModifier a <> trimList b <> ")" - NullIfFuncExprCommonSubexpr a b -> "NULLIF (" <> aExpr a <> ", " <> aExpr b <> ")" - CoalesceFuncExprCommonSubexpr a -> "COALESCE (" <> exprList a <> ")" - GreatestFuncExprCommonSubexpr a -> "GREATEST (" <> exprList a <> ")" - LeastFuncExprCommonSubexpr a -> "LEAST (" <> exprList a <> ")" - -extractList (ExtractList a b) = extractArg a <> " FROM " <> aExpr b - -extractArg = \case - IdentExtractArg a -> ident a - YearExtractArg -> "YEAR" - MonthExtractArg -> "MONTH" - DayExtractArg -> "DAY" - HourExtractArg -> "HOUR" - MinuteExtractArg -> "MINUTE" - SecondExtractArg -> "SECOND" - SconstExtractArg a -> sconst a - -overlayList (OverlayList a b c d) = aExpr a <> " " <> overlayPlacing b <> " " <> substrFrom c <> suffixMaybe substrFor d - -overlayPlacing a = "PLACING " <> aExpr a - -positionList (PositionList a b) = bExpr a <> " IN " <> bExpr b - -substrList = \case - ExprSubstrList a b -> aExpr a <> " " <> substrListFromFor b - ExprListSubstrList a -> exprList a - -substrListFromFor = \case - FromForSubstrListFromFor a b -> substrFrom a <> " " <> substrFor b - ForFromSubstrListFromFor a b -> substrFor a <> " " <> substrFrom b - FromSubstrListFromFor a -> substrFrom a - ForSubstrListFromFor a -> substrFor a - -substrFrom a = "FROM " <> aExpr a - -substrFor a = "FOR " <> aExpr a - -trimModifier = \case - BothTrimModifier -> "BOTH" - LeadingTrimModifier -> "LEADING" - TrailingTrimModifier -> "TRAILING" - -trimList = \case - ExprFromExprListTrimList a b -> aExpr a <> " FROM " <> exprList b - FromExprListTrimList a -> "FROM " <> exprList a - ExprListTrimList a -> exprList a - --- * AexprConsts - -aexprConst = \case - IAexprConst a -> iconst a - FAexprConst a -> fconst a - SAexprConst a -> sconst a - BAexprConst a -> "B'" <> text a <> "'" - XAexprConst a -> "X'" <> text a <> "'" - FuncAexprConst a b c -> funcName a <> foldMap (inParens . funcAexprConstArgList) b <> " " <> sconst c - ConstTypenameAexprConst a b -> constTypename a <> " " <> sconst b - StringIntervalAexprConst a b -> "INTERVAL " <> sconst a <> suffixMaybe interval b - IntIntervalAexprConst a b -> "INTERVAL " <> inParens (int64Dec a) <> " " <> sconst b - BoolAexprConst a -> if a then "TRUE" else "FALSE" - NullAexprConst -> "NULL" - -iconst = int64Dec - -fconst = doubleDec - -sconst a = "'" <> text (Text.replace "'" "''" a) <> "'" - -funcAexprConstArgList (FuncConstArgs a b) = commaNonEmpty funcArgExpr a <> suffixMaybe sortClause b - -constTypename = \case - NumericConstTypename a -> numeric a - ConstBitConstTypename a -> constBit a - ConstCharacterConstTypename a -> constCharacter a - ConstDatetimeConstTypename a -> constDatetime a - -numeric = \case - IntNumeric -> "INT" - IntegerNumeric -> "INTEGER" - SmallintNumeric -> "SMALLINT" - BigintNumeric -> "BIGINT" - RealNumeric -> "REAL" - FloatNumeric a -> "FLOAT" <> suffixMaybe (inParens . int64Dec) a - DoublePrecisionNumeric -> "DOUBLE PRECISION" - DecimalNumeric a -> "DECIMAL" <> suffixMaybe (inParens . commaNonEmpty aExpr) a - DecNumeric a -> "DEC" <> suffixMaybe (inParens . commaNonEmpty aExpr) a - NumericNumeric a -> "NUMERIC" <> suffixMaybe (inParens . commaNonEmpty aExpr) a - BooleanNumeric -> "BOOLEAN" - -bit (Bit a b) = - optLexemes - [ Just "BIT", - bool Nothing (Just "VARYING") a, - fmap (inParens . commaNonEmpty aExpr) b - ] - -constBit = bit - -constCharacter (ConstCharacter a b) = character a <> suffixMaybe (inParens . int64Dec) b - -character = \case - CharacterCharacter a -> "CHARACTER" <> bool "" " VARYING" a - CharCharacter a -> "CHAR" <> bool "" " VARYING" a - VarcharCharacter -> "VARCHAR" - NationalCharacterCharacter a -> "NATIONAL CHARACTER" <> bool "" " VARYING" a - NationalCharCharacter a -> "NATIONAL CHAR" <> bool "" " VARYING" a - NcharCharacter a -> "NCHAR" <> bool "" " VARYING" a - -constDatetime = \case - TimestampConstDatetime a b -> - optLexemes - [ Just "TIMESTAMP", - fmap (inParens . int64Dec) a, - fmap timezone b - ] - TimeConstDatetime a b -> - optLexemes - [ Just "TIME", - fmap (inParens . int64Dec) a, - fmap timezone b - ] - -timezone = \case - False -> "WITH TIME ZONE" - True -> "WITHOUT TIME ZONE" - -interval = \case - YearInterval -> "YEAR" - MonthInterval -> "MONTH" - DayInterval -> "DAY" - HourInterval -> "HOUR" - MinuteInterval -> "MINUTE" - SecondInterval a -> intervalSecond a - YearToMonthInterval -> "YEAR TO MONTH" - DayToHourInterval -> "DAY TO HOUR" - DayToMinuteInterval -> "DAY TO MINUTE" - DayToSecondInterval a -> "DAY TO " <> intervalSecond a - HourToMinuteInterval -> "HOUR TO MINUTE" - HourToSecondInterval a -> "HOUR TO " <> intervalSecond a - MinuteToSecondInterval a -> "MINUTE TO " <> intervalSecond a - -intervalSecond = \case - Nothing -> "SECOND" - Just a -> "SECOND " <> inParens (int64Dec a) - --- * Names and refs - -columnref (Columnref a b) = colId a <> foldMap indirection b - -ident = \case - QuotedIdent a -> char7 '"' <> text (Text.replace "\"" "\"\"" a) <> char7 '"' - UnquotedIdent a -> text a - -qualifiedName = \case - SimpleQualifiedName a -> ident a - IndirectedQualifiedName a b -> ident a <> indirection b - -indirection = foldMap indirectionEl - -indirectionEl = \case - AttrNameIndirectionEl a -> "." <> ident a - AllIndirectionEl -> ".*" - ExprIndirectionEl a -> "[" <> aExpr a <> "]" - SliceIndirectionEl a b -> "[" <> foldMap aExpr a <> ":" <> foldMap aExpr b <> "]" - -colId = ident - -name = colId - -cursorName = name - -colLabel = ident - -attrName = colLabel - -typeFunctionName = ident - -funcName = \case - TypeFuncName a -> typeFunctionName a - IndirectedFuncName a b -> colId a <> indirection b - -anyName (AnyName a b) = colId a <> foldMap attrs b - --- * Types - -typename (Typename a b _ d) = - bool "" "SETOF " a <> simpleTypename b <> foldMap typenameArrayDimensionsWithQuestionMark d - -typenameArrayDimensionsWithQuestionMark (a, _) = - typenameArrayDimensions a - -typenameArrayDimensions = \case - BoundsTypenameArrayDimensions a -> arrayBounds a - ExplicitTypenameArrayDimensions a -> " ARRAY" <> foldMap (inBrackets . iconst) a - -arrayBounds = spaceNonEmpty (inBrackets . foldMap iconst) - -simpleTypename = \case - GenericTypeSimpleTypename a -> genericType a - NumericSimpleTypename a -> numeric a - BitSimpleTypename a -> bit a - CharacterSimpleTypename a -> character a - ConstDatetimeSimpleTypename a -> constDatetime a - ConstIntervalSimpleTypename a -> "INTERVAL" <> either (suffixMaybe interval) (mappend " " . inParens . iconst) a - -genericType (GenericType a b c) = typeFunctionName a <> foldMap attrs b <> suffixMaybe typeModifiers c - -attrs = foldMap (mappend "." . attrName) - -typeModifiers = inParens . exprList - -typeList = commaNonEmpty typename - -subType = \case - AnySubType -> "ANY" - SomeSubType -> "SOME" - AllSubType -> "ALL" - --- * Indexes - -indexParams = commaNonEmpty indexElem - -indexElem (IndexElem a b c d e) = - indexElemDef a - <> suffixMaybe collate b - <> suffixMaybe class_ c - <> suffixMaybe ascDesc d - <> suffixMaybe nullsOrder e - -indexElemDef = \case - IdIndexElemDef a -> colId a - FuncIndexElemDef a -> funcExprWindownless a - ExprIndexElemDef a -> inParens (aExpr a) - -collate = mappend "COLLATE " . anyName - -class_ = anyName - -ascDesc = \case - AscAscDesc -> "ASC" - DescAscDesc -> "DESC" - -nullsOrder = \case - FirstNullsOrder -> "NULLS FIRST" - LastNullsOrder -> "NULLS LAST" diff --git a/library/PostgresqlSyntax/Validation.hs b/library/PostgresqlSyntax/Validation.hs deleted file mode 100644 --- a/library/PostgresqlSyntax/Validation.hs +++ /dev/null @@ -1,51 +0,0 @@ -module PostgresqlSyntax.Validation where - -import qualified Data.Text as Text -import qualified PostgresqlSyntax.KeywordSet as KeywordSet -import qualified PostgresqlSyntax.Predicate as Predicate -import PostgresqlSyntax.Prelude - -{- -The operator name is a sequence of up to NAMEDATALEN-1 (63 by default) -characters from the following list: - -+ - * / < > = ~ ! @ # % ^ & | ` ? - -There are a few restrictions on your choice of name: --- and /* cannot appear anywhere in an operator name, -since they will be taken as the start of a comment. - -A multicharacter operator name cannot end in + or -, -unless the name also contains at least one of these characters: - -~ ! @ # % ^ & | ` ? - -For example, @- is an allowed operator name, but *- is not. -This restriction allows PostgreSQL to parse SQL-compliant -commands without requiring spaces between tokens. -The use of => as an operator name is deprecated. -It may be disallowed altogether in a future release. - -The operator != is mapped to <> on input, -so these two names are always equivalent. --} -op :: Text -> Maybe Text -op a = - if Text.null a - then Just ("Operator is empty") - else - if Text.isInfixOf "--" a - then Just ("Operator contains a prohibited \"--\" sequence: " <> a) - else - if Text.isInfixOf "/*" a - then Just ("Operator contains a prohibited \"/*\" sequence: " <> a) - else - if Predicate.inSet KeywordSet.nonOp a - then Just ("Operator is not generic: " <> a) - else - if Text.find Predicate.prohibitionLiftingOpChar a & isJust - then Nothing - else - if Predicate.prohibitedOpChar (Text.last a) - then Just ("Operator ends with a prohibited char: " <> a) - else Nothing diff --git a/nesting-bench/Main.hs b/nesting-bench/Main.hs --- a/nesting-bench/Main.hs +++ b/nesting-bench/Main.hs @@ -11,15 +11,11 @@ -- 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 PostgresqlSyntax (AExpr, parse) import Prelude +import System.Clock -- * Inputs @@ -58,7 +54,7 @@ time :: Text -> IO Double time input = do start <- getTime Monotonic - _ <- evaluate (force (either (const "err") (const "ok") (Parsing.run Parsing.aExpr input) :: String)) + _ <- evaluate (force (either (const "err") (const "ok") (parse @AExpr mempty input) :: String)) end <- getTime Monotonic pure (fromIntegral (toNanoSecs (diffTimeSpec end start)) / 1e9) diff --git a/postgresql-syntax.cabal b/postgresql-syntax.cabal --- a/postgresql-syntax.cabal +++ b/postgresql-syntax.cabal @@ -1,12 +1,10 @@ cabal-version: 3.0 name: postgresql-syntax -version: 0.4.5.0 +version: 0.5.0.2 category: Database, PostgreSQL, Parsing synopsis: PostgreSQL AST parsing and rendering description: Postgres syntax tree and related utils extracted from the \"hasql-th\" package. - The API is in a rather raw \"guts out\" state with most documentation lacking, - but the codebase is well tested. homepage: https://github.com/nikita-volkov/postgresql-syntax bug-reports: https://github.com/nikita-volkov/postgresql-syntax/issues @@ -15,6 +13,10 @@ copyright: (c) 2020, Nikita Volkov license: MIT license-file: LICENSE +extra-doc-files: + CHANGELOG.md + LICENSE + README.md source-repository head type: git @@ -24,7 +26,6 @@ default-language: Haskell2010 default-extensions: ApplicativeDo - Arrows BangPatterns ConstraintKinds DataKinds @@ -51,35 +52,186 @@ OverloadedStrings ParallelListComp PatternGuards - QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving - TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UnboxedTuples -library +library internal import: base-settings - hs-source-dirs: library + hs-source-dirs: library-internal exposed-modules: + PostgresqlSyntax.Algebra PostgresqlSyntax.Ast - PostgresqlSyntax.KeywordSet - PostgresqlSyntax.Parsing - PostgresqlSyntax.Rendering - PostgresqlSyntax.Validation - - other-modules: + PostgresqlSyntax.Ast.AExpr + PostgresqlSyntax.Ast.AexprConst + PostgresqlSyntax.Ast.AExprReversableOp + PostgresqlSyntax.Ast.AliasClause + PostgresqlSyntax.Ast.AllOp + PostgresqlSyntax.Ast.AnyName + PostgresqlSyntax.Ast.AnyOperator + PostgresqlSyntax.Ast.ArrayBounds + PostgresqlSyntax.Ast.ArrayExpr + PostgresqlSyntax.Ast.ArrayExprList + PostgresqlSyntax.Ast.AscDesc + PostgresqlSyntax.Ast.Attrs + PostgresqlSyntax.Ast.Bconst + PostgresqlSyntax.Ast.BExpr + PostgresqlSyntax.Ast.BExprIsOp + PostgresqlSyntax.Ast.Bit + PostgresqlSyntax.Ast.CallStmt + PostgresqlSyntax.Ast.CaseExpr + PostgresqlSyntax.Ast.CExpr + PostgresqlSyntax.Ast.Character + PostgresqlSyntax.Ast.Columnref + PostgresqlSyntax.Ast.CommonTableExpr + PostgresqlSyntax.Ast.ConfExpr + PostgresqlSyntax.Ast.ConstCharacter + PostgresqlSyntax.Ast.ConstDatetime + PostgresqlSyntax.Ast.ConstTypename + PostgresqlSyntax.Ast.DeleteStmt + PostgresqlSyntax.Ast.ExplicitRow + PostgresqlSyntax.Ast.ExprList + PostgresqlSyntax.Ast.ExtractArg + PostgresqlSyntax.Ast.ExtractList + PostgresqlSyntax.Ast.Fconst + PostgresqlSyntax.Ast.ForLockingClause + PostgresqlSyntax.Ast.ForLockingItem + PostgresqlSyntax.Ast.ForLockingStrength + PostgresqlSyntax.Ast.FrameBound + PostgresqlSyntax.Ast.FrameClause + PostgresqlSyntax.Ast.FrameClauseMode + PostgresqlSyntax.Ast.FrameExtent + PostgresqlSyntax.Ast.FromClause + PostgresqlSyntax.Ast.FromList + PostgresqlSyntax.Ast.FuncAliasClause + PostgresqlSyntax.Ast.FuncApplication + PostgresqlSyntax.Ast.FuncApplicationParams + PostgresqlSyntax.Ast.FuncArgExpr + PostgresqlSyntax.Ast.FuncConstArgs + PostgresqlSyntax.Ast.FuncExpr + PostgresqlSyntax.Ast.FuncExprCommonSubexpr + PostgresqlSyntax.Ast.FuncExprWindowless + PostgresqlSyntax.Ast.FuncName + PostgresqlSyntax.Ast.FuncTable + PostgresqlSyntax.Ast.GenericType + PostgresqlSyntax.Ast.GroupByItem + PostgresqlSyntax.Ast.GroupClause + PostgresqlSyntax.Ast.HavingClause + PostgresqlSyntax.Ast.Iconst + PostgresqlSyntax.Ast.Ident + PostgresqlSyntax.Ast.ImplicitRow + PostgresqlSyntax.Ast.IndexElem + PostgresqlSyntax.Ast.IndexElemDef + PostgresqlSyntax.Ast.IndexParams + PostgresqlSyntax.Ast.Indirection + PostgresqlSyntax.Ast.IndirectionEl + PostgresqlSyntax.Ast.InExpr + PostgresqlSyntax.Ast.InsertColumnItem + PostgresqlSyntax.Ast.InsertColumnList + PostgresqlSyntax.Ast.InsertRest + PostgresqlSyntax.Ast.InsertStmt + PostgresqlSyntax.Ast.InsertTarget + PostgresqlSyntax.Ast.Interval + PostgresqlSyntax.Ast.IntervalSecond + PostgresqlSyntax.Ast.IntoClause + PostgresqlSyntax.Ast.JoinedTable + PostgresqlSyntax.Ast.JoinQual + PostgresqlSyntax.Ast.JoinType + PostgresqlSyntax.Ast.LimitClause + PostgresqlSyntax.Ast.MathOp + PostgresqlSyntax.Ast.NameList + PostgresqlSyntax.Ast.NullsOrder + PostgresqlSyntax.Ast.Numeric + PostgresqlSyntax.Ast.OffsetClause + PostgresqlSyntax.Ast.OnConflict + PostgresqlSyntax.Ast.OnConflictDo + PostgresqlSyntax.Ast.Op + PostgresqlSyntax.Ast.OptOrdinality + PostgresqlSyntax.Ast.OptTempTableName + PostgresqlSyntax.Ast.OptVarying + PostgresqlSyntax.Ast.OverClause + PostgresqlSyntax.Ast.OverlayList + PostgresqlSyntax.Ast.OverrideKind + PostgresqlSyntax.Ast.PositionList + PostgresqlSyntax.Ast.PreparableStmt + PostgresqlSyntax.Ast.QualAllOp + PostgresqlSyntax.Ast.QualifiedName + PostgresqlSyntax.Ast.QualOp + PostgresqlSyntax.Ast.RelationExpr + PostgresqlSyntax.Ast.RelationExprOptAlias + PostgresqlSyntax.Ast.ReturningClause + PostgresqlSyntax.Ast.Row + PostgresqlSyntax.Ast.RowsfromItem + PostgresqlSyntax.Ast.RowsfromList + PostgresqlSyntax.Ast.Sconst + PostgresqlSyntax.Ast.SelectBinOp + PostgresqlSyntax.Ast.SelectClause + PostgresqlSyntax.Ast.SelectFetchFirstValue + PostgresqlSyntax.Ast.SelectLimit + PostgresqlSyntax.Ast.SelectLimitValue + PostgresqlSyntax.Ast.SelectNoParens + PostgresqlSyntax.Ast.SelectStmt + PostgresqlSyntax.Ast.SelectWithParens + PostgresqlSyntax.Ast.SetClause + PostgresqlSyntax.Ast.SetClauseList + PostgresqlSyntax.Ast.SetTarget + PostgresqlSyntax.Ast.SetTargetList + PostgresqlSyntax.Ast.SimpleSelect + PostgresqlSyntax.Ast.SimpleTypename + PostgresqlSyntax.Ast.SortBy + PostgresqlSyntax.Ast.SortClause + PostgresqlSyntax.Ast.SubqueryOp + PostgresqlSyntax.Ast.SubstrList + PostgresqlSyntax.Ast.SubstrListFromFor + PostgresqlSyntax.Ast.SubType + PostgresqlSyntax.Ast.SymbolicExprBinOp + PostgresqlSyntax.Ast.TableFuncElement + PostgresqlSyntax.Ast.TableFuncElementList + PostgresqlSyntax.Ast.TableRef + PostgresqlSyntax.Ast.TablesampleClause + PostgresqlSyntax.Ast.TargetEl + PostgresqlSyntax.Ast.Targeting + PostgresqlSyntax.Ast.TargetList + PostgresqlSyntax.Ast.Timezone + PostgresqlSyntax.Ast.TrimList + PostgresqlSyntax.Ast.TrimModifier + PostgresqlSyntax.Ast.TypeList + PostgresqlSyntax.Ast.Typename + PostgresqlSyntax.Ast.TypenameArrayDimensions + PostgresqlSyntax.Ast.UpdateStmt + PostgresqlSyntax.Ast.UsingClause + PostgresqlSyntax.Ast.ValuesClause + PostgresqlSyntax.Ast.VerbalExprBinOp + PostgresqlSyntax.Ast.WhenClause + PostgresqlSyntax.Ast.WhenClauseList + PostgresqlSyntax.Ast.WhereClause + PostgresqlSyntax.Ast.WhereOrCurrentClause + PostgresqlSyntax.Ast.WindowClause + PostgresqlSyntax.Ast.WindowDefinition + PostgresqlSyntax.Ast.WindowExclusionClause + PostgresqlSyntax.Ast.WindowSpecification + PostgresqlSyntax.Ast.WithClause + PostgresqlSyntax.Ast.Xconst PostgresqlSyntax.CharSet + PostgresqlSyntax.Extras.Error PostgresqlSyntax.Extras.HeadedMegaparsec PostgresqlSyntax.Extras.NonEmpty PostgresqlSyntax.Extras.TextBuilder + PostgresqlSyntax.Helpers.Gens + PostgresqlSyntax.Helpers.Parsers + PostgresqlSyntax.Helpers.Shrinks + PostgresqlSyntax.Helpers.TextBuilders + PostgresqlSyntax.KeywordSet PostgresqlSyntax.Predicate PostgresqlSyntax.Prelude + PostgresqlSyntax.Settings + PostgresqlSyntax.Validation build-depends: base >=4.12 && <5, @@ -89,32 +241,193 @@ headed-megaparsec >=0.2.0.1 && <0.3, megaparsec >=9.2 && <10, parser-combinators >=1.3 && <1.4, + QuickCheck >=2.17 && <3, text >=1 && <3, text-builder >=1 && <1.1, unordered-containers >=0.2.16 && <0.3, -test-suite tasty-test +library import: base-settings - type: exitcode-stdio-1.0 - hs-source-dirs: tasty-test - main-is: Main.hs - ghc-options: -threaded + hs-source-dirs: library + exposed-modules: + PostgresqlSyntax + build-depends: - postgresql-syntax, - rerebase <2, - tasty >=1.2.3 && <2, - tasty-hunit >=0.10 && <0.11, + postgresql-syntax:internal -test-suite hedgehog-test +test-suite hspec-test import: base-settings type: exitcode-stdio-1.0 - hs-source-dirs: hedgehog-test + hs-source-dirs: hspec-test main-is: Main.hs - ghc-options: -threaded - other-modules: Main.Gen + other-modules: + Ast.AexprConstSpec + Ast.AExprReversableOpSpec + Ast.AExprSpec + Ast.AliasClauseSpec + Ast.AllOpSpec + Ast.AnyNameSpec + Ast.AnyOperatorSpec + Ast.ArrayBoundsSpec + Ast.ArrayExprListSpec + Ast.ArrayExprSpec + Ast.AscDescSpec + Ast.AttrsSpec + Ast.BconstSpec + Ast.BExprIsOpSpec + Ast.BExprSpec + Ast.BitSpec + Ast.CallStmtSpec + Ast.CaseExprSpec + Ast.CExprSpec + Ast.CharacterSpec + Ast.ColumnrefSpec + Ast.CommonTableExprSpec + Ast.ConfExprSpec + Ast.ConstCharacterSpec + Ast.ConstDatetimeSpec + Ast.ConstTypenameSpec + Ast.DeleteStmtSpec + Ast.ExplicitRowSpec + Ast.ExprListSpec + Ast.ExtractArgSpec + Ast.ExtractListSpec + Ast.FconstSpec + Ast.ForLockingClauseSpec + Ast.ForLockingItemSpec + Ast.ForLockingStrengthSpec + Ast.FrameBoundSpec + Ast.FrameClauseModeSpec + Ast.FrameClauseSpec + Ast.FrameExtentSpec + Ast.FromClauseSpec + Ast.FromListSpec + Ast.FuncAliasClauseSpec + Ast.FuncApplicationParamsSpec + Ast.FuncApplicationSpec + Ast.FuncArgExprSpec + Ast.FuncConstArgsSpec + Ast.FuncExprCommonSubexprSpec + Ast.FuncExprSpec + Ast.FuncExprWindowlessSpec + Ast.FuncNameSpec + Ast.FuncTableSpec + Ast.GenericTypeSpec + Ast.GroupByItemSpec + Ast.GroupClauseSpec + Ast.HavingClauseSpec + Ast.IconstSpec + Ast.IdentSpec + Ast.ImplicitRowSpec + Ast.IndexElemDefSpec + Ast.IndexElemSpec + Ast.IndexParamsSpec + Ast.IndirectionElSpec + Ast.IndirectionSpec + Ast.InExprSpec + Ast.InsertColumnItemSpec + Ast.InsertColumnListSpec + Ast.InsertRestSpec + Ast.InsertStmtSpec + Ast.InsertTargetSpec + Ast.IntervalSecondSpec + Ast.IntervalSpec + Ast.IntoClauseSpec + Ast.JoinedTableSpec + Ast.JoinQualSpec + Ast.JoinTypeSpec + Ast.LimitClauseSpec + Ast.MathOpSpec + Ast.NameListSpec + Ast.NullsOrderSpec + Ast.NumericSpec + Ast.OffsetClauseSpec + Ast.OnConflictDoSpec + Ast.OnConflictSpec + Ast.OpSpec + Ast.OptOrdinalitySpec + Ast.OptTempTableNameSpec + Ast.OptVaryingSpec + Ast.OverClauseSpec + Ast.OverlayListSpec + Ast.OverrideKindSpec + Ast.PositionListSpec + Ast.PreparableStmtSpec + Ast.QualAllOpSpec + Ast.QualifiedNameSpec + Ast.QualOpSpec + Ast.RelationExprOptAliasSpec + Ast.RelationExprSpec + Ast.ReturningClauseSpec + Ast.RowsfromItemSpec + Ast.RowsfromListSpec + Ast.RowSpec + Ast.SconstSpec + Ast.SelectBinOpSpec + Ast.SelectClauseSpec + Ast.SelectFetchFirstValueSpec + Ast.SelectLimitSpec + Ast.SelectLimitValueSpec + Ast.SelectNoParensSpec + Ast.SelectStmtSpec + Ast.SelectWithParensSpec + Ast.SetClauseListSpec + Ast.SetClauseSpec + Ast.SetTargetListSpec + Ast.SetTargetSpec + Ast.SimpleSelectSpec + Ast.SimpleTypenameSpec + Ast.SortBySpec + Ast.SortClauseSpec + Ast.SubqueryOpSpec + Ast.SubstrListFromForSpec + Ast.SubstrListSpec + Ast.SubTypeSpec + Ast.SymbolicExprBinOpSpec + Ast.TableFuncElementListSpec + Ast.TableFuncElementSpec + Ast.TableRefSpec + Ast.TablesampleClauseSpec + Ast.TargetElSpec + Ast.TargetingSpec + Ast.TargetListSpec + Ast.TimezoneSpec + Ast.TrimListSpec + Ast.TrimModifierSpec + Ast.TypeListSpec + Ast.TypenameArrayDimensionsSpec + Ast.TypenameSpec + Ast.UpdateStmtSpec + Ast.UsingClauseSpec + Ast.ValuesClauseSpec + Ast.VerbalExprBinOpSpec + Ast.WhenClauseListSpec + Ast.WhenClauseSpec + Ast.WhereClauseSpec + Ast.WhereOrCurrentClauseSpec + Ast.WindowClauseSpec + Ast.WindowDefinitionSpec + Ast.WindowExclusionClauseSpec + Ast.WindowSpecificationSpec + Ast.WithClauseSpec + Ast.XconstSpec + Helpers.Expectations + Helpers.Specs + Spec + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + + build-tool-depends: + hspec-discover:hspec-discover >=2.10 && <3 + build-depends: - hedgehog >=1.0.1 && <2, - postgresql-syntax, + hspec >=2.10 && <3, + megaparsec >=9.2 && <10, + postgresql-syntax:internal, + QuickCheck >=2.17 && <3, rerebase >=1.6.1 && <2, benchmark keyword-bench @@ -122,18 +435,16 @@ 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, + QuickCheck >=2.17 && <3, rerebase >=1.6.1 && <2, benchmark nesting-bench @@ -147,6 +458,5 @@ 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 deleted file mode 100644 --- a/tasty-test/Main.hs +++ /dev/null @@ -1,157 +0,0 @@ -module Main where - -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) - -main :: IO () -main = - defaultMain - $ testGroup - "" - [ testGroup "Parsers" - $ let testParserOnAllInputs parserName parser inputs = - testCase parserName - $ forM_ inputs - $ \input -> case Parsing.run parser input of - Left err -> assertFailure (err <> "\ninput: " <> Text.unpack input) - Right _ -> return () - in [ testParserOnAllInputs - "preparableStmt" - Parsing.preparableStmt - [ "select i :: int8 from auth.user as u\n\ - \inner join edgenode.usere_provider as p\n\ - \on u.id = p.user_id\n\ - \inner join edgenode.provider_branch as b\n\ - \on b.provider_fk = p.provider_id", - -- FOR locking clause before LIMIT (PostgreSQL accepts both orderings) - "select * from items for update limit 1", - "select * from items limit 1 for update", - "select * from items for share limit 10", - "select * from items for no key update limit 1", - "select * from items for key share limit 1", - "select * from items for update of items nowait limit 1", - "select * from items for update skip locked limit 1", - "select * from items order by id for update limit 1", - "select * from items for update offset 5 limit 10" - ], - testParserOnAllInputs - "typename" - Parsing.typename - [ "int4[]", - "int4[][]", - "int4?[]", - "int4?[]?", - "aa array", - "DOUBLE PRECISION", - "bool", - "int2", - "int4", - "int8", - "float4", - "float8", - "numeric", - "char", - "text", - "bytea", - "date", - "timestamp", - "timestamptz", - "time", - "timetz", - "interval", - "uuid", - "inet", - "json", - "jsonb" - ], - testParserOnAllInputs - "sconst" - Parsing.sconst - [ "'it''s good'", - "$$it's good$$", - "$x$it's good$x$" - ] - ], - testGroup "Nesting depth" nestingTests, - testGroup "Error reporting" - $ let testParserOnAllInputs parserName parser inputs res = - testCase parserName - $ forM_ inputs - $ \input -> case Parsing.runWithPosError parser input of - Left err -> show (NonEmpty.head err) @?= res - Right _ -> return () - in [ testParserOnAllInputs - "Typo in FROM keyword" - Parsing.preparableStmt - [ "select i :: int8 fom auth.user as u\n\ - \inner join edgenode.usere_provider as p\n\ - \on u.id = p.user_id\n\ - \inner join edgenode.provider_branch as b\n\ - \on b.provider_fk = p.provider_id" - ] - "(20,\"offset=20:\\nunexpected space\\nexpecting end of input\\n\")", - testParserOnAllInputs - "Typo in NOT keyword" - Parsing.preparableStmt - [ "select i :: int8 from auth.user as u\n\ - \WHERE u.id IS NO NULL && TRUE" - ] - "(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 ()