postgresql-syntax-0.4.3: library/PostgresqlSyntax/Parsing.hs
{-# 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 (WithParensSelectWithParens <$> selectWithParens <|> NoParensSelectWithParens <$> selectNoParens)
selectNoParens = withSelectNoParens <|> simpleSelectNoParens
sharedSelectNoParens with = do
select <- selectClause
sort <- optional (space1 *> sortClause)
limit <- optional (space1 *> selectLimit)
forLocking <- optional (space1 *> forLockingClause)
return (SelectNoParens with select sort limit 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 = suffixRec base suffix
where
base =
asum
[ Right <$> selectWithParens,
Left <$> baseSimpleSelect
]
suffix 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),
OverlapsAExpr <$> wrapToHead row <*> (space1 *> keyword "overlaps" *> space1 *> endHead *> row),
qualOpExpr aExpr PrefixQualOpAExpr,
PlusAExpr <$> plusedExpr aExpr,
MinusAExpr <$> minusedExpr aExpr,
NotAExpr <$> (keyword "not" *> space1 *> aExpr),
CExprAExpr <$> cExpr
]
suffix a =
asum
[ 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")
]
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,
ImplicitRowCExpr <$> implicitRow,
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),
InParensCExpr <$> (inParens aExpr <* endHead) <*> optional (space *> indirection),
AexprConstCExpr <$> wrapToHead aexprConst,
FuncCExpr <$> funcExpr,
ColumnrefCExpr <$> columnref
]
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 = SelectInExpr <$> wrapToHead selectWithParens <|> ExprListInExpr <$> inParens exprList
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
]
funcApplication = 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
keyword a = mfilter (a ==) anyKeyword
-- |
-- 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")