{-
The parser uses a separate lexer for two reasons:

1. sql syntax is very awkward to parse, the separate lexer makes it
easier to handle this in most places (in some places it makes it
harder or impossible, the fix is to switch to something better than
parsec)

2. using a separate lexer gives a huge speed boost because it reduces
backtracking. (We could get this by making the parsing code a lot more
complex also.)

3. we can test the lexer relatively exhaustively, then even when we
don't do nearly as comprehensive testing on the syntax level, we still
have a relatively high assurance of the low level of bugs. This is
much more difficult to get parity with when testing the syntax parser
directly without the separately testing lexing stage.

TODO:

optimisations:

check for left factor opportunities
check for places where it parses a few substrings from the source,
  then puts them back together with a concatenate of some flavour
  -> this is better if can find a way to parse the entire string
  from the source and lift it in one go into the lexical token
before this is done, a smaller optimisation is when any code matches
  a constant string in the lexer, use that constant string instead
  of the string from the parser, it might make a small difference in
  a few places
maybe every token should carry the exact source as well as any fields
  it's been broken into - so pretty printing is trivial


make the tokenswill print more dialect accurate. Maybe add symbol
  chars and identifier chars to the dialect definition and use them from
  here

start adding negative / different parse dialect tests

add token tables and tests for oracle, sql server
review existing tables

look for refactoring opportunities, especially the token
generation tables in the tests

do some user documentation on lexing, and lexing/dialects

start thinking about a more separated design for the dialect handling

lexing tests are starting to take a really long time, so split the
tests so it is much easier to run all the tests except the lexing
tests which only need to be run when working on the lexer (which
should be relatively uncommon), or doing a commit or finishing off a
series of commits,

start writing the error message tests:
  generate/write a large number of syntax errors
  create a table with the source and the error message
  try to compare some different versions of code to compare the
    quality of the error messages by hand

  get this checked in so improvements and regressions in the error
    message quality can be tracked a little more easily (although it will
    still be manual)

try again to add annotation to the ast

-}

-- | Lexer for SQL.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeFamilies      #-}
module Language.SQL.SimpleSQL.Lex
    (Token(..)
    ,WithPos(..)
    ,lexSQL
    ,lexSQLWithPositions
    ,prettyToken
    ,prettyTokens
    ,ParseError
    ,prettyError
    ,tokenListWillPrintAndLex
    ,ansi2011
    ,SQLStream(..)
    ) where

import Language.SQL.SimpleSQL.Dialect
    (Dialect(..)
    ,ansi2011
    )

import Text.Megaparsec
    (Parsec
    ,runParser'

    ,PosState(..)
    ,TraversableStream(..)
    ,VisualStream(..)
    
    ,ParseErrorBundle(..)
    ,errorBundlePretty

    ,SourcePos(..)
    ,getSourcePos
    ,getOffset
    ,pstateSourcePos
    ,statePosState
    ,mkPos
    ,hidden
    ,setErrorOffset

    ,choice
    ,satisfy
    ,takeWhileP
    ,takeWhile1P
    ,eof
    ,many
    ,try
    ,option
    ,(<|>)
    ,notFollowedBy
    ,lookAhead
    ,match
    ,optional
    ,label
    ,chunk
    ,region
    ,anySingle
    )
import qualified Text.Megaparsec as M
import Text.Megaparsec.Char
    (string
    ,char
    )
import Text.Megaparsec.State (initialState)

import qualified Data.List          as DL
import qualified Data.List.NonEmpty as NE
import Data.Proxy (Proxy(..))
import Data.Void (Void)

import Data.Char
    (isAlphaNum
    ,isAlpha
    ,isSpace
    ,isDigit
    )
import Control.Monad (void)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
--import Text.Megaparsec.Debug (dbg)

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

-- syntax

-- | Represents a lexed token
data Token
    -- | A symbol (in ansi dialect) is one of the following
    --
    -- * multi char symbols <> \<= \>= != ||
    -- * single char symbols: * + -  < >  ^ / %  ~ & | ? ( ) [ ] , ; ( )
    --
    = Symbol Text
    -- | This is an identifier or keyword. The first field is
    -- the quotes used, or nothing if no quotes were used. The quotes
    -- can be " or u& or something dialect specific like []
    | Identifier (Maybe (Text,Text)) Text
    -- | This is a prefixed variable symbol, such as :var, @var or #var
    -- (only :var is used in ansi dialect)
    | PrefixedVariable Char Text
    -- | This is a positional arg identifier e.g. $1
    | PositionalArg Int
    -- | This is a string literal. The first two fields are the --
    -- start and end quotes, which are usually both ', but can be
    -- the character set (one of nNbBxX, or u&, U&), or a dialect
    -- specific string quoting (such as $$ in postgres)
    | SqlString Text Text Text
    -- | A number literal (integral or otherwise), stored in original format
    -- unchanged
    | SqlNumber Text
    -- | Whitespace, one or more of space, tab or newline.
    | Whitespace Text
    -- | A commented line using --, contains every character starting with the
    -- \'--\' and including the terminating newline character if there is one
    -- - this will be missing if the last line in the source is a line comment
    -- with no trailing newline
    | LineComment Text
    -- | A block comment, \/* stuff *\/, includes the comment delimiters
    | BlockComment Text
    -- | Used for generating better error messages when using the
    --     output of the lexer in a parser
    | InvalidToken Text
      deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq,Int -> Token -> ShowS
[Token] -> ShowS
Token -> [Char]
(Int -> Token -> ShowS)
-> (Token -> [Char]) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> [Char]
show :: Token -> [Char]
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show,Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$c< :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord)

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

-- main api functions

-- | Lex some SQL to a list of tokens. The invalid token setting
-- changes the behaviour so that if there's a parse error at the start
-- of parsing an invalid token, it adds a final InvalidToken with the
-- character to the result then stop parsing. This can then be used to
-- produce a parse error with more context in the parser. Parse errors
-- within tokens still produce Left errors.
lexSQLWithPositions
    :: Dialect
    -- ^ dialect of SQL to use
    -> Bool
    -- ^ produce InvalidToken
    -> Text
    -- ^ filename to use in error messages
    -> Maybe (Int,Int)
    -- ^ line number and column number of the first character
    -- in the source to use in error messages
    -> Text
    -- ^ the SQL source to lex
    -> Either ParseError [WithPos Token]
lexSQLWithPositions :: Dialect
-> Bool
-> Text
-> Maybe (Int, Int)
-> Text
-> Either ParseError [WithPos Token]
lexSQLWithPositions Dialect
dialect Bool
pit Text
fn Maybe (Int, Int)
p Text
src = Text
-> Maybe (Int, Int)
-> Parser [WithPos Token]
-> Text
-> Either ParseError [WithPos Token]
forall a.
Text -> Maybe (Int, Int) -> Parser a -> Text -> Either ParseError a
myParse Text
fn Maybe (Int, Int)
p (Dialect -> Bool -> Parser [WithPos Token]
tokens Dialect
dialect Bool
pit) Text
src

-- | Lex some SQL to a list of tokens.
lexSQL
    :: Dialect
    -- ^ dialect of SQL to use
    -> Bool
    -- ^ produce InvalidToken, see lexSQLWithPositions
    -> Text
    -- ^ filename to use in error messages
    -> Maybe (Int,Int)
    -- ^ line number and column number of the first character
    -- in the source to use in error messages
    -> Text
    -- ^ the SQL source to lex
    -> Either ParseError [Token]
lexSQL :: Dialect
-> Bool
-> Text
-> Maybe (Int, Int)
-> Text
-> Either ParseError [Token]
lexSQL Dialect
dialect Bool
pit Text
fn Maybe (Int, Int)
p Text
src =
    (WithPos Token -> Token) -> [WithPos Token] -> [Token]
forall a b. (a -> b) -> [a] -> [b]
map WithPos Token -> Token
forall a. WithPos a -> a
tokenVal ([WithPos Token] -> [Token])
-> Either ParseError [WithPos Token] -> Either ParseError [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dialect
-> Bool
-> Text
-> Maybe (Int, Int)
-> Text
-> Either ParseError [WithPos Token]
lexSQLWithPositions Dialect
dialect Bool
pit Text
fn Maybe (Int, Int)
p Text
src

myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a
myParse :: forall a.
Text -> Maybe (Int, Int) -> Parser a -> Text -> Either ParseError a
myParse Text
name Maybe (Int, Int)
sp' Parser a
p Text
s =
        let sp :: (Int, Int)
sp = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1,Int
1) Maybe (Int, Int)
sp'
            ps :: SourcePos
ps = [Char] -> Pos -> Pos -> SourcePos
SourcePos (Text -> [Char]
T.unpack Text
name) (Int -> Pos
mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
sp) (Int -> Pos
mkPos (Int -> Pos) -> Int -> Pos
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
sp)
            is :: State Text Void
is = [Char] -> Text -> State Text Void
forall s e. [Char] -> s -> State s e
initialState (Text -> [Char]
T.unpack Text
name) Text
s
            sps :: PosState Text
sps = (State Text Void -> PosState Text
forall s e. State s e -> PosState s
statePosState State Text Void
is) {pstateSourcePos = ps}
            is' :: State Text Void
is' = State Text Void
is {statePosState = sps}
        in (State Text Void, Either ParseError a) -> Either ParseError a
forall a b. (a, b) -> b
snd ((State Text Void, Either ParseError a) -> Either ParseError a)
-> (State Text Void, Either ParseError a) -> Either ParseError a
forall a b. (a -> b) -> a -> b
$ Parser a
-> State Text Void -> (State Text Void, Either ParseError a)
forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
runParser' Parser a
p State Text Void
is'

prettyError :: ParseError -> Text
prettyError :: ParseError -> Text
prettyError = [Char] -> Text
T.pack ([Char] -> Text) -> (ParseError -> [Char]) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty

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

-- parsing boilerplate

type ParseError = ParseErrorBundle Text Void

type Parser = Parsec Void Text

-- | Positional information added to tokens to preserve source positions
-- for the parser
data WithPos a = WithPos
  { forall a. WithPos a -> SourcePos
startPos :: SourcePos
  , forall a. WithPos a -> SourcePos
endPos :: SourcePos
  , forall a. WithPos a -> Int
tokenLength :: Int
  , forall a. WithPos a -> a
tokenVal :: a
  } deriving (WithPos a -> WithPos a -> Bool
(WithPos a -> WithPos a -> Bool)
-> (WithPos a -> WithPos a -> Bool) -> Eq (WithPos a)
forall a. Eq a => WithPos a -> WithPos a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => WithPos a -> WithPos a -> Bool
== :: WithPos a -> WithPos a -> Bool
$c/= :: forall a. Eq a => WithPos a -> WithPos a -> Bool
/= :: WithPos a -> WithPos a -> Bool
Eq, Eq (WithPos a)
Eq (WithPos a) =>
(WithPos a -> WithPos a -> Ordering)
-> (WithPos a -> WithPos a -> Bool)
-> (WithPos a -> WithPos a -> Bool)
-> (WithPos a -> WithPos a -> Bool)
-> (WithPos a -> WithPos a -> Bool)
-> (WithPos a -> WithPos a -> WithPos a)
-> (WithPos a -> WithPos a -> WithPos a)
-> Ord (WithPos a)
WithPos a -> WithPos a -> Bool
WithPos a -> WithPos a -> Ordering
WithPos a -> WithPos a -> WithPos a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (WithPos a)
forall a. Ord a => WithPos a -> WithPos a -> Bool
forall a. Ord a => WithPos a -> WithPos a -> Ordering
forall a. Ord a => WithPos a -> WithPos a -> WithPos a
$ccompare :: forall a. Ord a => WithPos a -> WithPos a -> Ordering
compare :: WithPos a -> WithPos a -> Ordering
$c< :: forall a. Ord a => WithPos a -> WithPos a -> Bool
< :: WithPos a -> WithPos a -> Bool
$c<= :: forall a. Ord a => WithPos a -> WithPos a -> Bool
<= :: WithPos a -> WithPos a -> Bool
$c> :: forall a. Ord a => WithPos a -> WithPos a -> Bool
> :: WithPos a -> WithPos a -> Bool
$c>= :: forall a. Ord a => WithPos a -> WithPos a -> Bool
>= :: WithPos a -> WithPos a -> Bool
$cmax :: forall a. Ord a => WithPos a -> WithPos a -> WithPos a
max :: WithPos a -> WithPos a -> WithPos a
$cmin :: forall a. Ord a => WithPos a -> WithPos a -> WithPos a
min :: WithPos a -> WithPos a -> WithPos a
Ord, Int -> WithPos a -> ShowS
[WithPos a] -> ShowS
WithPos a -> [Char]
(Int -> WithPos a -> ShowS)
-> (WithPos a -> [Char])
-> ([WithPos a] -> ShowS)
-> Show (WithPos a)
forall a. Show a => Int -> WithPos a -> ShowS
forall a. Show a => [WithPos a] -> ShowS
forall a. Show a => WithPos a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> WithPos a -> ShowS
showsPrec :: Int -> WithPos a -> ShowS
$cshow :: forall a. Show a => WithPos a -> [Char]
show :: WithPos a -> [Char]
$cshowList :: forall a. Show a => [WithPos a] -> ShowS
showList :: [WithPos a] -> ShowS
Show)

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

-- pretty print

-- | Pretty printing, if you lex a bunch of tokens, then pretty
-- print them, should should get back exactly the same string
prettyToken :: Dialect -> Token -> Text
prettyToken :: Dialect -> Token -> Text
prettyToken Dialect
_ (Symbol Text
s) = Text
s
prettyToken Dialect
_ (Identifier Maybe (Text, Text)
Nothing Text
t) = Text
t
prettyToken Dialect
_ (Identifier (Just (Text
q1,Text
q2)) Text
t) = Text
q1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q2
prettyToken Dialect
_ (PrefixedVariable Char
c Text
p) = Char -> Text -> Text
T.cons Char
c Text
p
prettyToken Dialect
_ (PositionalArg Int
p) = Char -> Text -> Text
T.cons Char
'$' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
p
prettyToken Dialect
_ (SqlString Text
s Text
e Text
t) = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
prettyToken Dialect
_ (SqlNumber Text
r) = Text
r
prettyToken Dialect
_ (Whitespace Text
t) = Text
t
prettyToken Dialect
_ (LineComment Text
l) = Text
l
prettyToken Dialect
_ (BlockComment Text
c) = Text
c
prettyToken Dialect
_ (InvalidToken Text
t) = Text
t

prettyTokens :: Dialect -> [Token] -> Text
prettyTokens :: Dialect -> [Token] -> Text
prettyTokens Dialect
d [Token]
ts = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Token -> Text) -> [Token] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Dialect -> Token -> Text
prettyToken Dialect
d) [Token]
ts

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

-- token parsers

-- | parser for a sql token
sqlToken :: Dialect -> Parser (WithPos Token)
sqlToken :: Dialect -> Parser (WithPos Token)
sqlToken Dialect
d =
    Parser Token -> Parser (WithPos Token)
forall a. Parser a -> Parser (WithPos a)
withPos (Parser Token -> Parser (WithPos Token))
-> Parser Token -> Parser (WithPos Token)
forall a b. (a -> b) -> a -> b
$ Parser Token -> Parser Token
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ [Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser Token] -> Parser Token) -> [Parser Token] -> Parser Token
forall a b. (a -> b) -> a -> b
$
    [Dialect -> Parser Token
sqlString Dialect
d
    ,Dialect -> Parser Token
identifier Dialect
d
    ,Dialect -> Parser Token
lineComment Dialect
d
    ,Dialect -> Parser Token
blockComment Dialect
d
    ,Dialect -> Parser Token
sqlNumber Dialect
d
    ,Dialect -> Parser Token
positionalArg Dialect
d
    ,Dialect -> Parser Token
dontParseEndBlockComment Dialect
d
    ,Dialect -> Parser Token
prefixedVariable Dialect
d
    ,Dialect -> Parser Token
symbol Dialect
d
    ,Dialect -> Parser Token
sqlWhitespace Dialect
d]

--fakeSourcePos :: SourcePos
--fakeSourcePos = SourcePos "" (mkPos 1) (mkPos 1)

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

-- position and error helpers

withPos :: Parser a -> Parser (WithPos a)
withPos :: forall a. Parser a -> Parser (WithPos a)
withPos Parser a
p = do
    sp <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    off <- getOffset
    a <- p
    off1 <- getOffset
    ep <- getSourcePos
    pure $ WithPos sp ep (off1 - off) a

{-

TODO: extend this idea, to recover to parsing regular tokens after an
invalid one. This can then support resumption after error in the parser.
This would also need something similar being done for parse errors
within lexical tokens.

-}
invalidToken :: Dialect -> Parser (WithPos Token)
invalidToken :: Dialect -> Parser (WithPos Token)
invalidToken Dialect
_ =
    Parser Token -> Parser (WithPos Token)
forall a. Parser a -> Parser (WithPos a)
withPos (Parser Token -> Parser (WithPos Token))
-> Parser Token -> Parser (WithPos Token)
forall a b. (a -> b) -> a -> b
$ (ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof ParsecT Void Text Identity () -> Parser Token -> Parser Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Char] -> Parser Token
forall a. [Char] -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"") Parser Token -> Parser Token -> Parser Token
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Token
InvalidToken (Text -> Token) -> (Char -> Text) -> Char -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton (Char -> Token) -> ParsecT Void Text Identity Char -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle)

tokens :: Dialect -> Bool -> Parser [WithPos Token]
tokens :: Dialect -> Bool -> Parser [WithPos Token]
tokens Dialect
d Bool
pit = do
    x <- Parser (WithPos Token) -> Parser [WithPos Token]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Dialect -> Parser (WithPos Token)
sqlToken Dialect
d)
    if pit
        then choice [x <$ hidden eof
                    ,(\WithPos Token
y -> [WithPos Token]
x [WithPos Token] -> [WithPos Token] -> [WithPos Token]
forall a. [a] -> [a] -> [a]
++ [WithPos Token
y]) <$> hidden (invalidToken d)]
        else x <$ hidden eof

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

{-
Parse a SQL string. Examples:

'basic string'
'string with '' a quote'
n'international text'
b'binary string'
x'hexidecimal string'
-}

sqlString :: Dialect -> Parser Token
sqlString :: Dialect -> Parser Token
sqlString Dialect
d =
    (if (Dialect -> Bool
diDollarString Dialect
d)
     then (Parser Token
dollarString Parser Token -> Parser Token -> Parser Token
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>)
     else Parser Token -> Parser Token
forall a. a -> a
id) Parser Token
csString Parser Token -> Parser Token -> Parser Token
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Token
normalString
  where
    dollarString :: Parser Token
dollarString = do
        -- use try because of ambiguity with symbols and with
        -- positional arg
        delim <- ParsecT Void Text Identity () -> Parser Text
fstMatch (ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'$' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ Parser Text
identifierString ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'$'))
        let moreDollarString =
                [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label (Text -> [Char]
T.unpack Text
delim) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'$') ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
checkDollar
            checkDollar = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label (Text -> [Char]
T.unpack Text
delim) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ 
                [ParsecT Void Text Identity ()] -> ParsecT Void Text Identity ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
                [ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Text -> ParsecT Void Text Identity ()
chunk_ Text
delim) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> ParsecT Void Text Identity ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- would be nice not to parse it twice?
                                                     -- but makes the whole match trick much less neat
                ,Char -> ParsecT Void Text Identity ()
char_ Char
'$' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreDollarString]
        str <- fstMatch moreDollarString
        chunk_ delim
        pure $ SqlString delim delim str
    lq :: ParsecT Void Text Identity ()
lq = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"'" (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Void Text Identity ()
char_ Char
'\''
    normalString :: Parser Token
normalString = Text -> Text -> Text -> Token
SqlString Text
"'" Text
"'" (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity ()
lq ParsecT Void Text Identity () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser Text
normalStringSuffix Bool
False)
    normalStringSuffix :: Bool -> Parser Text
normalStringSuffix Bool
allowBackslash = [Char] -> Parser Text -> Parser Text
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"'" (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
        let regularChar :: Char -> Bool
regularChar = if Bool
allowBackslash
                          then (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\\')
                          else (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'')
            nonQuoteStringChar :: ParsecT Void Text Identity ()
nonQuoteStringChar = Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
regularChar
            nonRegularContinue :: ParsecT Void Text Identity ()
nonRegularContinue = 
                (Text -> ParsecT Void Text Identity ()
hchunk_ Text
"''" ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ParsecT Void Text Identity ()
hchunk_ Text
"\\'" ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT Void Text Identity ()
hchar_ Char
'\\')
            moreChars :: ParsecT Void Text Identity ()
moreChars = ParsecT Void Text Identity ()
nonQuoteStringChar
                ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option () (ParsecT Void Text Identity ()
nonRegularContinue ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreChars))
        ParsecT Void Text Identity () -> Parser Text
fstMatch ParsecT Void Text Identity ()
moreChars Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
lq
            
    -- try is used to to avoid conflicts with
    -- identifiers which can start with n,b,x,u
    -- once we read the quote type and the starting '
    -- then we commit to a string
    -- it's possible that this will reject some valid syntax
    -- but only pathalogical stuff, and I think the improved
    -- error messages and user predictability make it a good
    -- pragmatic choice
    csString :: Parser Token
csString
      | Dialect -> Bool
diEString Dialect
d =
        [Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text -> Text -> Text -> Token
SqlString (Text -> Text -> Text -> Token)
-> Parser Text
-> ParsecT Void Text Identity (Text -> Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
Text
"e'" Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
Text
"E'")
                          ParsecT Void Text Identity (Text -> Text -> Token)
-> Parser Text -> ParsecT Void Text Identity (Text -> Token)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"'" ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Parser Text
normalStringSuffix Bool
True
               ,Parser Token
csString']
      | Bool
otherwise = Parser Token
csString'
    csString' :: Parser Token
csString' = Text -> Text -> Text -> Token
SqlString
                (Text -> Text -> Text -> Token)
-> Parser Text
-> ParsecT Void Text Identity (Text -> Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Text
cs
                ParsecT Void Text Identity (Text -> Text -> Token)
-> Parser Text -> ParsecT Void Text Identity (Text -> Token)
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"'"
                ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Parser Text
normalStringSuffix Bool
False
    csPrefixes :: [Text]
csPrefixes = (Char -> Text) -> [Char] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Text -> Text
`T.cons` Text
"'") [Char]
"nNbBxX" [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"u&'", Text
"U&'"]
    cs :: Parser Text
    cs :: Parser Text
cs = [Parser Text] -> Parser Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser Text] -> Parser Text) -> [Parser Text] -> Parser Text
forall a b. (a -> b) -> a -> b
$ (Text -> Parser Text) -> [Text] -> [Parser Text]
forall a b. (a -> b) -> [a] -> [b]
map Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string [Text]
csPrefixes

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

{-
Parses identifiers:

simple_identifier_23
u&"unicode quoted identifier"
"quoted identifier"
"quoted identifier "" with double quote char"
`mysql quoted identifier`
-}

identifier :: Dialect -> Parser Token
identifier :: Dialect -> Parser Token
identifier Dialect
d =
    [Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser Token] -> Parser Token) -> [Parser Token] -> Parser Token
forall a b. (a -> b) -> a -> b
$
    [Parser Token
quotedIden
    ,Parser Token
unicodeQuotedIden
    ,Parser Token
regularIden]
    [Parser Token] -> [Parser Token] -> [Parser Token]
forall a. [a] -> [a] -> [a]
++ [Parser Token
mySqlQuotedIden | Dialect -> Bool
diBackquotedIden Dialect
d]
    [Parser Token] -> [Parser Token] -> [Parser Token]
forall a. [a] -> [a] -> [a]
++ [Parser Token
sqlServerQuotedIden | Dialect -> Bool
diSquareBracketQuotedIden Dialect
d]
  where
    regularIden :: Parser Token
regularIden = Maybe (Text, Text) -> Text -> Token
Identifier Maybe (Text, Text)
forall a. Maybe a
Nothing (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
identifierString
    quotedIden :: Parser Token
quotedIden = Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"\"",Text
"\"")) (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
qiden
    failEmptyIden :: Char -> Parser a
failEmptyIden Char
c = ParsecT Void Text Identity () -> Text -> Parser a
forall a. ParsecT Void Text Identity () -> Text -> Parser a
failOnThis (Char -> ParsecT Void Text Identity ()
char_ Char
c) Text
"empty identifier"
    mySqlQuotedIden :: Parser Token
mySqlQuotedIden =
        Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"`",Text
"`")) (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Char -> ParsecT Void Text Identity ()
char_ Char
'`' ParsecT Void Text Identity () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
         (Char -> Parser Text
forall {a}. Char -> Parser a
failEmptyIden Char
'`'
          Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token Text
'`') Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void Text Identity ()
char_ Char
'`')))
    sqlServerQuotedIden :: Parser Token
sqlServerQuotedIden =
        Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"[",Text
"]")) (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Char -> ParsecT Void Text Identity ()
char_ Char
'[' ParsecT Void Text Identity () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
         (Char -> Parser Text
forall {a}. Char -> Parser a
failEmptyIden Char
']'
         Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
forall a. Maybe a
Nothing (Char -> [Char] -> Bool
`notElemChar` [Char]
"[]")
              Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [ParsecT Void Text Identity ()] -> ParsecT Void Text Identity ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Char -> ParsecT Void Text Identity ()
char_ Char
']'
                         -- should probably do this error message as
                         -- a proper unexpected message
                         ,ParsecT Void Text Identity ()
-> Text -> ParsecT Void Text Identity ()
forall a. ParsecT Void Text Identity () -> Text -> Parser a
failOnThis (Char -> ParsecT Void Text Identity ()
char_ Char
'[') Text
"unexpected ["])))
    -- try is used here to avoid a conflict with identifiers
    -- and quoted strings which also start with a 'u'
    unicodeQuotedIden :: Parser Token
unicodeQuotedIden = Maybe (Text, Text) -> Text -> Token
Identifier
                        (Maybe (Text, Text) -> Text -> Token)
-> ParsecT Void Text Identity (Maybe (Text, Text))
-> ParsecT Void Text Identity (Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Maybe (Text, Text)
forall {b}. IsString b => Char -> Maybe (Text, b)
f (Char -> Maybe (Text, Text))
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Maybe (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ([Char] -> ParsecT Void Text Identity Char
oneOf [Char]
"uU" ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"&"))
                        ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
qiden
      where f :: Char -> Maybe (Text, b)
f Char
x = (Text, b) -> Maybe (Text, b)
forall a. a -> Maybe a
Just (Char -> Text -> Text
T.cons Char
x Text
"&\"", b
"\"")
    qiden :: Parser Text
qiden =
        Char -> ParsecT Void Text Identity ()
char_ Char
'"' ParsecT Void Text Identity () -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Parser Text
forall {a}. Char -> Parser a
failEmptyIden Char
'"' Parser Text -> Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity () -> Parser Text
fstMatch ParsecT Void Text Identity ()
moreQIden Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT Void Text Identity ()
char_ Char
'"')
    moreQIden :: ParsecT Void Text Identity ()
moreQIden =
        [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"\""
        (Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"')
         ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\"\"" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreQIden))

identifierString :: Parser Text
identifierString :: Parser Text
identifierString = [Char] -> Parser Text -> Parser Text
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"identifier" (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
    c <- (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
isFirstLetter
    choice
        [T.cons c <$> takeWhileP Nothing isIdentifierChar
        ,pure $ T.singleton c]
  where
     isFirstLetter :: Char -> Bool
isFirstLetter Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlpha Char
c

isIdentifierChar :: Char -> Bool
isIdentifierChar :: Char -> Bool
isIdentifierChar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isAlphaNum Char
c

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

lineComment :: Dialect -> Parser Token
lineComment :: Dialect -> Parser Token
lineComment Dialect
_ = Text -> Token
LineComment (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity () -> Parser Text
fstMatch (do
    ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (Text -> ParsecT Void Text Identity ()
string_ Text
"--")
    Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')
    -- can you optionally read the \n to terminate the takewhilep without reparsing it?
    ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_  (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Void Text Identity ()
char_ Char
'\n')

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

-- TODO: the parser before the switch to megaparsec parsed nested block comments
-- I don't know any dialects that use this, but I think it's useful, if needed,
-- add it back in under a dialect flag?
blockComment :: Dialect -> Parser Token
blockComment :: Dialect -> Parser Token
blockComment Dialect
_ = Text -> Token
BlockComment (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity () -> Parser Text
fstMatch ParsecT Void Text Identity ()
bc
  where
    bc :: ParsecT Void Text Identity ()
bc = Text -> ParsecT Void Text Identity ()
chunk_ Text
"/*" ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreBlockChars
    regularBlockCommentChars :: ParsecT Void Text Identity ()
regularBlockCommentChars = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"*/" (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$
        Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
forall a. Maybe a
Nothing (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')
    continueBlockComment :: ParsecT Void Text Identity ()
continueBlockComment = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"*/" (Char -> ParsecT Void Text Identity ()
char_ Char
'*' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT Void Text Identity ()
char_ Char
'/') ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreBlockChars
    endComment :: ParsecT Void Text Identity ()
endComment = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"*/" (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity ()
chunk_ Text
"*/"
    moreBlockChars :: ParsecT Void Text Identity ()
moreBlockChars = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"*/" (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$
        ParsecT Void Text Identity ()
regularBlockCommentChars
        ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT Void Text Identity ()
endComment
           ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"*/" ParsecT Void Text Identity ()
bc ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
moreBlockChars) -- nest
           ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
continueBlockComment)

{-
This is to improve user experience: provide an error if we see */
outside a comment. This could potentially break postgres ops with */
in them (it is not sensible to use operators that contain this as a
substring). In other cases, the user should write * / instead (I can't
think of any cases when this would be valid syntax).
-}

dontParseEndBlockComment :: Dialect -> Parser Token
dontParseEndBlockComment :: Dialect -> Parser Token
dontParseEndBlockComment Dialect
_ =
    ParsecT Void Text Identity () -> Text -> Parser Token
forall a. ParsecT Void Text Identity () -> Text -> Parser a
failOnThis (Text -> ParsecT Void Text Identity ()
chunk_ Text
"*/") Text
"comment end without comment start"

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

{-
numbers

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

where digits is one or more decimal digits (0 through 9). At least one
digit must be before or after the decimal point, if one is used. At
least one digit must follow the exponent marker (e), if one is
present. There cannot be any spaces or other characters embedded in
the constant. Note that any leading plus or minus sign is not actually
considered part of the constant; it is an operator applied to the
constant.


algorithm:
either
  parse 1 or more digits
    then an optional dot which isn't two dots
    then optional digits
  or: parse a dot which isn't two dots
    then digits
followed by an optional exponent
-}

sqlNumber :: Dialect -> Parser Token
sqlNumber :: Dialect -> Parser Token
sqlNumber Dialect
d =
    Text -> Token
SqlNumber (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity () -> Parser Text
fstMatch
    ((ParsecT Void Text Identity ()
numStartingWithDigits ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity ()
numStartingWithDot)
     ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ ParsecT Void Text Identity ()
expo ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
trailingCheck)
  where
    numStartingWithDigits :: ParsecT Void Text Identity ()
numStartingWithDigits = ParsecT Void Text Identity ()
digits_ ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ (ParsecT Void Text Identity ()
safeDot ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ ParsecT Void Text Identity ()
digits_)
    -- use try, so we don't commit to a number when there's a . with no following digit
    numStartingWithDot :: ParsecT Void Text Identity ()
numStartingWithDot = ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity ()
safeDot ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
digits_)
    expo :: ParsecT Void Text Identity ()
expo = (Char -> ParsecT Void Text Identity ()
char_ Char
'e' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT Void Text Identity ()
char_ Char
'E') ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
optional_ (Char -> ParsecT Void Text Identity ()
char_ Char
'-' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ParsecT Void Text Identity ()
char_ Char
'+') ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity ()
digits_
    digits_ :: ParsecT Void Text Identity ()
digits_ = [Char]
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"digits" (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhile1P_ Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
isDigit
    -- if there's a '..' next to the number, and it's a dialect that has .. as a
    -- lexical token, parse what we have so far and leave the dots in the chamber
    -- otherwise, give an error
    safeDot :: ParsecT Void Text Identity ()
safeDot =
        if Dialect -> Bool
diPostgresSymbols Dialect
d
        then ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Char -> ParsecT Void Text Identity ()
char_ Char
'.' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Char -> ParsecT Void Text Identity ()
char_ Char
'.'))
        else Char -> ParsecT Void Text Identity ()
char_ Char
'.' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Char -> ParsecT Void Text Identity ()
char_ Char
'.')
    -- additional check to give an error if the number is immediately
    -- followed by e, E or . with an exception for .. if this symbol is supported
    trailingCheck :: ParsecT Void Text Identity ()
trailingCheck =
        if Dialect -> Bool
diPostgresSymbols Dialect
d
        then -- special case to allow e.g. 1..2
             ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity ()
chunk_ Text
"..")
             ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ([Char] -> ParsecT Void Text Identity Char
oneOf [Char]
"eE."))
        else ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ([Char] -> ParsecT Void Text Identity Char
oneOf [Char]
"eE.")

digits :: Parser Text
digits :: Parser Text
digits = [Char] -> Parser Text -> Parser Text
forall a.
[Char]
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"digits" (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
isDigit

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

positionalArg :: Dialect -> Parser Token
positionalArg :: Dialect -> Parser Token
positionalArg Dialect
d =
    -- use try to avoid ambiguities with other syntax which starts with dollar
    [Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Int -> Token
PositionalArg (Int -> Token) -> ParsecT Void Text Identity Int -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Char -> ParsecT Void Text Identity ()
char_ Char
'$' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Int -> ParsecT Void Text Identity Int
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Char] -> Int
forall a. Read a => [Char] -> a
read ([Char] -> Int) -> (Text -> [Char]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> Int) -> Parser Text -> ParsecT Void Text Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
digits)) | Dialect -> Bool
diPositionalArg Dialect
d]

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

-- todo: I think the try here should read a prefix char, then a single valid
-- identifier char, then commit
prefixedVariable :: Dialect -> Parser Token
prefixedVariable :: Dialect -> Parser Token
prefixedVariable Dialect
d = Parser Token -> Parser Token
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Token -> Parser Token) -> Parser Token -> Parser Token
forall a b. (a -> b) -> a -> b
$ [Parser Token] -> Parser Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser Token] -> Parser Token) -> [Parser Token] -> Parser Token
forall a b. (a -> b) -> a -> b
$
    [Char -> Text -> Token
PrefixedVariable (Char -> Text -> Token)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':' ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
identifierString]
    [Parser Token] -> [Parser Token] -> [Parser Token]
forall a. [a] -> [a] -> [a]
++ [Char -> Text -> Token
PrefixedVariable (Char -> Text -> Token)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'@' ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
identifierString | Dialect -> Bool
diAtIdentifier Dialect
d]
    [Parser Token] -> [Parser Token] -> [Parser Token]
forall a. [a] -> [a] -> [a]
++ [Char -> Text -> Token
PrefixedVariable (Char -> Text -> Token)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'#' ParsecT Void Text Identity (Text -> Token)
-> Parser Text -> Parser Token
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
identifierString | Dialect -> Bool
diHashIdentifier Dialect
d]

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

{-
Symbols

A symbol is an operator, or one of the misc symbols which include:
. .. := : :: ( ) ? ; , { } (for odbc)

The postgresql operator syntax allows a huge range of operators
compared with ansi and other dialects
-}

symbol :: Dialect -> Parser Token
symbol :: Dialect -> Parser Token
symbol Dialect
d  = Text -> Token
Symbol (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Parser Text] -> Parser Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([[Parser Text]] -> [Parser Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [[ParsecT Void Text Identity (Tokens Text)]
[Parser Text]
dots
   ,if Dialect -> Bool
diPostgresSymbols Dialect
d
    then [ParsecT Void Text Identity (Tokens Text)]
[Parser Text]
postgresExtraSymbols
    else []
   ,[Parser Text]
miscSymbol
   ,if Dialect -> Bool
diOdbc Dialect
d then [ParsecT Void Text Identity (Tokens Text)]
[Parser Text]
odbcSymbol else []
   ,if Dialect -> Bool
diPostgresSymbols Dialect
d
    then [Parser Text]
generalizedPostgresqlOperator
    else [Parser Text]
basicAnsiOps
   ])
 where
   dots :: [ParsecT Void Text Identity (Tokens Text)]
dots = [Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
==Char
Token Text
'.')]
   odbcSymbol :: [ParsecT Void Text Identity (Tokens Text)]
odbcSymbol = [Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"{", Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"}"]
   postgresExtraSymbols :: [ParsecT Void Text Identity (Tokens Text)]
postgresExtraSymbols =
       [ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
":=")
        -- parse :: and : and avoid allowing ::: or more
       ,ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"::" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'))
       ,ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
":" ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'))]
   miscSymbol :: [Parser Text]
miscSymbol = (Char -> Parser Text) -> [Char] -> [Parser Text]
forall a b. (a -> b) -> [a] -> [b]
map (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> Parser Text) -> (Char -> Text) -> Char -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) ([Char] -> [Parser Text]) -> [Char] -> [Parser Text]
forall a b. (a -> b) -> a -> b
$
                case () of
                    ()
_ | Dialect -> Bool
diSqlServerSymbols Dialect
d -> [Char]
",;():?"
                      | Dialect -> Bool
diPostgresSymbols Dialect
d -> [Char]
"[],;()"
                      | Bool
otherwise -> [Char]
"[],;():?"

{-
try is used because most of the first characters of the two character
symbols can also be part of a single character symbol
-}

   basicAnsiOps :: [Parser Text]
basicAnsiOps = (Tokens Text -> Parser Text) -> [Tokens Text] -> [Parser Text]
forall a b. (a -> b) -> [a] -> [b]
map (Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text)
-> (Tokens Text -> Parser Text) -> Tokens Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Tokens Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string) [Tokens Text
">=",Tokens Text
"<=",Tokens Text
"!=",Tokens Text
"<>"]
                  [Parser Text] -> [Parser Text] -> [Parser Text]
forall a. [a] -> [a] -> [a]
++ (Char -> Parser Text) -> [Char] -> [Parser Text]
forall a b. (a -> b) -> [a] -> [b]
map (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> Parser Text) -> (Char -> Text) -> Char -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) [Char]
"+-^*/%~&<>="
                  [Parser Text] -> [Parser Text] -> [Parser Text]
forall a. [a] -> [a] -> [a]
++ [Parser Text]
pipes
   pipes :: [Parser Text]
pipes = -- what about using many1 (char '|'), then it will
           -- fail in the parser? Not sure exactly how
           -- standalone the lexer should be
           [Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'|' ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
            [Parser Text] -> Parser Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text
"||" Text -> ParsecT Void Text Identity Char -> Parser Text
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'|' Parser Text -> ParsecT Void Text Identity () -> Parser Text
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'|')
                   ,Text -> Parser Text
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"|"]]

{-
postgresql generalized operators

this includes the custom operators that postgres supports,
plus all the standard operators which could be custom operators
according to their grammar

rules

An operator name is a sequence of up to NAMEDATALEN-1 (63 by default) characters from the following list:

+ - * / < > = ~ ! @ # % ^ & | ` ?

There are a few restrictions on operator names, however:
-- and /* cannot appear anywhere in an operator name, since they will be taken as the start of a comment.

A multiple-character operator name cannot end in + or -, unless the name also contains at least one of these characters:

~ ! @ # % ^ & | ` ?

which allows the last character of a multi character symbol to be + or
-
-}

generalizedPostgresqlOperator :: [Parser Text]
generalizedPostgresqlOperator :: [Parser Text]
generalizedPostgresqlOperator = [Parser Text
singlePlusMinus,Parser Text
opMoreChars]
  where
    allOpSymbols :: [Char]
allOpSymbols = [Char]
"+-*/<>=~!@#%^&|`?"
    -- these are the symbols when if part of a multi character
    -- operator permit the operator to end with a + or - symbol
    exceptionOpSymbols :: [Char]
exceptionOpSymbols = [Char]
"~!@#%^&|`?"

    -- special case for parsing a single + or - symbol
    singlePlusMinus :: Parser Text
singlePlusMinus = Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ do
      c <- [Char] -> ParsecT Void Text Identity Char
oneOf [Char]
"+-"
      notFollowedBy $ oneOf allOpSymbols
      pure $ T.singleton c

    -- this is used when we are parsing a potentially multi symbol
    -- operator and we have alread seen one of the 'exception chars'
    -- and so we can end with a + or -
    moreOpCharsException :: Parser Text
moreOpCharsException = do
       c <- [Char] -> ParsecT Void Text Identity Char
oneOf ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> [Char] -> Bool
`notElemChar` [Char]
"-/*") [Char]
allOpSymbols)
            -- make sure we don't parse a comment starting token
            -- as part of an operator
            ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*'))
            ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'))
            -- and make sure we don't parse a block comment end
            -- as part of another symbol
            ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/'))
       T.cons c <$> option "" moreOpCharsException

    opMoreChars :: Parser Text
opMoreChars = [Parser Text] -> Parser Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
       [-- parse an exception char, now we can finish with a + -
        Char -> Text -> Text
T.cons
        (Char -> Text -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> ParsecT Void Text Identity Char
oneOf [Char]
exceptionOpSymbols
        ParsecT Void Text Identity (Text -> Text)
-> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text -> Parser Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" Parser Text
moreOpCharsException
       ,Char -> Text -> Text
T.cons
        (Char -> Text -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (-- parse +, make sure it isn't the last symbol
             ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'+' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ([Char] -> ParsecT Void Text Identity Char
oneOf [Char]
allOpSymbols))
             ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> -- parse -, make sure it isn't the last symbol
                 -- or the start of a -- comment
             ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-'
                  ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-')
                  ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ([Char] -> ParsecT Void Text Identity Char
oneOf [Char]
allOpSymbols))
             ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> -- parse / check it isn't the start of a /* comment
             ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*'))
             ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> -- make sure we don't parse */ as part of a symbol
             ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity Char
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a. Parser a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'/'))
             ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> -- any other ansi operator symbol
             [Char] -> ParsecT Void Text Identity Char
oneOf [Char]
"<>=")
        ParsecT Void Text Identity (Text -> Text)
-> Parser Text -> Parser Text
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser Text -> Parser Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" Parser Text
opMoreChars
       ]

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

sqlWhitespace :: Dialect -> Parser Token
sqlWhitespace :: Dialect -> Parser Token
sqlWhitespace Dialect
_ = Text -> Token
Whitespace (Text -> Token) -> Parser Text -> Parser Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
isSpace

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

-- parser helpers

char_ :: Char -> Parser ()
char_ :: Char -> ParsecT Void Text Identity ()
char_ = ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> (Char -> ParsecT Void Text Identity Char)
-> Char
-> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT Void Text Identity Char
Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char

hchar_ :: Char -> Parser ()
hchar_ :: Char -> ParsecT Void Text Identity ()
hchar_ = ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> (Char -> ParsecT Void Text Identity Char)
-> Char
-> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> (Char -> ParsecT Void Text Identity Char)
-> Char
-> ParsecT Void Text Identity Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ParsecT Void Text Identity Char
Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char

string_ :: Text -> Parser ()
string_ :: Text -> ParsecT Void Text Identity ()
string_ = Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> ParsecT Void Text Identity ())
-> (Text -> Parser Text) -> Text -> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

oneOf :: [Char] -> Parser Char
oneOf :: [Char] -> ParsecT Void Text Identity Char
oneOf = [Char] -> ParsecT Void Text Identity Char
[Token Text] -> ParsecT Void Text Identity (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
M.oneOf

notElemChar :: Char -> [Char] -> Bool
notElemChar :: Char -> [Char] -> Bool
notElemChar Char
a [Char]
b = Char
a Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
b :: [Char])

fstMatch :: Parser () -> Parser Text
fstMatch :: ParsecT Void Text Identity () -> Parser Text
fstMatch ParsecT Void Text Identity ()
x = (Text, ()) -> Text
forall a b. (a, b) -> a
fst ((Text, ()) -> Text)
-> ParsecT Void Text Identity (Text, ()) -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity (Tokens Text, ())
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match ParsecT Void Text Identity ()
x

hoptional_ :: Parser a -> Parser ()
hoptional_ :: forall a. Parser a -> ParsecT Void Text Identity ()
hoptional_ = ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe a)
 -> ParsecT Void Text Identity ())
-> (Parser a -> ParsecT Void Text Identity (Maybe a))
-> Parser a
-> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ParsecT Void Text Identity (Maybe a)
forall a. Parser a -> Parser (Maybe a)
hoptional

hoptional :: Parser a -> Parser (Maybe a)
hoptional :: forall a. Parser a -> Parser (Maybe a)
hoptional = ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity (Maybe a)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (ParsecT Void Text Identity (Maybe a)
 -> ParsecT Void Text Identity (Maybe a))
-> (Parser a -> ParsecT Void Text Identity (Maybe a))
-> Parser a
-> ParsecT Void Text Identity (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

optional_ :: Parser a -> Parser ()
optional_ :: forall a. Parser a -> ParsecT Void Text Identity ()
optional_ = ParsecT Void Text Identity (Maybe a)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Maybe a)
 -> ParsecT Void Text Identity ())
-> (Parser a -> ParsecT Void Text Identity (Maybe a))
-> Parser a
-> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ParsecT Void Text Identity (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional

--hoption :: a -> Parser a -> Parser a
--hoption a p = hidden $ option a p

takeWhileP_ :: Maybe String -> (Char -> Bool) -> Parser ()
takeWhileP_ :: Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhileP_ Maybe [Char]
m Char -> Bool
p = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe [Char]
m Char -> Bool
Token Text -> Bool
p

takeWhile1P_ :: Maybe String -> (Char -> Bool) -> Parser ()
takeWhile1P_ :: Maybe [Char] -> (Char -> Bool) -> ParsecT Void Text Identity ()
takeWhile1P_ Maybe [Char]
m Char -> Bool
p = ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Maybe [Char]
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe [Char]
m Char -> Bool
Token Text -> Bool
p

chunk_ :: Text -> Parser ()
chunk_ :: Text -> ParsecT Void Text Identity ()
chunk_ = Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> ParsecT Void Text Identity ())
-> (Text -> Parser Text) -> Text -> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk

hchunk_ :: Text -> Parser ()
hchunk_ :: Text -> ParsecT Void Text Identity ()
hchunk_ = Parser Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text -> ParsecT Void Text Identity ())
-> (Text -> Parser Text) -> Text -> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Text -> Parser Text
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (Parser Text -> Parser Text)
-> (Text -> Parser Text) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text -> ParsecT Void Text Identity (Tokens Text)
Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk

failOnThis :: Parser () -> Text -> Parser a
failOnThis :: forall a. ParsecT Void Text Identity () -> Text -> Parser a
failOnThis ParsecT Void Text Identity ()
p Text
msg = do
    o <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    hidden p
    region (setErrorOffset o) $ fail $ T.unpack msg

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


{-
This utility function will accurately report if the two tokens are
pretty printed, if they should lex back to the same two tokens. This
function is used in testing (and can be used in other places), and
must not be implemented by actually trying to print both tokens and
then lex them back from a single string (because then we would have
the risk of thinking two tokens cannot be together when there is bug
in the lexer, which the testing is supposed to find).

maybe do some quick checking to make sure this function only gives
true negatives: check pairs which return false actually fail to lex or
give different symbols in return: could use quickcheck for this

a good sanity test for this function is to change it to always return
true, then check that the automated tests return the same number of
successes. I don't think it succeeds this test at the moment
-}

-- | Utility function to tell you if a list of tokens
-- will pretty print then lex back to the same set of tokens.
-- Used internally, might be useful for generating SQL via lexical tokens.
tokenListWillPrintAndLex :: Dialect -> [Token] -> Bool
tokenListWillPrintAndLex :: Dialect -> [Token] -> Bool
tokenListWillPrintAndLex Dialect
_ [] = Bool
True
tokenListWillPrintAndLex Dialect
_ [Token
_] = Bool
True
tokenListWillPrintAndLex Dialect
d (Token
a:Token
b:[Token]
xs) =
    Dialect -> Token -> Token -> Bool
tokensWillPrintAndLex Dialect
d Token
a Token
b Bool -> Bool -> Bool
&& Dialect -> [Token] -> Bool
tokenListWillPrintAndLex Dialect
d (Token
bToken -> [Token] -> [Token]
forall a. a -> [a] -> [a]
:[Token]
xs)

tokensWillPrintAndLex :: Dialect -> Token -> Token -> Bool
tokensWillPrintAndLex :: Dialect -> Token -> Token -> Bool
tokensWillPrintAndLex Dialect
d Token
a Token
b

{-
a : followed by an identifier character will look like a host param
followed by = or : makes a different symbol
-}

    | Symbol Text
":" <- Token
a
    , (Char -> Bool) -> Bool
checkFirstBChar (\Char
x -> Char -> Bool
isIdentifierChar Char
x Bool -> Bool -> Bool
|| Char
x Char -> Text -> Bool
`T.elem` Text
":=") = Bool
False

{-
two symbols next to eachother will fail if the symbols can combine and
(possibly just the prefix) look like a different symbol
-}

    | Dialect -> Bool
diPostgresSymbols Dialect
d
    , Symbol Text
a' <- Token
a
    , Symbol Text
b' <- Token
b
    , Text
b' Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"+", Text
"-"] Bool -> Bool -> Bool
|| (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Text -> Bool
`T.elem` Text
a') ([Char]
"~!@#%^&|`?" :: [Char]) = Bool
False

{-
check two adjacent symbols in non postgres where the combination
possibilities are much more limited. This is ansi behaviour, it might
be different when the other dialects are done properly
-}

   | Symbol Text
a' <- Token
a
   , Symbol Text
b' <- Token
b
   , (Text
a',Text
b') (Text, Text) -> [(Text, Text)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text
"<",Text
">")
                    ,(Text
"<",Text
"=")
                    ,(Text
">",Text
"=")
                    ,(Text
"!",Text
"=")
                    ,(Text
"|",Text
"|")
                    ,(Text
"||",Text
"|")
                    ,(Text
"|",Text
"||")
                    ,(Text
"||",Text
"||")
                    ,(Text
"<",Text
">=")
                    ] = Bool
False

-- two whitespaces will be combined

   | Whitespace {} <- Token
a
   , Whitespace {} <- Token
b = Bool
False

-- line comment without a newline at the end will eat the next token

   | LineComment {} <- Token
a
   , (Char -> Bool) -> Bool
checkLastAChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') = Bool
False

{-
check the last character of the first token and the first character of
the second token forming a comment start or end symbol
-}

   | let f :: Char -> Char -> Bool
f Char
'-' Char
'-' = Bool
True
         f Char
'/' Char
'*' = Bool
True
         f Char
'*' Char
'/' = Bool
True
         f Char
_ Char
_ = Bool
False
     in (Char -> Char -> Bool) -> Bool
checkBorderChars Char -> Char -> Bool
f = Bool
False

{-
a symbol will absorb a following .
TODO: not 100% on this always being bad
-}

   | Symbol {} <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') = Bool
False

-- cannot follow a symbol ending in : with another token starting with :

   | let f :: Char -> Char -> Bool
f Char
':' Char
':' = Bool
True
         f Char
_ Char
_ = Bool
False
     in (Char -> Char -> Bool) -> Bool
checkBorderChars Char -> Char -> Bool
f = Bool
False

-- unquoted identifier followed by an identifier letter

   | Identifier Maybe (Text, Text)
Nothing Text
_ <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar Char -> Bool
isIdentifierChar = Bool
False

-- a quoted identifier using ", followed by a " will fail

   | Identifier (Just (Text
_,Text
"\"")) Text
_ <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"') = Bool
False

-- prefixed variable followed by an identifier char will be absorbed

   | PrefixedVariable {} <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar Char -> Bool
isIdentifierChar = Bool
False

-- a positional arg will absorb a following digit

   | PositionalArg {} <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar Char -> Bool
isDigit = Bool
False

-- a string ending with ' followed by a token starting with ' will be absorbed

   | SqlString Text
_ Text
"'" Text
_ <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\'') = Bool
False

-- a number followed by a . will fail or be absorbed

   | SqlNumber {} <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') = Bool
False

-- a number followed by an e or E will fail or be absorbed

   | SqlNumber {} <- Token
a
   , (Char -> Bool) -> Bool
checkFirstBChar (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'e' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'E') = Bool
False

-- two numbers next to eachother will fail or be absorbed

   | SqlNumber {} <- Token
a
   , SqlNumber {} <- Token
b = Bool
False


   | Bool
otherwise = Bool
True

  where
    prettya :: Text
prettya = Dialect -> Token -> Text
prettyToken Dialect
d Token
a
    prettyb :: Text
prettyb = Dialect -> Token -> Text
prettyToken Dialect
d Token
b
    -- helper function to run a predicate on the
    -- last character of the first token and the first
    -- character of the second token
    checkBorderChars :: (Char -> Char -> Bool) -> Bool
checkBorderChars Char -> Char -> Bool
f =
        case (Text -> Maybe (Text, Char)
T.unsnoc Text
prettya, Text -> Maybe (Char, Text)
T.uncons Text
prettyb) of
            (Just (Text
_,Char
la), Just (Char
fb,Text
_)) -> Char -> Char -> Bool
f Char
la Char
fb
            (Maybe (Text, Char), Maybe (Char, Text))
_ -> Bool
False
    checkFirstBChar :: (Char -> Bool) -> Bool
checkFirstBChar Char -> Bool
f = case Text -> Maybe (Char, Text)
T.uncons Text
prettyb of
        Just (Char
b',Text
_) -> Char -> Bool
f Char
b'
        Maybe (Char, Text)
_ -> Bool
False
    checkLastAChar :: (Char -> Bool) -> Bool
checkLastAChar Char -> Bool
f = case Text -> Maybe (Text, Char)
T.unsnoc Text
prettya of
        Just (Text
_,Char
la) -> Char -> Bool
f Char
la
        Maybe (Text, Char)
_ -> Bool
False

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

-- megaparsec stream boilerplate

-- | Wrapper to allow using the lexer as input to a megaparsec parser.
data SQLStream = SQLStream
  { SQLStream -> [Char]
sqlStreamInput :: String
  , SQLStream -> [WithPos Token]
unSQLStream :: [WithPos Token]
  }

instance M.Stream SQLStream where
  type Token  SQLStream = WithPos Token
  type Tokens SQLStream = [WithPos Token]

  tokenToChunk :: Proxy SQLStream -> Token SQLStream -> Tokens SQLStream
tokenToChunk Proxy SQLStream
Proxy Token SQLStream
x = [Token SQLStream
WithPos Token
x]
  tokensToChunk :: Proxy SQLStream -> [Token SQLStream] -> Tokens SQLStream
tokensToChunk Proxy SQLStream
Proxy [Token SQLStream]
xs = [Token SQLStream]
Tokens SQLStream
xs
  chunkToTokens :: Proxy SQLStream -> Tokens SQLStream -> [Token SQLStream]
chunkToTokens Proxy SQLStream
Proxy = [WithPos Token] -> [WithPos Token]
Tokens SQLStream -> [Token SQLStream]
forall a. a -> a
id
  chunkLength :: Proxy SQLStream -> Tokens SQLStream -> Int
chunkLength Proxy SQLStream
Proxy = [WithPos Token] -> Int
Tokens SQLStream -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
  chunkEmpty :: Proxy SQLStream -> Tokens SQLStream -> Bool
chunkEmpty Proxy SQLStream
Proxy = [WithPos Token] -> Bool
Tokens SQLStream -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
  take1_ :: SQLStream -> Maybe (Token SQLStream, SQLStream)
take1_ (SQLStream [Char]
_ []) = Maybe (Token SQLStream, SQLStream)
Maybe (WithPos Token, SQLStream)
forall a. Maybe a
Nothing
  take1_ (SQLStream [Char]
str (WithPos Token
t:[WithPos Token]
ts)) = (WithPos Token, SQLStream) -> Maybe (WithPos Token, SQLStream)
forall a. a -> Maybe a
Just
    ( WithPos Token
t
    , [Char] -> [WithPos Token] -> SQLStream
SQLStream (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Proxy SQLStream -> NonEmpty (Token SQLStream) -> Int
forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> Int
tokensLength Proxy SQLStream
pxy (WithPos Token
t WithPos Token -> [WithPos Token] -> NonEmpty (WithPos Token)
forall a. a -> [a] -> NonEmpty a
NE.:|[])) [Char]
str) [WithPos Token]
ts
    )
  takeN_ :: Int -> SQLStream -> Maybe (Tokens SQLStream, SQLStream)
takeN_ Int
n (SQLStream [Char]
str [WithPos Token]
s)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = ([WithPos Token], SQLStream) -> Maybe ([WithPos Token], SQLStream)
forall a. a -> Maybe a
Just ([], [Char] -> [WithPos Token] -> SQLStream
SQLStream [Char]
str [WithPos Token]
s)
    | [WithPos Token] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [WithPos Token]
s    = Maybe ([WithPos Token], SQLStream)
Maybe (Tokens SQLStream, SQLStream)
forall a. Maybe a
Nothing
    | Bool
otherwise =
        let ([WithPos Token]
x, [WithPos Token]
s') = Int -> [WithPos Token] -> ([WithPos Token], [WithPos Token])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [WithPos Token]
s
        in case [WithPos Token] -> Maybe (NonEmpty (WithPos Token))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [WithPos Token]
x of
          Maybe (NonEmpty (WithPos Token))
Nothing -> ([WithPos Token], SQLStream) -> Maybe ([WithPos Token], SQLStream)
forall a. a -> Maybe a
Just ([WithPos Token]
x, [Char] -> [WithPos Token] -> SQLStream
SQLStream [Char]
str [WithPos Token]
s')
          Just NonEmpty (WithPos Token)
nex -> ([WithPos Token], SQLStream) -> Maybe ([WithPos Token], SQLStream)
forall a. a -> Maybe a
Just ([WithPos Token]
x, [Char] -> [WithPos Token] -> SQLStream
SQLStream (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Proxy SQLStream -> NonEmpty (Token SQLStream) -> Int
forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> Int
tokensLength Proxy SQLStream
pxy NonEmpty (Token SQLStream)
NonEmpty (WithPos Token)
nex) [Char]
str) [WithPos Token]
s')
  takeWhile_ :: (Token SQLStream -> Bool)
-> SQLStream -> (Tokens SQLStream, SQLStream)
takeWhile_ Token SQLStream -> Bool
f (SQLStream [Char]
str [WithPos Token]
s) =
    let ([WithPos Token]
x, [WithPos Token]
s') = (WithPos Token -> Bool)
-> [WithPos Token] -> ([WithPos Token], [WithPos Token])
forall a. (a -> Bool) -> [a] -> ([a], [a])
DL.span Token SQLStream -> Bool
WithPos Token -> Bool
f [WithPos Token]
s
    in case [WithPos Token] -> Maybe (NonEmpty (WithPos Token))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [WithPos Token]
x of
      Maybe (NonEmpty (WithPos Token))
Nothing -> ([WithPos Token]
Tokens SQLStream
x, [Char] -> [WithPos Token] -> SQLStream
SQLStream [Char]
str [WithPos Token]
s')
      Just NonEmpty (WithPos Token)
nex -> ([WithPos Token]
Tokens SQLStream
x, [Char] -> [WithPos Token] -> SQLStream
SQLStream (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Proxy SQLStream -> NonEmpty (Token SQLStream) -> Int
forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> Int
tokensLength Proxy SQLStream
pxy NonEmpty (Token SQLStream)
NonEmpty (WithPos Token)
nex) [Char]
str) [WithPos Token]
s')

instance VisualStream SQLStream where
  showTokens :: Proxy SQLStream -> NonEmpty (Token SQLStream) -> [Char]
showTokens Proxy SQLStream
Proxy = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
DL.intercalate [Char]
" "
    ([[Char]] -> [Char])
-> (NonEmpty (WithPos Token) -> [[Char]])
-> NonEmpty (WithPos Token)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
NE.toList
    (NonEmpty [Char] -> [[Char]])
-> (NonEmpty (WithPos Token) -> NonEmpty [Char])
-> NonEmpty (WithPos Token)
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithPos Token -> [Char])
-> NonEmpty (WithPos Token) -> NonEmpty [Char]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> [Char]
showMyToken (Token -> [Char])
-> (WithPos Token -> Token) -> WithPos Token -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithPos Token -> Token
forall a. WithPos a -> a
tokenVal)
  tokensLength :: Proxy SQLStream -> NonEmpty (Token SQLStream) -> Int
tokensLength Proxy SQLStream
Proxy NonEmpty (Token SQLStream)
xs = NonEmpty Int -> Int
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (WithPos Token -> Int
forall a. WithPos a -> Int
tokenLength (WithPos Token -> Int) -> NonEmpty (WithPos Token) -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Token SQLStream)
NonEmpty (WithPos Token)
xs)

instance TraversableStream SQLStream where
    -- I have no idea what all this is doing
  reachOffset :: Int -> PosState SQLStream -> (Maybe [Char], PosState SQLStream)
reachOffset Int
o _x :: PosState SQLStream
_x@(M.PosState {Int
[Char]
SourcePos
Pos
SQLStream
pstateSourcePos :: forall s. PosState s -> SourcePos
pstateInput :: SQLStream
pstateOffset :: Int
pstateSourcePos :: SourcePos
pstateTabWidth :: Pos
pstateLinePrefix :: [Char]
pstateLinePrefix :: forall s. PosState s -> [Char]
pstateTabWidth :: forall s. PosState s -> Pos
pstateOffset :: forall s. PosState s -> Int
pstateInput :: forall s. PosState s -> s
..}) =
    ( [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
actualLine
    , PosState
        { pstateInput :: SQLStream
pstateInput = SQLStream
            { sqlStreamInput :: [Char]
sqlStreamInput = [Char]
postStr
            , unSQLStream :: [WithPos Token]
unSQLStream = [WithPos Token]
post
            }
        , pstateOffset :: Int
pstateOffset = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
pstateOffset Int
o
        , pstateSourcePos :: SourcePos
pstateSourcePos = SourcePos
newSourcePos
        , pstateTabWidth :: Pos
pstateTabWidth = Pos
pstateTabWidth
        , pstateLinePrefix :: [Char]
pstateLinePrefix = [Char]
prefix
        }
    )
    where
      maybeitsthefullsource :: [Char]
maybeitsthefullsource = SQLStream -> [Char]
sqlStreamInput SQLStream
pstateInput
      targetLineNo :: Int
targetLineNo = Pos -> Int
M.unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
newSourcePos
      actualLine :: [Char]
actualLine = case Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop (Int
targetLineNo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
maybeitsthefullsource of
          ([Char]
x:[[Char]]
_) -> [Char]
x
          [] -> [Char]
"<empty line>"
      prefix :: [Char]
prefix =
        if Bool
sameLine
          then [Char]
pstateLinePrefix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
preLine
          else [Char]
preLine
      sameLine :: Bool
sameLine = SourcePos -> Pos
sourceLine SourcePos
newSourcePos Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== SourcePos -> Pos
sourceLine SourcePos
pstateSourcePos
      newSourcePos :: SourcePos
newSourcePos =
        case [WithPos Token]
post of
          [] -> case SQLStream -> [WithPos Token]
unSQLStream SQLStream
pstateInput of
            [] -> SourcePos
pstateSourcePos
            [WithPos Token]
xs -> WithPos Token -> SourcePos
forall a. WithPos a -> SourcePos
endPos ([WithPos Token] -> WithPos Token
forall a. HasCallStack => [a] -> a
last [WithPos Token]
xs)
          (WithPos Token
x:[WithPos Token]
_) -> WithPos Token -> SourcePos
forall a. WithPos a -> SourcePos
startPos WithPos Token
x
      ([WithPos Token]
pre, [WithPos Token]
post) = Int -> [WithPos Token] -> ([WithPos Token], [WithPos Token])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pstateOffset) (SQLStream -> [WithPos Token]
unSQLStream SQLStream
pstateInput)
      ([Char]
preStr, [Char]
postStr) = Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
tokensConsumed (SQLStream -> [Char]
sqlStreamInput SQLStream
pstateInput)
      preLine :: [Char]
preLine = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
preStr
      tokensConsumed :: Int
tokensConsumed =
        case [WithPos Token] -> Maybe (NonEmpty (WithPos Token))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [WithPos Token]
pre of
          Maybe (NonEmpty (WithPos Token))
Nothing -> Int
0
          Just NonEmpty (WithPos Token)
nePre -> Proxy SQLStream -> NonEmpty (Token SQLStream) -> Int
forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> Int
tokensLength Proxy SQLStream
pxy NonEmpty (Token SQLStream)
NonEmpty (WithPos Token)
nePre

pxy :: Proxy SQLStream
pxy :: Proxy SQLStream
pxy = Proxy SQLStream
forall {k} (t :: k). Proxy t
Proxy

showMyToken :: Token -> String
-- todo: how to do this properly?
showMyToken :: Token -> [Char]
showMyToken = Text -> [Char]
T.unpack (Text -> [Char]) -> (Token -> Text) -> Token -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dialect -> Token -> Text
prettyToken Dialect
ansi2011