Location via proxy:   [ UP ]   [Report a bug]   [Manage cookies]    No cookies    No scripts    No ads    No referrer    Show this form

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

    ,choice
    ,satisfy
    ,takeWhileP
    ,takeWhile1P
    ,(<?>)
    ,eof
    ,many
    ,try
    ,option
    ,(<|>)
    ,notFollowedBy
    ,manyTill
    ,anySingle
    ,lookAhead
    )
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 Control.Applicative ((<**>))
import Data.Char
    (isAlphaNum
    ,isAlpha
    ,isSpace
    ,isDigit
    )
import Control.Monad (void, guard)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)

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

-- 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
      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 -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$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.
lexSQLWithPositions
    :: Dialect
    -- ^ dialect of SQL to use
    -> 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
-> Text
-> Maybe (Int, Int)
-> Text
-> Either ParseError [WithPos Token]
lexSQLWithPositions Dialect
dialect 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 (ParsecT Void Text Identity (WithPos Token)
-> Parser [WithPos Token]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Dialect -> ParsecT Void Text Identity (WithPos Token)
sqlToken Dialect
dialect) Parser [WithPos Token]
-> ParsecT Void Text Identity () -> Parser [WithPos Token]
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 ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof ParsecT Void Text Identity ()
-> String -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"")) Text
src


-- | Lex some SQL to a list of tokens.
lexSQL
    :: Dialect
    -- ^ dialect of SQL to use
    -> 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
-> Text -> Maybe (Int, Int) -> Text -> Either ParseError [Token]
lexSQL Dialect
dialect 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
-> Text
-> Maybe (Int, Int)
-> Text
-> Either ParseError [WithPos Token]
lexSQLWithPositions Dialect
dialect 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 = String -> Pos -> Pos -> SourcePos
SourcePos (Text -> String
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 = String -> Text -> State Text Void
forall s e. String -> s -> State s e
initialState (Text -> String
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 = String -> Text
T.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
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 -> String
(Int -> WithPos a -> ShowS)
-> (WithPos a -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: WithPos a -> String
$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
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
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

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 -> ParsecT Void Text Identity (WithPos Token)
sqlToken Dialect
d = (do
    -- possibly there's a more efficient way of doing the source positions?
    SourcePos
sp <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    Int
off <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    Token
t <- [ParsecT Void Text Identity Token]
-> ParsecT Void Text Identity Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
         [Dialect -> ParsecT Void Text Identity Token
sqlString Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
identifier Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
lineComment Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
blockComment Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
sqlNumber Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
positionalArg Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
dontParseEndBlockComment Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
prefixedVariable Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
symbol Dialect
d
         ,Dialect -> ParsecT Void Text Identity Token
sqlWhitespace Dialect
d]
    Int
off1 <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    SourcePos
ep <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
    WithPos Token -> ParsecT Void Text Identity (WithPos Token)
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithPos Token -> ParsecT Void Text Identity (WithPos Token))
-> WithPos Token -> ParsecT Void Text Identity (WithPos Token)
forall a b. (a -> b) -> a -> b
$ SourcePos -> SourcePos -> Int -> Token -> WithPos Token
forall a. SourcePos -> SourcePos -> Int -> a -> WithPos a
WithPos SourcePos
sp SourcePos
ep (Int
off1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off) Token
t) ParsecT Void Text Identity (WithPos Token)
-> String -> ParsecT Void Text Identity (WithPos Token)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"valid lexical token"

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

{-
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 -> ParsecT Void Text Identity Token
sqlString Dialect
d = ParsecT Void Text Identity Token
dollarString ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity 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
<|> ParsecT Void Text Identity Token
csString ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity 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
<|> ParsecT Void Text Identity Token
normalString
  where
    dollarString :: ParsecT Void Text Identity Token
dollarString = do
        Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ParsecT Void Text Identity ())
-> Bool -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Dialect -> Bool
diDollarString Dialect
d
        -- use try because of ambiguity with symbols and with
        -- positional arg
        Text
delim <- (\Text
x -> [Text] -> Text
T.concat [Text
"$",Text
x,Text
"$"])
                 (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 (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 Text
-> ParsecT Void Text Identity 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
*> Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" ParsecT Void Text Identity Text
identifierString ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity 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
<* 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 -> Text -> Text -> Token
SqlString Text
delim Text
delim (Text -> Token) -> (String -> Text) -> String -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Token)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (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 (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity (Tokens Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
delim)
    normalString :: ParsecT Void Text Identity Token
normalString = Text -> Text -> Text -> Token
SqlString Text
"'" Text
"'" (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 -> Text -> ParsecT Void Text Identity Text
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, Tokens s ~ Text, MonadParsec e s m) =>
Bool -> Text -> m Text
normalStringSuffix Bool
False Text
"")
    normalStringSuffix :: Bool -> Text -> m Text
normalStringSuffix Bool
allowBackslash Text
t = do
        Text
s <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing ((Token s -> Bool) -> m (Tokens s))
-> (Token s -> Bool) -> m (Tokens s)
forall a b. (a -> b) -> a -> b
$ if Bool
allowBackslash
                                  then (Char -> String -> Bool
`notElemChar` String
"'\\")
                                  else (Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token s
'\'')
        -- deal with '' or \' as literal quote character
        [m Text] -> m Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [do
                Text
ctu <- [m Text] -> m Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text
"''" Text -> m (Tokens s) -> m Text
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m (Tokens s) -> m (Tokens s)
forall a. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"''")
                              ,Text
"\\'" Text -> m (Tokens s) -> m Text
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens s
"\\'"
                              ,Text
"\\" Text -> m Char -> m Text
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\\']
                Bool -> Text -> m Text
normalStringSuffix Bool
allowBackslash (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
t,Text
s,Text
ctu]
               ,[Text] -> Text
T.concat [Text
t,Text
s] Text -> m Char -> m Text
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'\'']
    -- 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 :: ParsecT Void Text Identity Token
csString
      | Dialect -> Bool
diEString Dialect
d =
        [ParsecT Void Text Identity Token]
-> ParsecT Void Text Identity Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text -> Text -> Text -> Token
SqlString (Text -> Text -> Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 Text
Tokens Text
"e'" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 Text
Tokens Text
"E'")
                          ParsecT Void Text Identity (Text -> Text -> Token)
-> ParsecT Void Text Identity 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 -> ParsecT Void Text Identity 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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 -> Text -> ParsecT Void Text Identity Text
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, Tokens s ~ Text, MonadParsec e s m) =>
Bool -> Text -> m Text
normalStringSuffix Bool
True Text
""
               ,ParsecT Void Text Identity Token
csString']
      | Bool
otherwise = ParsecT Void Text Identity Token
csString'
    csString' :: ParsecT Void Text Identity Token
csString' = Text -> Text -> Text -> Token
SqlString
                (Text -> Text -> Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text -> Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 ParsecT Void Text Identity Text
cs
                ParsecT Void Text Identity (Text -> Text -> Token)
-> ParsecT Void Text Identity 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 -> ParsecT Void Text Identity 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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 -> Text -> ParsecT Void Text Identity Text
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, Tokens s ~ Text, MonadParsec e s m) =>
Bool -> Text -> m Text
normalStringSuffix Bool
False Text
""
    csPrefixes :: [Text]
csPrefixes = (Char -> Text) -> String -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Text -> Text
`T.cons` Text
"'") String
"nNbBxX" [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"u&'", Text
"U&'"]
    cs :: Parser Text
    cs :: ParsecT Void Text Identity Text
cs = [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void Text Identity Text]
 -> ParsecT Void Text Identity Text)
-> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ (Text -> ParsecT Void Text Identity Text)
-> [Text] -> [ParsecT Void Text Identity Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ParsecT Void Text Identity Text
Tokens Text -> ParsecT Void Text Identity (Tokens 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 -> ParsecT Void Text Identity Token
identifier Dialect
d =
    [ParsecT Void Text Identity Token]
-> ParsecT Void Text Identity Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ParsecT Void Text Identity Token
quotedIden
    ,ParsecT Void Text Identity Token
unicodeQuotedIden
    ,ParsecT Void Text Identity Token
regularIden
    ,Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diBackquotedIden Dialect
d) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity Token
mySqlQuotedIden
    ,Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diSquareBracketQuotedIden Dialect
d) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void Text Identity Token
sqlServerQuotedIden
    ]
  where
    regularIden :: ParsecT Void Text Identity Token
regularIden = Maybe (Text, Text) -> Text -> Token
Identifier Maybe (Text, Text)
forall a. Maybe a
Nothing (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
identifierString
    quotedIden :: ParsecT Void Text Identity Token
quotedIden = Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"\"",Text
"\"")) (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
qidenPart
    mySqlQuotedIden :: ParsecT Void Text Identity Token
mySqlQuotedIden = Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"`",Text
"`"))
                      (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
*> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token Text
'`') ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity 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
<* 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
'`')
    sqlServerQuotedIden :: ParsecT Void Text Identity Token
sqlServerQuotedIden = Maybe (Text, Text) -> Text -> Token
Identifier ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
"[",Text
"]"))
                          (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
*> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Char -> String -> Bool
`notElemChar` String
"[]") ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity 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
<* 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
']')
    -- try is used here to avoid a conflict with identifiers
    -- and quoted strings which also start with a 'u'
    unicodeQuotedIden :: ParsecT Void Text Identity 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 (String -> ParsecT Void Text Identity Char
oneOf String
"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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
qidenPart
      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
"\"")
    qidenPart :: ParsecT Void Text Identity Text
qidenPart = 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 Text
-> ParsecT Void Text Identity 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
*> Text -> ParsecT Void Text Identity Text
forall {s} {m :: * -> *} {e}.
(Token s ~ Char, Tokens s ~ Text, MonadParsec e s m) =>
Text -> m Text
qidenSuffix Text
""
    qidenSuffix :: Text -> m Text
qidenSuffix Text
t = do
        Text
s <- Maybe String -> (Token s -> Bool) -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Token s -> Token s -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token s
'"')
        m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'"'
        -- deal with "" as literal double quote character
        [m Text] -> m Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [do
                m Char -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Char -> m ()) -> m Char -> m ()
forall a b. (a -> b) -> a -> b
$ Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token s
'"'
                Text -> m Text
qidenSuffix (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
t,Text
s,Text
"\"\""]
               ,Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
t,Text
s]]

identifierString :: Parser Text
identifierString :: ParsecT Void Text Identity Text
identifierString = (do
    Char
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
    [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [Char -> Text -> Text
T.cons Char
c (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier char") Char -> Bool
Token Text -> Bool
isIdentifierChar
        ,Text -> ParsecT Void Text Identity Text
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ParsecT Void Text Identity Text)
-> Text -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
c]) ParsecT Void Text Identity Text
-> String -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"identifier"
  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 -> ParsecT Void Text Identity Token
lineComment Dialect
_ = 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
try (Text -> ParsecT Void Text Identity ()
string_ Text
"--") ParsecT Void Text Identity ()
-> String -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
""
    Text
rest <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"non newline character") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
Token Text
'\n')
    -- can you optionally read the \n to terminate the takewhilep without reparsing it?
    Text
suf <- Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" (Text
"\n" Text
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity 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
<$ Char -> ParsecT Void Text Identity ()
char_ Char
'\n')
    Token -> ParsecT Void Text Identity Token
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token -> ParsecT Void Text Identity Token)
-> Token -> ParsecT Void Text Identity Token
forall a b. (a -> b) -> a -> b
$ Text -> Token
LineComment (Text -> Token) -> Text -> Token
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"--", Text
rest, Text
suf]

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

-- 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 -> ParsecT Void Text Identity Token
blockComment Dialect
_ = (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
try (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 ()
string_ Text
"/*"
    Text -> Token
BlockComment (Text -> Token) -> ([Text] -> Text) -> [Text] -> Token
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"/*"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> Token)
-> ParsecT Void Text Identity [Text]
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [Text]
more) ParsecT Void Text Identity Token
-> String -> ParsecT Void Text Identity Token
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
""
  where
    more :: ParsecT Void Text Identity [Tokens Text]
more = [ParsecT Void Text Identity [Tokens Text]]
-> ParsecT Void Text Identity [Tokens Text]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [[Tokens Text
"*/"] [Tokens Text]
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Tokens 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
<$ 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 (Text -> ParsecT Void Text Identity ()
string_ Text
"*/")  -- comment ended
        ,Char -> ParsecT Void Text Identity ()
char_ Char
'*' ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Tokens Text]
-> ParsecT Void Text Identity [Tokens 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
*> ((Tokens Text
"*"Tokens Text -> [Tokens Text] -> [Tokens Text]
forall a. a -> [a] -> [a]
:) ([Tokens Text] -> [Tokens Text])
-> ParsecT Void Text Identity [Tokens Text]
-> ParsecT Void Text Identity [Tokens Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity [Tokens Text]
more) -- comment contains * but this isn't the comment end token
        -- not sure if there's an easy optimisation here
        ,(:) (Tokens Text -> [Tokens Text] -> [Tokens Text])
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity ([Tokens Text] -> [Tokens Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"non comment terminator text") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'*') ParsecT Void Text Identity ([Tokens Text] -> [Tokens Text])
-> ParsecT Void Text Identity [Tokens Text]
-> ParsecT Void Text Identity [Tokens 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
<*> ParsecT Void Text Identity [Tokens Text]
more]

{-
This is to improve user experience: provide an error if we see */
outside a comment. This could potentially break postgres ops with */
in them (which is a stupid thing to do). In other cases, the user
should write * / instead (I can't think of any cases when this would
be valid syntax though).
-}

dontParseEndBlockComment :: Dialect -> Parser Token
dontParseEndBlockComment :: Dialect -> ParsecT Void Text Identity Token
dontParseEndBlockComment Dialect
_ =
    -- don't use try, then it should commit to the error
    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 Token
-> ParsecT Void Text Identity 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
*> String -> ParsecT Void Text Identity Token
forall a. String -> ParsecT Void Text Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 -> ParsecT Void Text Identity Token
sqlNumber Dialect
d =
    Text -> Token
SqlNumber (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
completeNumber
    -- this is for definitely avoiding possibly ambiguous source
    ParsecT Void Text Identity Token
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
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 [-- special case to allow e.g. 1..2
               Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diPostgresSymbols Dialect
d)
               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 (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 (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
lookAhead (ParsecT Void Text Identity (Tokens Text)
 -> ParsecT Void Text Identity (Tokens Text))
-> ParsecT Void Text Identity (Tokens Text)
-> ParsecT Void Text Identity (Tokens Text)
forall a b. (a -> b) -> a -> b
$ 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)
-> String -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
""))
                  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.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (String -> ParsecT Void Text Identity Char
oneOf String
"eE."))
              ,ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (String -> ParsecT Void Text Identity Char
oneOf String
"eE.")
              ]
  where
    completeNumber :: ParsecT Void Text Identity Text
completeNumber =
      (ParsecT Void Text Identity Text
digits ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
forall {f :: * -> *} {b}. Alternative f => f b -> f (b -> b) -> f b
<??> (ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
pp ParsecT Void Text Identity Text
dot ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity (Text -> Text)
forall {f :: * -> *} {a} {c}.
Alternative f =>
f (a -> c) -> f (c -> c) -> f (a -> c)
<??.> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
pp ParsecT Void Text Identity Text
digits)
      -- try is used in case we read a dot
      -- and it isn't part of a number
      -- if there are any following digits, then we commit
      -- to it being a number and not something else
      ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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 Text -> ParsecT Void Text Identity 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 (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
dot ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
digits))
      ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
forall {f :: * -> *} {b}. Alternative f => f b -> f (b -> b) -> f b
<??> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
pp ParsecT Void Text Identity Text
expon

    -- make sure we don't parse two adjacent dots in a number
    -- special case for postgresql, we backtrack if we see two adjacent dots
    -- to parse 1..2, but in other dialects we commit to the failure
    dot :: ParsecT Void Text Identity Text
dot = let p :: ParsecT Void Text Identity (Tokens Text)
p = 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.
ParsecT Void Text Identity 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
'.')
          in if Dialect -> Bool
diPostgresSymbols Dialect
d
             then ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
p
             else ParsecT Void Text Identity Text
ParsecT Void Text Identity (Tokens Text)
p
    expon :: ParsecT Void Text Identity Text
expon = 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
<$> String -> ParsecT Void Text Identity Char
oneOf String
"eE" ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
sInt
    sInt :: ParsecT Void Text Identity Text
sInt = Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" (Char -> Text
T.singleton (Char -> Text)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT Void Text Identity Char
oneOf String
"+-") ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
digits
    pp :: ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
pp = (ParsecT Void Text Identity Text
-> (Text -> Text -> Text)
-> ParsecT Void Text Identity (Text -> Text)
forall {f :: * -> *} {a} {a} {c}.
Applicative f =>
f a -> (a -> a -> c) -> f (a -> c)
<$$> Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>))
    f b
p <??> :: f b -> f (b -> b) -> f b
<??> f (b -> b)
q = f b
p f b -> f (b -> b) -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (b -> b) -> f (b -> b) -> f (b -> b)
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option b -> b
forall a. a -> a
id f (b -> b)
q
    f a
pa <$$> :: f a -> (a -> a -> c) -> f (a -> c)
<$$> a -> a -> c
c = f a
pa f a -> f (a -> a -> c) -> f (a -> c)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> (a -> a -> c) -> f (a -> a -> c)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> a -> c) -> a -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> c
c)
    f (a -> c)
pa <??.> :: f (a -> c) -> f (c -> c) -> f (a -> c)
<??.> f (c -> c)
pb =
       let c :: (a -> a -> c) -> f a -> f (a -> c)
c = (a -> a -> c) -> f a -> f (a -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>) ((a -> a -> c) -> f a -> f (a -> c))
-> ((a -> a -> c) -> a -> a -> c)
-> (a -> a -> c)
-> f a
-> f (a -> c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> c) -> a -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip
       in (c -> c) -> (a -> c) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((c -> c) -> (a -> c) -> a -> c)
-> f (a -> c) -> f ((c -> c) -> a -> c)
forall {a} {a} {c}. (a -> a -> c) -> f a -> f (a -> c)
`c` f (a -> c)
pa f ((c -> c) -> a -> c) -> f (c -> c) -> f (a -> c)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (c -> c) -> f (c -> c) -> f (c -> c)
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option c -> c
forall a. a -> a
id f (c -> c)
pb

digits :: Parser Text
digits :: ParsecT Void Text Identity Text
digits = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"digit") Char -> Bool
Token Text -> Bool
isDigit

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

positionalArg :: Dialect -> Parser Token
positionalArg :: Dialect -> ParsecT Void Text Identity Token
positionalArg Dialect
d =
    Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diPositionalArg Dialect
d) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
    -- use try to avoid ambiguities with other syntax which starts with dollar
    Int -> Token
PositionalArg (Int -> Token)
-> ParsecT Void Text Identity Int
-> ParsecT Void Text Identity 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
*> (String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (Text -> String) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Int)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
digits))

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

-- 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 -> ParsecT Void Text Identity Token
prefixedVariable Dialect
d = ParsecT Void Text Identity Token
-> ParsecT Void Text Identity 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 (ParsecT Void Text Identity Token
 -> ParsecT Void Text Identity Token)
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Token]
-> ParsecT Void Text Identity Token
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
identifierString
    ,Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diAtIdentifier Dialect
d) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
identifierString
    ,Bool -> ParsecT Void Text Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Dialect -> Bool
diHashIdentifier Dialect
d) ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Token
-> ParsecT Void Text Identity Token
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
<*> ParsecT Void Text Identity Text
identifierString
    ]

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

{-
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 -> ParsecT Void Text Identity Token
symbol Dialect
d  = Text -> Token
Symbol (Text -> Token)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Token
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([[ParsecT Void Text Identity Text]]
-> [ParsecT Void Text Identity Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [[ParsecT Void Text Identity Text]
[ParsecT Void Text Identity (Tokens Text)]
dots
   ,if Dialect -> Bool
diPostgresSymbols Dialect
d
    then [ParsecT Void Text Identity Text]
[ParsecT Void Text Identity (Tokens Text)]
postgresExtraSymbols
    else []
   ,[ParsecT Void Text Identity Text]
miscSymbol
   ,if Dialect -> Bool
diOdbc Dialect
d then [ParsecT Void Text Identity Text]
[ParsecT Void Text Identity (Tokens Text)]
odbcSymbol else []
   ,if Dialect -> Bool
diPostgresSymbols Dialect
d
    then [ParsecT Void Text Identity Text]
generalizedPostgresqlOperator
    else [ParsecT Void Text Identity Text]
basicAnsiOps
   ])
 where
   dots :: [ParsecT Void Text Identity (Tokens Text)]
dots = [Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"dot") (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.
ParsecT Void Text Identity 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.
ParsecT Void Text Identity 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 :: [ParsecT Void Text Identity Text]
miscSymbol = (Char -> ParsecT Void Text Identity Text)
-> String -> [ParsecT Void Text Identity Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ParsecT Void Text Identity Text
Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> ParsecT Void Text Identity Text)
-> (Char -> Text) -> Char -> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) (String -> [ParsecT Void Text Identity Text])
-> String -> [ParsecT Void Text Identity Text]
forall a b. (a -> b) -> a -> b
$
                case () of
                    ()
_ | Dialect -> Bool
diSqlServerSymbols Dialect
d -> String
",;():?"
                      | Dialect -> Bool
diPostgresSymbols Dialect
d -> String
"[],;()"
                      | Bool
otherwise -> String
"[],;():?"

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

   basicAnsiOps :: [ParsecT Void Text Identity Text]
basicAnsiOps = (Tokens Text -> ParsecT Void Text Identity Text)
-> [Tokens Text] -> [ParsecT Void Text Identity Text]
forall a b. (a -> b) -> [a] -> [b]
map (ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> (Tokens Text -> ParsecT Void Text Identity Text)
-> Tokens Text
-> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text -> ParsecT Void Text Identity 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
">=",Tokens Text
"<=",Tokens Text
"!=",Tokens Text
"<>"]
                  [ParsecT Void Text Identity Text]
-> [ParsecT Void Text Identity Text]
-> [ParsecT Void Text Identity Text]
forall a. [a] -> [a] -> [a]
++ (Char -> ParsecT Void Text Identity Text)
-> String -> [ParsecT Void Text Identity Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> ParsecT Void Text Identity Text
Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> ParsecT Void Text Identity Text)
-> (Char -> Text) -> Char -> ParsecT Void Text Identity Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton) String
"+-^*/%~&<>="
                  [ParsecT Void Text Identity Text]
-> [ParsecT Void Text Identity Text]
-> [ParsecT Void Text Identity Text]
forall a. [a] -> [a] -> [a]
++ [ParsecT Void Text Identity Text]
pipes
   pipes :: [ParsecT Void Text Identity 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
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
*>
            [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Text
"||" Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity 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
'|' ParsecT Void Text Identity Text
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity 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.
ParsecT Void Text Identity 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 -> ParsecT Void Text Identity 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 :: [ParsecT Void Text Identity Text]
generalizedPostgresqlOperator = [ParsecT Void Text Identity Text
singlePlusMinus,ParsecT Void Text Identity Text
opMoreChars]
  where
    allOpSymbols :: String
allOpSymbols = String
"+-*/<>=~!@#%^&|`?"
    -- these are the symbols when if part of a multi character
    -- operator permit the operator to end with a + or - symbol
    exceptionOpSymbols :: String
exceptionOpSymbols = String
"~!@#%^&|`?"

    -- special case for parsing a single + or - symbol
    singlePlusMinus :: ParsecT Void Text Identity Text
singlePlusMinus = ParsecT Void Text Identity Text -> ParsecT Void Text Identity 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 (ParsecT Void Text Identity Text
 -> ParsecT Void Text Identity Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ do
      Char
c <- String -> ParsecT Void Text Identity Char
oneOf String
"+-"
      ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (ParsecT Void Text Identity Char -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Char -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT Void Text Identity Char
oneOf String
allOpSymbols
      Text -> ParsecT Void Text Identity Text
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ParsecT Void Text Identity Text)
-> Text -> ParsecT Void Text Identity Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
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 :: ParsecT Void Text Identity Text
moreOpCharsException = do
       Char
c <- String -> ParsecT Void Text Identity Char
oneOf ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
`notElemChar` String
"-/*") String
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.
ParsecT Void Text Identity 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.
ParsecT Void Text Identity 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.
ParsecT Void Text Identity 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
'/'))
       Char -> Text -> Text
T.cons Char
c (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" ParsecT Void Text Identity Text
moreOpCharsException

    opMoreChars :: ParsecT Void Text Identity Text
opMoreChars = [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity 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
<$> String -> ParsecT Void Text Identity Char
oneOf String
exceptionOpSymbols
        ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" ParsecT Void Text Identity 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 (String -> ParsecT Void Text Identity Char
oneOf String
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.
ParsecT Void Text Identity 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 (String -> ParsecT Void Text Identity Char
oneOf String
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.
ParsecT Void Text Identity 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.
ParsecT Void Text Identity 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
             String -> ParsecT Void Text Identity Char
oneOf String
"<>=")
        ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity 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
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" ParsecT Void Text Identity Text
opMoreChars
       ]

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

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

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

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

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

oneOf :: [Char] -> Parser Char
oneOf :: String -> ParsecT Void Text Identity Char
oneOf = String -> 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 -> String -> Bool
notElemChar Char
a String
b = Char
a Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
b :: [Char])

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


{-
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) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Text -> Bool
`T.elem` Text
a') (String
"~!@#%^&|`?" :: [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 -> String
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 String
_ []) = Maybe (Token SQLStream, SQLStream)
Maybe (WithPos Token, SQLStream)
forall a. Maybe a
Nothing
  take1_ (SQLStream String
str (WithPos Token
t:[WithPos Token]
ts)) = (WithPos Token, SQLStream) -> Maybe (WithPos Token, SQLStream)
forall a. a -> Maybe a
Just
    ( WithPos Token
t
    , String -> [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.:|[])) String
str) [WithPos Token]
ts
    )
  takeN_ :: Int -> SQLStream -> Maybe (Tokens SQLStream, SQLStream)
takeN_ Int
n (SQLStream String
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 ([], String -> [WithPos Token] -> SQLStream
SQLStream String
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, String -> [WithPos Token] -> SQLStream
SQLStream String
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, String -> [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) String
str) [WithPos Token]
s')
  takeWhile_ :: (Token SQLStream -> Bool)
-> SQLStream -> (Tokens SQLStream, SQLStream)
takeWhile_ Token SQLStream -> Bool
f (SQLStream String
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, String -> [WithPos Token] -> SQLStream
SQLStream String
str [WithPos Token]
s')
      Just NonEmpty (WithPos Token)
nex -> ([WithPos Token]
Tokens SQLStream
x, String -> [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) String
str) [WithPos Token]
s')

instance VisualStream SQLStream where
  showTokens :: Proxy SQLStream -> NonEmpty (Token SQLStream) -> String
showTokens Proxy SQLStream
Proxy = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
DL.intercalate String
" "
    ([String] -> String)
-> (NonEmpty (WithPos Token) -> [String])
-> NonEmpty (WithPos Token)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList
    (NonEmpty String -> [String])
-> (NonEmpty (WithPos Token) -> NonEmpty String)
-> NonEmpty (WithPos Token)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithPos Token -> String)
-> NonEmpty (WithPos Token) -> NonEmpty String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Token -> String
showMyToken (Token -> String)
-> (WithPos Token -> Token) -> WithPos Token -> String
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
  reachOffset :: Int -> PosState SQLStream -> (Maybe String, PosState SQLStream)
reachOffset Int
o M.PosState {Int
String
SourcePos
Pos
SQLStream
pstateSourcePos :: forall s. PosState s -> SourcePos
pstateInput :: SQLStream
pstateOffset :: Int
pstateSourcePos :: SourcePos
pstateTabWidth :: Pos
pstateLinePrefix :: String
pstateInput :: forall s. PosState s -> s
pstateOffset :: forall s. PosState s -> Int
pstateTabWidth :: forall s. PosState s -> Pos
pstateLinePrefix :: forall s. PosState s -> String
..} =
    ( String -> Maybe String
forall a. a -> Maybe a
Just (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
restOfLine)
    , PosState
        { pstateInput :: SQLStream
pstateInput = SQLStream
            { sqlStreamInput :: String
sqlStreamInput = String
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 :: String
pstateLinePrefix = String
prefix
        }
    )
    where
      prefix :: String
prefix =
        if Bool
sameLine
          then String
pstateLinePrefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
preLine
          else String
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)
      (String
preStr, String
postStr) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
tokensConsumed (SQLStream -> String
sqlStreamInput SQLStream
pstateInput)
      preLine :: String
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
$ String
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
      restOfLine :: String
restOfLine = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
postStr

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 -> String
showMyToken = Text -> String
T.unpack (Text -> String) -> (Token -> Text) -> Token -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dialect -> Token -> Text
prettyToken Dialect
ansi2011