simple-sql-parser/Language/SQL/SimpleSQL/Parser.lhs

TODO:
P -> P.Parser
swap order in select items

> {-# LANGUAGE TupleSections #-}
> -- | This is the module with the parser functions.
> module Language.SQL.SimpleSQL.Parser
>     (parseQueryExpr
>     ,parseValueExpr
>     ,parseQueryExprs
>     ,ParseError(..)) where

> import Control.Monad.Identity (Identity)
> import Control.Monad (guard, void)
> import Control.Applicative ((<$), (<$>), (<*>) ,(<*), (*>))
> import Data.Maybe (fromMaybe,catMaybes)
> import Data.Char (toLower)
> import Text.Parsec (errorPos,sourceLine,sourceColumn,sourceName
>                    ,setPosition,setSourceColumn,setSourceLine,getPosition
>                    ,option,between,sepBy,sepBy1,string,manyTill,anyChar
>                    ,try,string,many1,oneOf,digit,(<|>),choice,char,eof
>                    ,optionMaybe,optional,many,letter,alphaNum,parse)
> import Text.Parsec.String (Parser)
> import qualified Text.Parsec as P (ParseError)
> import Text.Parsec.Perm (permute,(<$?>), (<|?>))
> import qualified Text.Parsec.Expr as E

> import Language.SQL.SimpleSQL.Syntax

The public API functions.

> -- | Parses a query expr, trailing semicolon optional.
> parseQueryExpr :: FilePath
>                   -- ^ filename to use in errors
>                -> Maybe (Int,Int)
>                   -- ^ line number and column number to use in errors
>                -> String
>                   -- ^ the SQL source to parse
>                -> Either ParseError QueryExpr
> parseQueryExpr = wrapParse topLevelQueryExpr

> -- | Parses a list of query exprs, with semi colons between
> -- them. The final semicolon is optional.
> parseQueryExprs :: FilePath
>                    -- ^ filename to use in errors
>                 -> Maybe (Int,Int)
>                    -- ^ line number and column number to use in errors
>                 -> String
>                    -- ^ the SQL source to parse
>                 -> Either ParseError [QueryExpr]
> parseQueryExprs = wrapParse queryExprs

> -- | Parses a value expression.
> parseValueExpr :: FilePath
>                    -- ^ filename to use in errors
>                 -> Maybe (Int,Int)
>                    -- ^ line number and column number to use in errors
>                 -> String
>                    -- ^ the SQL source to parse
>                 -> Either ParseError ValueExpr
> parseValueExpr = wrapParse valueExpr

This helper function takes the parser given and:

sets the position when parsing
automatically skips leading whitespace
checks the parser parses all the input using eof
converts the error return to the nice wrapper

> wrapParse :: Parser a
>           -> FilePath
>           -> Maybe (Int,Int)
>           -> String
>           -> Either ParseError a
> wrapParse parser f p src =
>     either (Left . convParseError src) Right
>     $ parse (setPos p *> whiteSpace *> parser <* eof) f src

> -- | Type to represent parse errors.
> data ParseError = ParseError
>                   {peErrorString :: String
>                    -- ^ contains the error message
>                   ,peFilename :: FilePath
>                    -- ^ filename location for the error
>                   ,pePosition :: (Int,Int)
>                    -- ^ line number and column number location for the error
>                   ,peFormattedError :: String
>                    -- ^ formatted error with the position, error
>                    -- message and source context
>                   } deriving (Eq,Show)

------------------------------------------------

= value expressions

== literals

See the stringLiteral lexer below for notes on string literal syntax.

> estring :: Parser ValueExpr
> estring = StringLit <$> stringLiteral

> number :: Parser ValueExpr
> number = NumLit <$> numberLiteral

parse SQL interval literals, something like
interval '5' day (3)
or
interval '5' month

wrap the whole lot in try, in case we get something like this:
interval '3 days'
which parses as a typed literal

> interval :: Parser ValueExpr
> interval = try (keyword_ "interval" >>
>     IntervalLit
>     <$> stringLiteral
>     <*> identifierString
>     <*> optionMaybe (try $ parens integerLiteral))

> literal :: Parser ValueExpr
> literal = number <|> estring <|> interval

== identifiers

Uses the identifierString 'lexer'. See this function for notes on
identifiers.

> name :: Parser Name
> name = choice [QName <$> quotedIdentifier
>               ,Name <$> identifierString]

> identifier :: Parser ValueExpr
> identifier = Iden <$> name

== star

used in select *, select x.*, and agg(*) variations, and some other
places as well. Because it is quite general, the parser doesn't
attempt to check that the star is in a valid context, it parses it OK
in any value expression context.

> star :: Parser ValueExpr
> star = Star <$ symbol "*"

== parameter

use in e.g. select * from t where a = ?

> parameter :: Parser ValueExpr
> parameter = Parameter <$ symbol "?"

== function application, aggregates and windows

this represents anything which syntactically looks like regular C
function application: an identifier, parens with comma sep value
expression arguments.

The parsing for the aggregate extensions is here as well:

aggregate([all|distinct] args [order by orderitems])

> aggOrApp :: Parser ValueExpr
> aggOrApp =
>     makeApp
>     <$> name
>     <*> parens ((,,) <$> try duplicates
>                      <*> choice [commaSep valueExpr]
>                      <*> try (optionMaybe orderBy))
>   where
>     makeApp i (Nothing,es,Nothing) = App i es
>     makeApp i (d,es,od) = AggregateApp i d es (fromMaybe [] od)

> duplicates :: Parser (Maybe SetQuantifier)
> duplicates = optionMaybe $ try $
>     choice [All <$ keyword_ "all"
>            ,Distinct <$ keyword "distinct"]

parse a window call as a suffix of a regular function call
this looks like this:
functionname(args) over ([partition by ids] [order by orderitems])

No support for explicit frames yet.

The convention in this file is that the 'Suffix', erm, suffix on
parser names means that they have been left factored. These are almost
always used with the optionSuffix combinator.

> windowSuffix :: ValueExpr -> Parser ValueExpr
> windowSuffix (App f es) =
>     try (keyword_ "over")
>     *> parens (WindowApp f es
>                <$> option [] partitionBy
>                <*> option [] orderBy
>                <*> optionMaybe frameClause)
>   where
>     partitionBy = try (keyword_ "partition") >>
>         keyword_ "by" >> commaSep1 valueExpr
>     frameClause =
>         mkFrame <$> choice [FrameRows <$ keyword_ "rows"
>                            ,FrameRange <$ keyword_ "range"]
>                 <*> frameStartEnd
>     frameStartEnd =
>         choice
>         [try (keyword_ "between") >>
>          mkFrameBetween <$> frameLimit True
>                         <*> (keyword_ "and" *> frameLimit True)
>         ,mkFrameFrom <$> frameLimit False]
>     -- use the bexpression style from the between parsing for frame between
>     frameLimit useB =
>         choice
>         [Current <$ try (keyword_ "current") <* keyword_ "row"
>         ,try (keyword_ "unbounded") >>
>          choice [UnboundedPreceding <$ keyword_ "preceding"
>                 ,UnboundedFollowing <$ keyword_ "following"]
>         ,do
>          e <- if useB then valueExprB else valueExpr
>          choice [Preceding e <$ keyword_ "preceding"
>                 ,Following e <$ keyword_ "following"]
>         ]
>     mkFrameBetween s e rs = FrameBetween rs s e
>     mkFrameFrom s rs = FrameFrom rs s
>     mkFrame rs c = c rs
> windowSuffix _ = fail ""

> app :: Parser ValueExpr
> app = aggOrApp >>= optionSuffix windowSuffix

== case expression

> scase :: Parser ValueExpr
> scase =
>     Case <$> (try (keyword_ "case") *> optionMaybe (try valueExpr))
>          <*> many1 swhen
>          <*> optionMaybe (try (keyword_ "else") *> valueExpr)
>          <* keyword_ "end"
>   where
>     swhen = keyword_ "when" *>
>             ((,) <$> commaSep1 valueExpr
>                  <*> (keyword_ "then" *> valueExpr))

== miscellaneous keyword operators

These are keyword operators which don't look like normal prefix,
postfix or infix binary operators. They mostly look like function
application but with keywords in the argument list instead of commas
to separate the arguments.

cast: cast(expr as type)

> cast :: Parser ValueExpr
> cast = parensCast <|> prefixCast
>   where
>     parensCast = try (keyword_ "cast") >>
>                  parens (Cast <$> valueExpr
>                          <*> (keyword_ "as" *> typeName))
>     prefixCast = try (TypedLit <$> typeName
>                              <*> stringLiteral)

the special op keywords
parse an operator which is
operatorname(firstArg keyword0 arg0 keyword1 arg1 etc.)

> data SpecialOpKFirstArg = SOKNone
>                         | SOKOptional
>                         | SOKMandatory

> specialOpK :: String -- name of the operator
>            -> SpecialOpKFirstArg -- has a first arg without a keyword
>            -> [(String,Bool)] -- the other args with their keywords
>                               -- and whether they are optional
>            -> Parser ValueExpr
> specialOpK opName firstArg kws =
>     keyword_ opName >> do
>     void $ symbol  "("
>     let pfa = do
>               e <- valueExpr
>               -- check we haven't parsed the first
>               -- keyword as an identifier
>               guard (case (e,kws) of
>                   (Iden (Name i), ((k,_):_)) | map toLower i == k -> False
>                   _ -> True)
>               return e
>     fa <- case firstArg of
>          SOKNone -> return Nothing
>          SOKOptional -> optionMaybe (try pfa)
>          SOKMandatory -> Just <$> pfa
>     as <- mapM parseArg kws
>     void $ symbol ")"
>     return $ SpecialOpK (Name opName) fa $ catMaybes as
>   where
>     parseArg (nm,mand) =
>         let p = keyword_ nm >> valueExpr
>         in fmap (nm,) <$> if mand
>                           then Just <$> p
>                           else optionMaybe (try p)

The actual operators:

EXTRACT( date_part FROM expression )

POSITION( string1 IN string2 )

SUBSTRING(extraction_string FROM starting_position [FOR length]
[COLLATE collation_name])

CONVERT(char_value USING conversion_char_name)

TRANSLATE(char_value USING translation_name)

OVERLAY(string PLACING embedded_string FROM start
[FOR length])

TRIM( [ [{LEADING | TRAILING | BOTH}] [removal_char] FROM ]
target_string
[COLLATE collation_name] )

> specialOpKs :: Parser ValueExpr
> specialOpKs = choice $ map try
>     [extract, position, substring, convert, translate, overlay, trim]

> extract :: Parser ValueExpr
> extract = specialOpK "extract" SOKMandatory [("from", True)]

> position :: Parser ValueExpr
> position = specialOpK "position" SOKMandatory [("in", True)]

strictly speaking, the substring must have at least one of from and
for, but the parser doens't enforce this

> substring :: Parser ValueExpr
> substring = specialOpK "substring" SOKMandatory
>                 [("from", False),("for", False),("collate", False)]

> convert :: Parser ValueExpr
> convert = specialOpK "convert" SOKMandatory [("using", True)]


> translate :: Parser ValueExpr
> translate = specialOpK "translate" SOKMandatory [("using", True)]

> overlay :: Parser ValueExpr
> overlay = specialOpK "overlay" SOKMandatory
>                 [("placing", True),("from", True),("for", False)]

trim is too different because of the optional char, so a custom parser
the both ' ' is filled in as the default if either parts are missing
in the source

> trim :: Parser ValueExpr
> trim =
>     keyword "trim" >>
>     parens (mkTrim
>             <$> option "both" sides
>             <*> option " " stringLiteral
>             <*> (keyword_ "from" *> valueExpr)
>             <*> optionMaybe (keyword_ "collate" *> stringLiteral))
>   where
>     sides = choice ["leading" <$ keyword_ "leading"
>                    ,"trailing" <$ keyword_ "trailing"
>                    ,"both" <$ keyword_ "both"]
>     mkTrim fa ch fr cl =
>       SpecialOpK (Name "trim") Nothing
>           $ catMaybes [Just (fa,StringLit ch)
>                       ,Just ("from", fr)
>                       ,fmap (("collate",) . StringLit) cl]

in: two variations:
a in (expr0, expr1, ...)
a in (queryexpr)

this is parsed as a postfix operator which is why it is in this form

> inSuffix :: Parser (ValueExpr -> ValueExpr)
> inSuffix =
>     mkIn <$> inty
>          <*> parens (choice
>                      [InQueryExpr <$> queryExpr
>                      ,InList <$> commaSep1 valueExpr])
>   where
>     inty = try $ choice [True <$ keyword_ "in"
>                         ,False <$ keyword_ "not" <* keyword_ "in"]
>     mkIn i v = \e -> In i e v


between:
expr between expr and expr

There is a complication when parsing between - when parsing the second
expression it is ambiguous when you hit an 'and' whether it is a
binary operator or part of the between. This code follows what
postgres does, which might be standard across SQL implementations,
which is that you can't have a binary and operator in the middle
expression in a between unless it is wrapped in parens. The 'bExpr
parsing' is used to create alternative value expression parser which
is identical to the normal one expect it doesn't recognise the binary
and operator. This is the call to valueExprB.

> betweenSuffix :: Parser (ValueExpr -> ValueExpr)
> betweenSuffix =
>     makeOp <$> (Name <$> opName)
>            <*> valueExprB
>            <*> (keyword_ "and" *> valueExprB)
>   where
>     opName = try $ choice
>              ["between" <$ keyword_ "between"
>              ,"not between" <$ keyword_ "not" <* keyword_ "between"]
>     makeOp n b c = \a -> SpecialOp n [a,b,c]

subquery expression:
[exists|all|any|some] (queryexpr)

> subquery :: Parser ValueExpr
> subquery =
>     choice
>     [try $ SubQueryExpr SqSq <$> parens queryExpr
>     ,SubQueryExpr <$> try sqkw <*> parens queryExpr]
>   where
>     sqkw = try $ choice
>            [SqExists <$ keyword_ "exists"
>            ,SqAll <$ try (keyword_ "all")
>            ,SqAny <$ keyword_ "any"
>            ,SqSome <$ keyword_ "some"]

typename: used in casts. Special cases for the multi keyword typenames
that SQL supports.

> typeName :: Parser TypeName
> typeName = choice (multiWordParsers
>                    ++ [TypeName <$> identifierString])
>            >>= optionSuffix precision
>   where
>     multiWordParsers =
>         flip map multiWordTypeNames
>         $ \ks -> (TypeName . unwords) <$> try (mapM keyword ks)
>     multiWordTypeNames = map words
>         ["double precision"
>         ,"character varying"
>         ,"char varying"
>         ,"character large object"
>         ,"char large object"
>         ,"national character"
>         ,"national char"
>         ,"national character varying"
>         ,"national char varying"
>         ,"national character large object"
>         ,"nchar large object"
>         ,"nchar varying"
>         ,"bit varying"
>         ]

todo: timestamp types:

    | TIME [ <left paren> <time precision> <right paren> ] [ WITH TIME ZONE ]
     | TIMESTAMParser [ <left paren> <timestamp precision> <right paren> ] [ WITH TIME ZONE ]


>     precision t = try (parens (commaSep integerLiteral)) >>= makeWrap t
>     makeWrap (TypeName t) [a] = return $ PrecTypeName t a
>     makeWrap (TypeName t) [a,b] = return $ PrecScaleTypeName t a b
>     makeWrap _ _ = fail "there must be one or two precision components"


== value expression parens and row ctor

> sparens :: Parser ValueExpr
> sparens =
>     ctor <$> parens (commaSep1 valueExpr)
>   where
>     ctor [a] = Parens a
>     ctor as = SpecialOp (Name "rowctor") as


== operator parsing

The 'regular' operators in this parsing and in the abstract syntax are
unary prefix, unary postfix and binary infix operators. The operators
can be symbols (a + b), single keywords (a and b) or multiple keywords
(a is similar to b).

> opTable :: Bool -> [[E.Operator String () Identity ValueExpr]]
> opTable bExpr =
>         [[binarySym "." E.AssocLeft]
>         ,[prefixSym "+", prefixSym "-"]
>         ,[binarySym "^" E.AssocLeft]
>         ,[binarySym "*" E.AssocLeft
>          ,binarySym "/" E.AssocLeft
>          ,binarySym "%" E.AssocLeft]
>         ,[binarySym "+" E.AssocLeft
>          ,binarySym "-" E.AssocLeft]
>         ,[binarySym ">=" E.AssocNone
>          ,binarySym "<=" E.AssocNone
>          ,binarySym "!=" E.AssocRight
>          ,binarySym "<>" E.AssocRight
>          ,binarySym "||" E.AssocRight
>          ,prefixSym "~"
>          ,binarySym "&" E.AssocRight
>          ,binarySym "|" E.AssocRight
>          ,binaryKeyword "like" E.AssocNone
>          ,binaryKeyword "overlaps" E.AssocNone]
>          ++ map (flip binaryKeywords E.AssocNone)
>          ["not like"
>          ,"is similar to"
>          ,"is not similar to"
>          ,"is distinct from"
>          ,"is not distinct from"]
>          ++ map postfixKeywords
>          ["is null"
>          ,"is not null"
>          ,"is true"
>          ,"is not true"
>          ,"is false"
>          ,"is not false"
>          ,"is unknown"
>          ,"is not unknown"]
>           ++ [E.Postfix $ try inSuffix,E.Postfix $ try betweenSuffix]
>         ]
>         ++
>         [[binarySym "<" E.AssocNone
>          ,binarySym ">" E.AssocNone]
>         ,[binarySym "=" E.AssocRight]
>         ,[prefixKeyword "not"]]
>         ++
>         if bExpr then [] else [[binaryKeyword "and" E.AssocLeft]]
>         ++
>         [[binaryKeyword "or" E.AssocLeft]]
>   where
>     binarySym nm assoc = binary (try $ symbol_ nm) nm assoc
>     binaryKeyword nm assoc = binary (try $ keyword_ nm) nm assoc
>     binaryKeywords nm assoc = binary (try $ mapM_ keyword_ (words nm)) nm assoc
>     binary p nm assoc =
>       E.Infix (p >> return (\a b -> BinOp a (Name nm) b)) assoc
>     prefixKeyword nm = prefix (try $ keyword_ nm) nm
>     prefixSym nm = prefix (try $ symbol_ nm) nm
>     prefix p nm = E.Prefix (p >> return (PrefixOp (Name nm)))
>     postfixKeywords nm = postfix (try $ mapM_ keyword_ (words nm)) nm
>     postfix p nm = E.Postfix (p >> return (PostfixOp (Name nm)))

== value expressions

TODO:
left factor stuff which starts with identifier

This parses most of the value exprs.The order of the parsers and use
of try is carefully done to make everything work. It is a little
fragile and could at least do with some heavy explanation.

> valueExpr :: Parser ValueExpr
> valueExpr = E.buildExpressionParser (opTable False) term

> term :: Parser ValueExpr
> term = choice [literal
>               ,parameter
>               ,scase
>               ,cast
>               ,try specialOpKs
>               ,subquery
>               ,try app
>               ,try star
>               ,identifier
>               ,sparens]

expose the b expression for window frame clause range between

> valueExprB :: Parser ValueExpr
> valueExprB = E.buildExpressionParser (opTable True) term


-------------------------------------------------

= query expressions

== select lists

> selectItem :: Parser (Maybe Name, ValueExpr)
> selectItem = flip (,) <$> valueExpr <*> optionMaybe (try als)
>   where als = optional (try (keyword_ "as")) *> name

> selectList :: Parser [(Maybe Name,ValueExpr)]
> selectList = commaSep1 selectItem

== from

Here is the rough grammar for joins

tref
(cross | [natural] ([inner] | (left | right | full) [outer])) join
tref
[on expr | using (...)]

> from :: Parser [TableRef]
> from = try (keyword_ "from") *> commaSep1 tref
>   where
>     tref = nonJoinTref >>= optionSuffix joinTrefSuffix
>     nonJoinTref = choice [try (TRQueryExpr <$> parens queryExpr)
>                          ,TRParens <$> parens tref
>                          ,TRLateral <$> (try (keyword_ "lateral")
>                                          *> nonJoinTref)
>                          ,try (TRFunction <$> name
>                                           <*> parens (commaSep valueExpr))
>                          ,TRSimple <$> name]
>                   >>= optionSuffix aliasSuffix
>     aliasSuffix j = option j (TRAlias j <$> alias)
>     joinTrefSuffix t = (do
>          nat <- option False $ try (True <$ try (keyword_ "natural"))
>          TRJoin t <$> joinType
>                   <*> nonJoinTref
>                   <*> optionMaybe (joinCondition nat))
>         >>= optionSuffix joinTrefSuffix
>     joinType =
>         choice [choice
>                 [JCross <$ try (keyword_ "cross")
>                 ,JInner <$ try (keyword_ "inner")
>                 ,choice [JLeft <$ try (keyword_ "left")
>                         ,JRight <$ try (keyword_ "right")
>                         ,JFull <$ try (keyword_ "full")]
>                  <* optional (try $ keyword_ "outer")]
>                 <* keyword "join"
>                ,JInner <$ keyword_ "join"]
>     joinCondition nat =
>         choice [guard nat >> return JoinNatural
>                ,try (keyword_ "on") >>
>                 JoinOn <$> valueExpr
>                ,try (keyword_ "using") >>
>                 JoinUsing <$> parens (commaSep1 name)
>                ]

> alias :: Parser Alias
> alias = Alias <$> try tableAlias <*> try columnAliases
>   where
>     tableAlias = optional (try $ keyword_ "as") *> name
>     columnAliases = optionMaybe $ try $ parens $ commaSep1 name

== simple other parts

Parsers for where, group by, having, order by and limit, which are
pretty trivial.

Here is a helper for parsing a few parts of the query expr (currently
where, having, limit, offset).

> keywordValueExpr :: String -> Parser ValueExpr
> keywordValueExpr k = try (keyword_ k) *> valueExpr

> swhere :: Parser ValueExpr
> swhere = keywordValueExpr "where"

> sgroupBy :: Parser [GroupingExpr]
> sgroupBy = try (keyword_ "group")
>            *> keyword_ "by"
>            *> commaSep1 groupingExpression
>   where
>     groupingExpression =
>       choice
>       [try (keyword_ "cube") >>
>        Cube <$> parens (commaSep groupingExpression)
>       ,try (keyword_ "rollup") >>
>        Rollup <$> parens (commaSep groupingExpression)
>       ,GroupingParens <$> parens (commaSep groupingExpression)
>       ,try (keyword_ "grouping") >> keyword_ "sets" >>
>        GroupingSets <$> parens (commaSep groupingExpression)
>       ,SimpleGroup <$> valueExpr
>       ]

> having :: Parser ValueExpr
> having = keywordValueExpr "having"

> orderBy :: Parser [SortSpec]
> orderBy = try (keyword_ "order") *> keyword_ "by" *> commaSep1 ob
>   where
>     ob = SortSpec
>          <$> valueExpr
>          <*> option Asc (choice [Asc <$ keyword_ "asc"
>                                 ,Desc <$ keyword_ "desc"])
>          <*> option NullsOrderDefault
>              (try (keyword_ "nulls" >>
>                     choice [NullsFirst <$ keyword "first"
>                            ,NullsLast <$ keyword "last"]))

allows offset and fetch in either order
+ postgresql offset without row(s) and limit instead of fetch also

> offsetFetch :: Parser (Maybe ValueExpr, Maybe ValueExpr)
> offsetFetch = permute ((,) <$?> (Nothing, Just <$> offset)
>                            <|?> (Nothing, Just <$> fetch))

> offset :: Parser ValueExpr
> offset = try (keyword_ "offset") *> valueExpr
>          <* option () (try $ choice [try (keyword_ "rows"),keyword_ "row"])

> fetch :: Parser ValueExpr
> fetch = choice [ansiFetch, limit]
>   where
>     ansiFetch = try (keyword_ "fetch") >>
>         choice [keyword_ "first",keyword_ "next"]
>         *> valueExpr
>         <* choice [keyword_ "rows",keyword_ "row"]
>         <* keyword_ "only"
>     limit = try (keyword_ "limit") *> valueExpr

== common table expressions

> with :: Parser QueryExpr
> with = try (keyword_ "with") >>
>     With <$> option False (try (True <$ keyword_ "recursive"))
>          <*> commaSep1 withQuery <*> queryExpr
>   where
>     withQuery =
>         (,) <$> (alias <* optional (try $ keyword_ "as"))
>             <*> parens queryExpr

== query expression

This parser parses any query expression variant: normal select, cte,
and union, etc..

> queryExpr :: Parser QueryExpr
> queryExpr =
>   choice [with
>          ,choice [values,table, select]
>           >>= optionSuffix queryExprSuffix]
>   where
>     select = try (keyword_ "select") >>
>         mkSelect
>         <$> (fromMaybe All <$> duplicates)
>         <*> selectList
>         <*> option [] from
>         <*> optionMaybe swhere
>         <*> option [] sgroupBy
>         <*> optionMaybe having
>         <*> option [] orderBy
>         <*> offsetFetch
>     mkSelect d sl f w g h od (ofs,fe) =
>         Select d sl f w g h od ofs fe
>     values = try (keyword_ "values")
>              >> Values <$> commaSep (parens (commaSep valueExpr))
>     table = try (keyword_ "table") >> Table <$> name

> queryExprSuffix :: QueryExpr -> Parser QueryExpr
> queryExprSuffix qe =
>     (CombineQueryExpr qe
>      <$> try (choice
>               [Union <$ keyword_ "union"
>               ,Intersect <$ keyword_ "intersect"
>               ,Except <$ keyword_ "except"])
>      <*> (fromMaybe All <$> duplicates)
>      <*> option Respectively
>                 (try (Corresponding <$ keyword_ "corresponding"))
>      <*> queryExpr)
>     >>= optionSuffix queryExprSuffix

wrapper for query expr which ignores optional trailing semicolon.

> topLevelQueryExpr :: Parser QueryExpr
> topLevelQueryExpr =
>      queryExpr >>= optionSuffix ((symbol ";" *>) . return)

wrapper to parse a series of query exprs from a single source. They
must be separated by semicolon, but for the last expression, the
trailing semicolon is optional.

> queryExprs :: Parser [QueryExpr]
> queryExprs =
>     (:[]) <$> queryExpr
>     >>= optionSuffix ((symbol ";" *>) . return)
>     >>= optionSuffix (\p -> (p++) <$> queryExprs)

------------------------------------------------

= lexing parsers

The lexing is a bit 'virtual', in the usual parsec style. The
convention in this file is to put all the parsers which access
characters directly or indirectly here (i.e. ones which use char,
string, digit, etc.), except for the parsers which only indirectly
access them via these functions, if you follow?

> symbol :: String -> Parser String
> symbol s = string s
>            -- <* notFollowedBy (oneOf "+-/*<>=!|")
>            <* whiteSpace

> symbol_ :: String -> Parser ()
> symbol_ s = symbol s *> return ()

TODO: now that keyword has try in it, a lot of the trys above can be
removed

> keyword :: String -> Parser String
> keyword s = try $ do
>     i <- identifierRaw
>     guard (map toLower i == map toLower s)
>     return i

> keyword_ :: String -> Parser ()
> keyword_ s = keyword s *> return ()

Identifiers are very simple at the moment: start with a letter or
underscore, and continue with letter, underscore or digit. It doesn't
support quoting other other sorts of identifiers yet. There is a
blacklist of keywords which aren't supported as identifiers.

the identifier raw doesn't check the blacklist since it is used by the
keyword parser also

> identifierRaw :: Parser String
> identifierRaw = (:) <$> letterOrUnderscore
>                     <*> many letterDigitOrUnderscore <* whiteSpace
>   where
>     letterOrUnderscore = char '_' <|> letter
>     letterDigitOrUnderscore = char '_' <|> alphaNum

> identifierString :: Parser String
> identifierString = do
>     s <- identifierRaw
>     guard (map toLower s `notElem` blacklist)
>     return s

> blacklist :: [String]
> blacklist =
>     ["select", "as", "from", "where", "having", "group", "order"
>     ,"limit", "offset", "fetch"
>     ,"inner", "left", "right", "full", "natural", "join"
>     ,"cross", "on", "using", "lateral"
>     ,"when", "then", "case", "end", "in"
>     ,"except", "intersect", "union"]

These blacklisted names are mostly needed when we parse something with
an optional alias, e.g. select a a from t. If we write select a from
t, we have to make sure the from isn't parsed as an alias. I'm not
sure what other places strictly need the blacklist, and in theory it
could be tuned differently for each place the identifierString/
identifier parsers are used to only blacklist the bare minimum.

> quotedIdentifier :: Parser String
> quotedIdentifier = char '"' *> manyTill anyChar (symbol_ "\"")


String literals: limited at the moment, no escaping \' or other
variations.

> stringLiteral :: Parser String
> stringLiteral = (char '\'' *> manyTill anyChar (char '\'')
>                  >>= optionSuffix moreString) <* whiteSpace
>   where
>     moreString s0 = try $ do
>         void $ char '\''
>         s <- manyTill anyChar (char '\'')
>         optionSuffix moreString (s0 ++ "'" ++ s)

number literals

here is the rough grammar target:

digits
digits.[digits][e[+-]digits]
[digits].digits[e[+-]digits]
digitse[+-]digits

numbers are parsed to strings, not to a numeric type. This is to avoid
making a decision on how to represent numbers, the client code can
make this choice.

> numberLiteral :: Parser String
> numberLiteral =
>     choice [int
>             >>= optionSuffix dot
>             >>= optionSuffix fracts
>             >>= optionSuffix expon
>            ,fract "" >>= optionSuffix expon]
>     <* whiteSpace
>   where
>     int = many1 digit
>     fract p = dot p >>= fracts
>     dot p = (p++) <$> string "."
>     fracts p = (p++) <$> int
>     expon p = concat <$> sequence
>               [return p
>               ,string "e"
>               ,option "" (string "+" <|> string "-")
>               ,int]

lexer for integer literals which appear in some places in SQL

> integerLiteral :: Parser Int
> integerLiteral = read <$> many1 digit <* whiteSpace

whitespace parser which skips comments also

> whiteSpace :: Parser ()
> whiteSpace =
>     choice [simpleWhiteSpace *> whiteSpace
>            ,lineComment *> whiteSpace
>            ,blockComment *> whiteSpace
>            ,return ()]
>   where
>     lineComment = try (string "--")
>                   *> manyTill anyChar (void (char '\n') <|> eof)
>     blockComment = -- no nesting of block comments in SQL
>                    try (string "/*")
>                    -- TODO: why is try used herex
>                    *> manyTill anyChar (try $ string "*/")
>     -- use many1 so we can more easily avoid non terminating loops
>     simpleWhiteSpace = void $ many1 (oneOf " \t\n")

= generic parser helpers

a possible issue with the option suffix is that it enforces left
associativity when chaining it recursively. Have to review
all these uses and figure out if any should be right associative
instead, and create an alternative suffix parser

> optionSuffix :: (a -> Parser a) -> a -> Parser a
> optionSuffix p a = option a (p a)

> parens :: Parser a -> Parser a
> parens = between (symbol_ "(") (symbol_ ")")

> commaSep :: Parser a -> Parser [a]
> commaSep = (`sepBy` symbol_ ",")


> commaSep1 :: Parser a -> Parser [a]
> commaSep1 = (`sepBy1` symbol_ ",")

--------------------------------------------

= helper functions

> setPos :: Maybe (Int,Int) -> Parser ()
> setPos Nothing = return ()
> setPos (Just (l,c)) = fmap f getPosition >>= setPosition
>   where f = flip setSourceColumn c
>             . flip setSourceLine l

> convParseError :: String -> P.ParseError -> ParseError
> convParseError src e =
>     ParseError
>     {peErrorString = show e
>     ,peFilename = sourceName p
>     ,pePosition = (sourceLine p, sourceColumn p)
>     ,peFormattedError = formatError src e
>     }
>   where
>     p = errorPos e

format the error more nicely: emacs format for positioning, plus
context

> formatError :: String -> P.ParseError -> String
> formatError src e =
>     sourceName p ++ ":" ++ show (sourceLine p)
>     ++ ":" ++ show (sourceColumn p) ++ ":"
>     ++ context
>     ++ show e
>   where
>     context =
>         let lns = take 1 $ drop (sourceLine p - 1) $ lines src
>         in case lns of
>              [x] -> "\n" ++ x ++ "\n"
>                     ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"
>              _ -> ""
>     p = errorPos e