{-|

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 PostgresqlSyntax.Prelude hiding (expr, try, option, some, many, sortBy, filter, head, tail, bit, fromList)
import HeadedMegaparsec hiding (string)
import Control.Applicative.Combinators hiding (some)
import Control.Applicative.Combinators.NonEmpty
import PostgresqlSyntax.Extras.HeadedMegaparsec hiding (run)
import PostgresqlSyntax.Ast
import Text.Megaparsec (Stream, Parsec)
import qualified PostgresqlSyntax.Extras.HeadedMegaparsec as Extras
import qualified PostgresqlSyntax.Extras.NonEmpty as NonEmpty
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char as MegaparsecChar
import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer
import qualified PostgresqlSyntax.KeywordSet as KeywordSet
import qualified PostgresqlSyntax.Predicate as Predicate
import qualified PostgresqlSyntax.Validation as Validation
import qualified Data.Text as Text
import qualified Data.List.NonEmpty as NonEmpty
import qualified Text.Builder as TextBuilder
import qualified Data.HashSet as HashSet


{- $setup
>>> testParser parser = either putStr print . run parser
-}


type Parser = HeadedParsec Void Text


-- * Executors
-------------------------

run :: Parser a -> Text -> Either String a
run = Extras.run


-- * Helpers
-------------------------

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.run bdr)
    in collectChunks mempty
  return _tail

atEnd :: Parser a -> Parser a
atEnd p = space *> p <* endHead <* space <* eof


-- * PreparableStmt
-------------------------

preparableStmt =
  SelectPreparableStmt <$> selectStmt <|>
  InsertPreparableStmt <$> insertStmt <|>
  UpdatePreparableStmt <$> updateStmt <|>
  DeletePreparableStmt <$> deleteStmt


-- * 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\".
-}
{-
  | 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
-------------------------

{-
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

{-
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

{-
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

{-
  |  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

    {-
    | relation_expr opt_alias_clause
    | relation_expr opt_alias_clause tablesample_clause
    -}
    relationExprTableRef = do
      _relationExpr <- relationExpr
      endHead
      _optAliasClause <- optional (space1 *> aliasClause)
      _optTablesampleClause <- optional (space1 *> tablesampleClause)
      return (RelationExprTableRef _relationExpr _optAliasClause _optTablesampleClause)

    {-
    | LATERAL_P func_table func_alias_clause
    | LATERAL_P xmltable opt_alias_clause
    | LATERAL_P select_with_parens opt_alias_clause
    TODO: add xmltable
    -}
    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
        ]

{-
  | '(' joined_table ')'
-}
inParensJoinedTable = InParensJoinedTable <$> inParens joinedTable

{-
  | 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
  aExpr = customizedAExpr cExpr
  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

{-
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
-}
{-
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 '\''

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

{-
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
-------------------------

{-
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)
    ]

{-
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

{-
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
-------------------------

{-
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

{-
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)

{-
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

{-
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)

{-
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)

{-
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
-}
{-
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

{-
func_name:
  | type_function_name
  | ColId indirection
-}
funcName =
  IndirectedFuncName <$> wrapToHead colId <*> (space *> indirection) <|>
  TypeFuncName <$> typeFunctionName

{-
type_function_name:
  | IDENT
  | unreserved_keyword
  | type_func_name_keyword
-}
typeFunctionName =
  keywordNameFromSet KeywordSet.typeFunctionName <|>
  ident

{-
indirection:
  | indirection_el
  | indirection indirection_el
-}
indirection = some indirectionEl

{-
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
    ]

{-
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")