switch tests to hspec, improve error messages
This commit is contained in:
Jake Wheat
parent
fadd010942
commit
c11bee4a9c
36 changed files with 2570 additions and 1809 deletions
|
|
@ -74,7 +74,6 @@ try again to add annotation to the ast
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Language.SQL.SimpleSQL.Lex
|
||||
(Token(..)
|
||||
,WithPos(..)
|
||||
|
|
@ -111,21 +110,26 @@ import Text.Megaparsec
|
|||
,pstateSourcePos
|
||||
,statePosState
|
||||
,mkPos
|
||||
,hidden
|
||||
,setErrorOffset
|
||||
|
||||
,choice
|
||||
,satisfy
|
||||
,takeWhileP
|
||||
,takeWhile1P
|
||||
,(<?>)
|
||||
,eof
|
||||
,many
|
||||
,try
|
||||
,option
|
||||
,(<|>)
|
||||
,notFollowedBy
|
||||
,manyTill
|
||||
,anySingle
|
||||
,lookAhead
|
||||
,match
|
||||
,optional
|
||||
,label
|
||||
,chunk
|
||||
,region
|
||||
,anySingle
|
||||
)
|
||||
import qualified Text.Megaparsec as M
|
||||
import Text.Megaparsec.Char
|
||||
|
|
@ -139,17 +143,17 @@ 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 Control.Monad (void)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe (fromMaybe)
|
||||
--import Text.Megaparsec.Debug (dbg)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -189,16 +193,26 @@ data Token
|
|||
| LineComment Text
|
||||
-- | A block comment, \/* stuff *\/, includes the comment delimiters
|
||||
| BlockComment Text
|
||||
-- | Used for generating better error messages when using the
|
||||
-- output of the lexer in a parser
|
||||
| InvalidToken Text
|
||||
deriving (Eq,Show,Ord)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- main api functions
|
||||
|
||||
-- | Lex some SQL to a list of tokens.
|
||||
-- | Lex some SQL to a list of tokens. The invalid token setting
|
||||
-- changes the behaviour so that if there's a parse error at the start
|
||||
-- of parsing an invalid token, it adds a final InvalidToken with the
|
||||
-- character to the result then stop parsing. This can then be used to
|
||||
-- produce a parse error with more context in the parser. Parse errors
|
||||
-- within tokens still produce Left errors.
|
||||
lexSQLWithPositions
|
||||
:: Dialect
|
||||
-- ^ dialect of SQL to use
|
||||
-> Bool
|
||||
-- ^ produce InvalidToken
|
||||
-> Text
|
||||
-- ^ filename to use in error messages
|
||||
-> Maybe (Int,Int)
|
||||
|
|
@ -207,13 +221,14 @@ lexSQLWithPositions
|
|||
-> Text
|
||||
-- ^ the SQL source to lex
|
||||
-> Either ParseError [WithPos Token]
|
||||
lexSQLWithPositions dialect fn p src = myParse fn p (many (sqlToken dialect) <* (eof <?> "")) src
|
||||
|
||||
lexSQLWithPositions dialect pit fn p src = myParse fn p (tokens dialect pit) src
|
||||
|
||||
-- | Lex some SQL to a list of tokens.
|
||||
lexSQL
|
||||
:: Dialect
|
||||
-- ^ dialect of SQL to use
|
||||
-> Bool
|
||||
-- ^ produce InvalidToken, see lexSQLWithPositions
|
||||
-> Text
|
||||
-- ^ filename to use in error messages
|
||||
-> Maybe (Int,Int)
|
||||
|
|
@ -222,8 +237,8 @@ lexSQL
|
|||
-> Text
|
||||
-- ^ the SQL source to lex
|
||||
-> Either ParseError [Token]
|
||||
lexSQL dialect fn p src =
|
||||
map tokenVal <$> lexSQLWithPositions dialect fn p src
|
||||
lexSQL dialect pit fn p src =
|
||||
map tokenVal <$> lexSQLWithPositions dialect pit fn p src
|
||||
|
||||
myParse :: Text -> Maybe (Int,Int) -> Parser a -> Text -> Either ParseError a
|
||||
myParse name sp' p s =
|
||||
|
|
@ -271,6 +286,7 @@ prettyToken _ (SqlNumber r) = r
|
|||
prettyToken _ (Whitespace t) = t
|
||||
prettyToken _ (LineComment l) = l
|
||||
prettyToken _ (BlockComment c) = c
|
||||
prettyToken _ (InvalidToken t) = t
|
||||
|
||||
prettyTokens :: Dialect -> [Token] -> Text
|
||||
prettyTokens d ts = T.concat $ map (prettyToken d) ts
|
||||
|
|
@ -281,24 +297,54 @@ prettyTokens d ts = T.concat $ map (prettyToken d) ts
|
|||
|
||||
-- | parser for a sql token
|
||||
sqlToken :: Dialect -> Parser (WithPos Token)
|
||||
sqlToken d = (do
|
||||
-- possibly there's a more efficient way of doing the source positions?
|
||||
sqlToken d =
|
||||
withPos $ hidden $ choice $
|
||||
[sqlString d
|
||||
,identifier d
|
||||
,lineComment d
|
||||
,blockComment d
|
||||
,sqlNumber d
|
||||
,positionalArg d
|
||||
,dontParseEndBlockComment d
|
||||
,prefixedVariable d
|
||||
,symbol d
|
||||
,sqlWhitespace d]
|
||||
|
||||
--fakeSourcePos :: SourcePos
|
||||
--fakeSourcePos = SourcePos "" (mkPos 1) (mkPos 1)
|
||||
|
||||
--------------------------------------
|
||||
|
||||
-- position and error helpers
|
||||
|
||||
withPos :: Parser a -> Parser (WithPos a)
|
||||
withPos p = do
|
||||
sp <- getSourcePos
|
||||
off <- getOffset
|
||||
t <- choice
|
||||
[sqlString d
|
||||
,identifier d
|
||||
,lineComment d
|
||||
,blockComment d
|
||||
,sqlNumber d
|
||||
,positionalArg d
|
||||
,dontParseEndBlockComment d
|
||||
,prefixedVariable d
|
||||
,symbol d
|
||||
,sqlWhitespace d]
|
||||
a <- p
|
||||
off1 <- getOffset
|
||||
ep <- getSourcePos
|
||||
pure $ WithPos sp ep (off1 - off) t) <?> "valid lexical token"
|
||||
pure $ WithPos sp ep (off1 - off) a
|
||||
|
||||
{-
|
||||
|
||||
TODO: extend this idea, to recover to parsing regular tokens after an
|
||||
invalid one. This can then support resumption after error in the parser.
|
||||
This would also need something similar being done for parse errors
|
||||
within lexical tokens.
|
||||
|
||||
-}
|
||||
invalidToken :: Dialect -> Parser (WithPos Token)
|
||||
invalidToken _ =
|
||||
withPos $ (hidden eof *> fail "") <|> (InvalidToken . T.singleton <$> anySingle)
|
||||
|
||||
tokens :: Dialect -> Bool -> Parser [WithPos Token]
|
||||
tokens d pit = do
|
||||
x <- many (sqlToken d)
|
||||
if pit
|
||||
then choice [x <$ hidden eof
|
||||
,(\y -> x ++ [y]) <$> hidden (invalidToken d)]
|
||||
else x <$ hidden eof
|
||||
|
||||
--------------------------------------
|
||||
|
||||
|
|
@ -313,27 +359,38 @@ x'hexidecimal string'
|
|||
-}
|
||||
|
||||
sqlString :: Dialect -> Parser Token
|
||||
sqlString d = dollarString <|> csString <|> normalString
|
||||
sqlString d =
|
||||
(if (diDollarString d)
|
||||
then (dollarString <|>)
|
||||
else id) csString <|> normalString
|
||||
where
|
||||
dollarString = do
|
||||
guard $ diDollarString d
|
||||
-- use try because of ambiguity with symbols and with
|
||||
-- positional arg
|
||||
delim <- (\x -> T.concat ["$",x,"$"])
|
||||
<$> try (char '$' *> option "" identifierString <* char '$')
|
||||
SqlString delim delim . T.pack <$> manyTill anySingle (try $ string delim)
|
||||
normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix False "")
|
||||
normalStringSuffix allowBackslash t = do
|
||||
s <- takeWhileP Nothing $ if allowBackslash
|
||||
then (`notElemChar` "'\\")
|
||||
else (/= '\'')
|
||||
-- deal with '' or \' as literal quote character
|
||||
choice [do
|
||||
ctu <- choice ["''" <$ try (string "''")
|
||||
,"\\'" <$ string "\\'"
|
||||
,"\\" <$ char '\\']
|
||||
normalStringSuffix allowBackslash $ T.concat [t,s,ctu]
|
||||
,T.concat [t,s] <$ char '\'']
|
||||
delim <- fstMatch (try (char '$' *> hoptional_ identifierString <* char '$'))
|
||||
let moreDollarString =
|
||||
label (T.unpack delim) $ takeWhileP_ Nothing (/='$') *> checkDollar
|
||||
checkDollar = label (T.unpack delim) $
|
||||
choice
|
||||
[lookAhead (chunk_ delim) *> pure () -- would be nice not to parse it twice?
|
||||
-- but makes the whole match trick much less neat
|
||||
,char_ '$' *> moreDollarString]
|
||||
str <- fstMatch moreDollarString
|
||||
chunk_ delim
|
||||
pure $ SqlString delim delim str
|
||||
lq = label "'" $ char_ '\''
|
||||
normalString = SqlString "'" "'" <$> (lq *> normalStringSuffix False)
|
||||
normalStringSuffix allowBackslash = label "'" $ do
|
||||
let regularChar = if allowBackslash
|
||||
then (\x -> x /= '\'' && x /='\\')
|
||||
else (\x -> x /= '\'')
|
||||
nonQuoteStringChar = takeWhileP_ Nothing regularChar
|
||||
nonRegularContinue =
|
||||
(hchunk_ "''" <|> hchunk_ "\\'" <|> hchar_ '\\')
|
||||
moreChars = nonQuoteStringChar
|
||||
*> (option () (nonRegularContinue *> moreChars))
|
||||
fstMatch moreChars <* lq
|
||||
|
||||
-- try is used to to avoid conflicts with
|
||||
-- identifiers which can start with n,b,x,u
|
||||
-- once we read the quote type and the starting '
|
||||
|
|
@ -345,13 +402,13 @@ sqlString d = dollarString <|> csString <|> normalString
|
|||
csString
|
||||
| diEString d =
|
||||
choice [SqlString <$> try (string "e'" <|> string "E'")
|
||||
<*> pure "'" <*> normalStringSuffix True ""
|
||||
<*> pure "'" <*> normalStringSuffix True
|
||||
,csString']
|
||||
| otherwise = csString'
|
||||
csString' = SqlString
|
||||
<$> try cs
|
||||
<*> pure "'"
|
||||
<*> normalStringSuffix False ""
|
||||
<*> normalStringSuffix False
|
||||
csPrefixes = map (`T.cons` "'") "nNbBxX" ++ ["u&'", "U&'"]
|
||||
cs :: Parser Text
|
||||
cs = choice $ map string csPrefixes
|
||||
|
|
@ -370,42 +427,49 @@ u&"unicode quoted identifier"
|
|||
|
||||
identifier :: Dialect -> Parser Token
|
||||
identifier d =
|
||||
choice
|
||||
choice $
|
||||
[quotedIden
|
||||
,unicodeQuotedIden
|
||||
,regularIden
|
||||
,guard (diBackquotedIden d) >> mySqlQuotedIden
|
||||
,guard (diSquareBracketQuotedIden d) >> sqlServerQuotedIden
|
||||
]
|
||||
,regularIden]
|
||||
++ [mySqlQuotedIden | diBackquotedIden d]
|
||||
++ [sqlServerQuotedIden | diSquareBracketQuotedIden d]
|
||||
where
|
||||
regularIden = Identifier Nothing <$> identifierString
|
||||
quotedIden = Identifier (Just ("\"","\"")) <$> qidenPart
|
||||
mySqlQuotedIden = Identifier (Just ("`","`"))
|
||||
<$> (char '`' *> takeWhile1P Nothing (/='`') <* char '`')
|
||||
sqlServerQuotedIden = Identifier (Just ("[","]"))
|
||||
<$> (char '[' *> takeWhile1P Nothing (`notElemChar` "[]") <* char ']')
|
||||
quotedIden = Identifier (Just ("\"","\"")) <$> qiden
|
||||
failEmptyIden c = failOnThis (char_ c) "empty identifier"
|
||||
mySqlQuotedIden =
|
||||
Identifier (Just ("`","`")) <$>
|
||||
(char_ '`' *>
|
||||
(failEmptyIden '`'
|
||||
<|> (takeWhile1P Nothing (/='`') <* char_ '`')))
|
||||
sqlServerQuotedIden =
|
||||
Identifier (Just ("[","]")) <$>
|
||||
(char_ '[' *>
|
||||
(failEmptyIden ']'
|
||||
<|> (takeWhileP Nothing (`notElemChar` "[]")
|
||||
<* choice [char_ ']'
|
||||
-- should probably do this error message as
|
||||
-- a proper unexpected message
|
||||
,failOnThis (char_ '[') "unexpected ["])))
|
||||
-- try is used here to avoid a conflict with identifiers
|
||||
-- and quoted strings which also start with a 'u'
|
||||
unicodeQuotedIden = Identifier
|
||||
<$> (f <$> try (oneOf "uU" <* string "&"))
|
||||
<*> qidenPart
|
||||
<*> qiden
|
||||
where f x = Just (T.cons x "&\"", "\"")
|
||||
qidenPart = char '"' *> qidenSuffix ""
|
||||
qidenSuffix t = do
|
||||
s <- takeWhileP Nothing (/='"')
|
||||
void $ char '"'
|
||||
-- deal with "" as literal double quote character
|
||||
choice [do
|
||||
void $ char '"'
|
||||
qidenSuffix $ T.concat [t,s,"\"\""]
|
||||
,pure $ T.concat [t,s]]
|
||||
qiden =
|
||||
char_ '"' *> (failEmptyIden '"' <|> fstMatch moreQIden <* char_ '"')
|
||||
moreQIden =
|
||||
label "\""
|
||||
(takeWhileP_ Nothing (/='"')
|
||||
*> hoptional_ (chunk "\"\"" *> moreQIden))
|
||||
|
||||
identifierString :: Parser Text
|
||||
identifierString = (do
|
||||
identifierString = label "identifier" $ do
|
||||
c <- satisfy isFirstLetter
|
||||
choice
|
||||
[T.cons c <$> takeWhileP (Just "identifier char") isIdentifierChar
|
||||
,pure $ T.singleton c]) <?> "identifier"
|
||||
[T.cons c <$> takeWhileP Nothing isIdentifierChar
|
||||
,pure $ T.singleton c]
|
||||
where
|
||||
isFirstLetter c = c == '_' || isAlpha c
|
||||
|
||||
|
|
@ -415,12 +479,11 @@ isIdentifierChar c = c == '_' || isAlphaNum c
|
|||
--------------------------------------
|
||||
|
||||
lineComment :: Dialect -> Parser Token
|
||||
lineComment _ = do
|
||||
try (string_ "--") <?> ""
|
||||
rest <- takeWhileP (Just "non newline character") (/='\n')
|
||||
lineComment _ = LineComment <$> fstMatch (do
|
||||
hidden (string_ "--")
|
||||
takeWhileP_ Nothing (/='\n')
|
||||
-- can you optionally read the \n to terminate the takewhilep without reparsing it?
|
||||
suf <- option "" ("\n" <$ char_ '\n')
|
||||
pure $ LineComment $ T.concat ["--", rest, suf]
|
||||
hoptional_ $ char_ '\n')
|
||||
|
||||
--------------------------------------
|
||||
|
||||
|
|
@ -428,28 +491,30 @@ lineComment _ = do
|
|||
-- 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 _ = (do
|
||||
try $ string_ "/*"
|
||||
BlockComment . T.concat . ("/*":) <$> more) <?> ""
|
||||
blockComment _ = BlockComment <$> fstMatch bc
|
||||
where
|
||||
more = choice
|
||||
[["*/"] <$ try (string_ "*/") -- comment ended
|
||||
,char_ '*' *> (("*":) <$> more) -- comment contains * but this isn't the comment end token
|
||||
-- not sure if there's an easy optimisation here
|
||||
,(:) <$> takeWhile1P (Just "non comment terminator text") (/= '*') <*> more]
|
||||
bc = chunk_ "/*" *> moreBlockChars
|
||||
regularBlockCommentChars = label "*/" $
|
||||
takeWhileP_ Nothing (\x -> x /= '*' && x /= '/')
|
||||
continueBlockComment = label "*/" (char_ '*' <|> char_ '/') *> moreBlockChars
|
||||
endComment = label "*/" $ chunk_ "*/"
|
||||
moreBlockChars = label "*/" $
|
||||
regularBlockCommentChars
|
||||
*> (endComment
|
||||
<|> (label "*/" bc *> moreBlockChars) -- nest
|
||||
<|> continueBlockComment)
|
||||
|
||||
{-
|
||||
This is to improve user experience: provide an error if we see */
|
||||
outside a comment. This could potentially break postgres ops with */
|
||||
in them (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).
|
||||
in them (it is not sensible to use operators that contain this as a
|
||||
substring). In other cases, the user should write * / instead (I can't
|
||||
think of any cases when this would be valid syntax).
|
||||
-}
|
||||
|
||||
dontParseEndBlockComment :: Dialect -> Parser Token
|
||||
dontParseEndBlockComment _ =
|
||||
-- don't use try, then it should commit to the error
|
||||
try (string "*/") *> fail "comment end without comment start"
|
||||
failOnThis (chunk_ "*/") "comment end without comment start"
|
||||
|
||||
--------------------------------------
|
||||
|
||||
|
|
@ -482,63 +547,51 @@ followed by an optional exponent
|
|||
|
||||
sqlNumber :: Dialect -> Parser Token
|
||||
sqlNumber d =
|
||||
SqlNumber <$> completeNumber
|
||||
-- this is for definitely avoiding possibly ambiguous source
|
||||
<* choice [-- special case to allow e.g. 1..2
|
||||
guard (diPostgresSymbols d)
|
||||
*> void (lookAhead $ try (string ".." <?> ""))
|
||||
<|> void (notFollowedBy (oneOf "eE."))
|
||||
,notFollowedBy (oneOf "eE.")
|
||||
]
|
||||
SqlNumber <$> fstMatch
|
||||
((numStartingWithDigits <|> numStartingWithDot)
|
||||
*> hoptional_ expo *> trailingCheck)
|
||||
where
|
||||
completeNumber =
|
||||
(digits <??> (pp dot <??.> pp 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
|
||||
<|> try ((<>) <$> dot <*> digits))
|
||||
<??> pp 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 = let p = string "." <* notFollowedBy (char '.')
|
||||
in if diPostgresSymbols d
|
||||
then try p
|
||||
else p
|
||||
expon = T.cons <$> oneOf "eE" <*> sInt
|
||||
sInt = (<>) <$> option "" (T.singleton <$> oneOf "+-") <*> digits
|
||||
pp = (<$$> (<>))
|
||||
p <??> q = p <**> option id q
|
||||
pa <$$> c = pa <**> pure (flip c)
|
||||
pa <??.> pb =
|
||||
let c = (<$>) . flip
|
||||
in (.) `c` pa <*> option id pb
|
||||
numStartingWithDigits = digits_ *> hoptional_ (safeDot *> hoptional_ digits_)
|
||||
-- use try, so we don't commit to a number when there's a . with no following digit
|
||||
numStartingWithDot = try (safeDot *> digits_)
|
||||
expo = (char_ 'e' <|> char_ 'E') *> optional_ (char_ '-' <|> char_ '+') *> digits_
|
||||
digits_ = label "digits" $ takeWhile1P_ Nothing isDigit
|
||||
-- if there's a '..' next to the number, and it's a dialect that has .. as a
|
||||
-- lexical token, parse what we have so far and leave the dots in the chamber
|
||||
-- otherwise, give an error
|
||||
safeDot =
|
||||
if diPostgresSymbols d
|
||||
then try (char_ '.' <* notFollowedBy (char_ '.'))
|
||||
else char_ '.' <* notFollowedBy (char_ '.')
|
||||
-- additional check to give an error if the number is immediately
|
||||
-- followed by e, E or . with an exception for .. if this symbol is supported
|
||||
trailingCheck =
|
||||
if diPostgresSymbols d
|
||||
then -- special case to allow e.g. 1..2
|
||||
void (lookAhead $ hidden $ chunk_ "..")
|
||||
<|> void (notFollowedBy (oneOf "eE."))
|
||||
else notFollowedBy (oneOf "eE.")
|
||||
|
||||
digits :: Parser Text
|
||||
digits = takeWhile1P (Just "digit") isDigit
|
||||
digits = label "digits" $ takeWhile1P Nothing isDigit
|
||||
|
||||
--------------------------------------
|
||||
|
||||
positionalArg :: Dialect -> Parser Token
|
||||
positionalArg d =
|
||||
guard (diPositionalArg d) >>
|
||||
-- use try to avoid ambiguities with other syntax which starts with dollar
|
||||
PositionalArg <$> try (char_ '$' *> (read . T.unpack <$> digits))
|
||||
choice [PositionalArg <$>
|
||||
try (char_ '$' *> (read . T.unpack <$> digits)) | diPositionalArg d]
|
||||
|
||||
--------------------------------------
|
||||
|
||||
-- todo: I think the try here should read a prefix char, then a single valid
|
||||
-- identifier char, then commit
|
||||
prefixedVariable :: Dialect -> Parser Token
|
||||
prefixedVariable d = try $ choice
|
||||
[PrefixedVariable <$> char ':' <*> identifierString
|
||||
,guard (diAtIdentifier d) >>
|
||||
PrefixedVariable <$> char '@' <*> identifierString
|
||||
,guard (diHashIdentifier d) >>
|
||||
PrefixedVariable <$> char '#' <*> identifierString
|
||||
]
|
||||
prefixedVariable d = try $ choice $
|
||||
[PrefixedVariable <$> char ':' <*> identifierString]
|
||||
++ [PrefixedVariable <$> char '@' <*> identifierString | diAtIdentifier d]
|
||||
++ [PrefixedVariable <$> char '#' <*> identifierString | diHashIdentifier d]
|
||||
|
||||
--------------------------------------
|
||||
|
||||
|
|
@ -565,7 +618,7 @@ symbol d = Symbol <$> choice (concat
|
|||
else basicAnsiOps
|
||||
])
|
||||
where
|
||||
dots = [takeWhile1P (Just "dot") (=='.')]
|
||||
dots = [takeWhile1P Nothing (=='.')]
|
||||
odbcSymbol = [string "{", string "}"]
|
||||
postgresExtraSymbols =
|
||||
[try (string ":=")
|
||||
|
|
@ -670,7 +723,7 @@ generalizedPostgresqlOperator = [singlePlusMinus,opMoreChars]
|
|||
--------------------------------------
|
||||
|
||||
sqlWhitespace :: Dialect -> Parser Token
|
||||
sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
|
||||
sqlWhitespace _ = Whitespace <$> takeWhile1P Nothing isSpace
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -679,6 +732,9 @@ sqlWhitespace _ = Whitespace <$> takeWhile1P (Just "whitespace") isSpace <?> ""
|
|||
char_ :: Char -> Parser ()
|
||||
char_ = void . char
|
||||
|
||||
hchar_ :: Char -> Parser ()
|
||||
hchar_ = void . hidden . char
|
||||
|
||||
string_ :: Text -> Parser ()
|
||||
string_ = void . string
|
||||
|
||||
|
|
@ -688,6 +744,39 @@ oneOf = M.oneOf
|
|||
notElemChar :: Char -> [Char] -> Bool
|
||||
notElemChar a b = a `notElem` (b :: [Char])
|
||||
|
||||
fstMatch :: Parser () -> Parser Text
|
||||
fstMatch x = fst <$> match x
|
||||
|
||||
hoptional_ :: Parser a -> Parser ()
|
||||
hoptional_ = void . hoptional
|
||||
|
||||
hoptional :: Parser a -> Parser (Maybe a)
|
||||
hoptional = hidden . optional
|
||||
|
||||
optional_ :: Parser a -> Parser ()
|
||||
optional_ = void . optional
|
||||
|
||||
--hoption :: a -> Parser a -> Parser a
|
||||
--hoption a p = hidden $ option a p
|
||||
|
||||
takeWhileP_ :: Maybe String -> (Char -> Bool) -> Parser ()
|
||||
takeWhileP_ m p = void $ takeWhileP m p
|
||||
|
||||
takeWhile1P_ :: Maybe String -> (Char -> Bool) -> Parser ()
|
||||
takeWhile1P_ m p = void $ takeWhile1P m p
|
||||
|
||||
chunk_ :: Text -> Parser ()
|
||||
chunk_ = void . chunk
|
||||
|
||||
hchunk_ :: Text -> Parser ()
|
||||
hchunk_ = void . hidden . chunk
|
||||
|
||||
failOnThis :: Parser () -> Text -> Parser a
|
||||
failOnThis p msg = do
|
||||
o <- getOffset
|
||||
hidden p
|
||||
region (setErrorOffset o) $ fail $ T.unpack msg
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -195,8 +195,8 @@ import Text.Megaparsec
|
|||
|
||||
,ParseErrorBundle(..)
|
||||
,errorBundlePretty
|
||||
|
||||
,(<?>)
|
||||
,hidden
|
||||
|
||||
,(<|>)
|
||||
,token
|
||||
,choice
|
||||
|
|
@ -212,6 +212,7 @@ import Text.Megaparsec
|
|||
)
|
||||
import qualified Control.Monad.Combinators.Expr as E
|
||||
import qualified Control.Monad.Permutations as P
|
||||
import qualified Text.Megaparsec as M
|
||||
|
||||
import Control.Monad.Reader
|
||||
(Reader
|
||||
|
|
@ -235,6 +236,8 @@ import qualified Data.Text as T
|
|||
import Language.SQL.SimpleSQL.Syntax
|
||||
import Language.SQL.SimpleSQL.Dialect
|
||||
import qualified Language.SQL.SimpleSQL.Lex as L
|
||||
--import Text.Megaparsec.Debug (dbg)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -324,9 +327,9 @@ wrapParse :: Parser a
|
|||
-> Text
|
||||
-> Either ParseError a
|
||||
wrapParse parser d f p src = do
|
||||
lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d f p src
|
||||
lx <- either (Left . LexError) Right $ L.lexSQLWithPositions d True f p src
|
||||
either (Left . ParseError) Right $
|
||||
runReader (runParserT (parser <* (eof <?> "")) (T.unpack f)
|
||||
runReader (runParserT (parser <* (hidden eof)) (T.unpack f)
|
||||
$ L.SQLStream (T.unpack src) $ filter notSpace lx) d
|
||||
where
|
||||
notSpace = notSpace' . L.tokenVal
|
||||
|
|
@ -379,20 +382,20 @@ u&"example quoted"
|
|||
-}
|
||||
|
||||
name :: Parser Name
|
||||
name = do
|
||||
name = label "name" $ do
|
||||
bl <- askDialect diKeywords
|
||||
uncurry Name <$> identifierTok bl
|
||||
|
||||
-- todo: replace (:[]) with a named function all over
|
||||
|
||||
names :: Parser [Name]
|
||||
names = reverse <$> (((:[]) <$> name) <??*> anotherName)
|
||||
names = label "name" (reverse <$> (((:[]) <$> name) <??*> anotherName))
|
||||
-- can't use a simple chain here since we
|
||||
-- want to wrap the . + name in a try
|
||||
-- this will change when this is left factored
|
||||
where
|
||||
anotherName :: Parser ([Name] -> [Name])
|
||||
anotherName = try ((:) <$> ((symbol "." *> name) <?> ""))
|
||||
anotherName = try ((:) <$> (hidden (symbol "." *> name)))
|
||||
|
||||
{-
|
||||
= Type Names
|
||||
|
|
@ -501,36 +504,48 @@ a lob type name.
|
|||
|
||||
Unfortunately, to improve the error messages, there is a lot of (left)
|
||||
factoring in this function, and it is a little dense.
|
||||
|
||||
the hideArg is used when the typename is used as part of a typed
|
||||
literal expression, to hide what comes after the paren in
|
||||
'typename('. This is so 'arbitrary_fn(' gives an 'expecting expression',
|
||||
instead of 'expecting expression or number', which is odd.
|
||||
|
||||
-}
|
||||
|
||||
typeName :: Parser TypeName
|
||||
typeName =
|
||||
(rowTypeName <|> intervalTypeName <|> otherTypeName)
|
||||
<??*> tnSuffix
|
||||
typeName = typeName' False
|
||||
|
||||
typeName' :: Bool -> Parser TypeName
|
||||
typeName' hideArg =
|
||||
label "typename" (
|
||||
(rowTypeName <|> intervalTypeName <|> otherTypeName)
|
||||
<??*> tnSuffix)
|
||||
where
|
||||
rowTypeName =
|
||||
RowTypeName <$> (keyword_ "row" *> parens (commaSep1 rowField))
|
||||
RowTypeName <$> (hidden (keyword_ "row") *> parens (commaSep1 rowField))
|
||||
rowField = (,) <$> name <*> typeName
|
||||
----------------------------
|
||||
intervalTypeName =
|
||||
keyword_ "interval" *>
|
||||
hidden (keyword_ "interval") *>
|
||||
(uncurry IntervalTypeName <$> intervalQualifier)
|
||||
----------------------------
|
||||
otherTypeName =
|
||||
nameOfType <**>
|
||||
(typeNameWithParens
|
||||
<|> pure Nothing <**> (timeTypeName <|> charTypeName)
|
||||
<|> pure Nothing <**> (hidden timeTypeName <|> hidden charTypeName)
|
||||
<|> pure TypeName)
|
||||
nameOfType = reservedTypeNames <|> names
|
||||
charTypeName = charSet <**> (option [] tcollate <$$$$> CharTypeName)
|
||||
<|> pure [] <**> (tcollate <$$$$> CharTypeName)
|
||||
typeNameWithParens =
|
||||
(openParen *> unsignedInteger)
|
||||
<**> (closeParen *> precMaybeSuffix
|
||||
<|> (precScaleTypeName <|> precLengthTypeName) <* closeParen)
|
||||
(hidden openParen *> (if hideArg then hidden unsignedInteger else unsignedInteger))
|
||||
<**> (closeParen *> hidden precMaybeSuffix
|
||||
<|> hidden (precScaleTypeName <|> precLengthTypeName) <* closeParen)
|
||||
precMaybeSuffix = (. Just) <$> (timeTypeName <|> charTypeName)
|
||||
<|> pure (flip PrecTypeName)
|
||||
precScaleTypeName = (comma *> unsignedInteger) <$$$> PrecScaleTypeName
|
||||
precScaleTypeName =
|
||||
(hidden comma *> (if hideArg then hidden unsignedInteger else unsignedInteger))
|
||||
<$$$> PrecScaleTypeName
|
||||
precLengthTypeName =
|
||||
Just <$> lobPrecSuffix
|
||||
<**> (optional lobUnits <$$$$> PrecLengthTypeName)
|
||||
|
|
@ -609,7 +624,7 @@ parameter = choice
|
|||
[Parameter <$ questionMark
|
||||
,HostParameter
|
||||
<$> hostParamTok
|
||||
<*> optional (keyword "indicator" *> hostParamTok)]
|
||||
<*> hoptional (keyword "indicator" *> hostParamTok)]
|
||||
|
||||
-- == positional arg
|
||||
|
||||
|
|
@ -734,11 +749,12 @@ this. also fix the monad -> applicative
|
|||
-}
|
||||
|
||||
intervalLit :: Parser ScalarExpr
|
||||
intervalLit = try (keyword_ "interval" >> do
|
||||
s <- optional $ choice [Plus <$ symbol_ "+"
|
||||
,Minus <$ symbol_ "-"]
|
||||
intervalLit =
|
||||
label "interval literal" $ try (keyword_ "interval" >> do
|
||||
s <- hoptional $ choice [Plus <$ symbol_ "+"
|
||||
,Minus <$ symbol_ "-"]
|
||||
lit <- singleQuotesOnlyStringTok
|
||||
q <- optional intervalQualifier
|
||||
q <- hoptional intervalQualifier
|
||||
mkIt s lit q)
|
||||
where
|
||||
mkIt Nothing val Nothing = pure $ TypedLit (TypeName [Name Nothing "interval"]) val
|
||||
|
|
@ -764,23 +780,41 @@ all the scalar expressions which start with an identifier
|
|||
|
||||
idenExpr :: Parser ScalarExpr
|
||||
idenExpr =
|
||||
-- todo: work out how to left factor this
|
||||
try (TypedLit <$> typeName <*> singleQuotesOnlyStringTok)
|
||||
<|> (names <**> option Iden app)
|
||||
<|> keywordFunctionOrIden
|
||||
-- todo: try reversing these
|
||||
-- then if it parses as a typename as part of a typed literal
|
||||
-- and not a regularapplike, then you'll get a better error message
|
||||
try typedLiteral <|> regularAppLike
|
||||
where
|
||||
-- special cases for keywords that can be parsed as an iden or app
|
||||
keywordFunctionOrIden = try $ do
|
||||
x <- unquotedIdentifierTok [] Nothing
|
||||
-- parse regular iden or app
|
||||
-- if it could potentially be a typed literal typename 'literaltext'
|
||||
-- optionally try to parse that
|
||||
regularAppLike = do
|
||||
e <- (keywordFunctionOrIden <|> (names <**> hoption Iden app))
|
||||
let getInt s = readMaybe (T.unpack s)
|
||||
case e of
|
||||
Iden nm -> tryTypedLiteral (TypeName nm) <|> pure e
|
||||
App nm [NumLit prec]
|
||||
| Just prec' <- getInt prec ->
|
||||
tryTypedLiteral (PrecTypeName nm prec') <|> pure e
|
||||
App nm [NumLit prec,NumLit scale]
|
||||
| Just prec' <- getInt prec
|
||||
, Just scale' <- getInt scale ->
|
||||
tryTypedLiteral (PrecScaleTypeName nm prec' scale') <|> pure e
|
||||
_ -> pure e
|
||||
tryTypedLiteral tn =
|
||||
TypedLit tn <$> hidden singleQuotesOnlyStringTok
|
||||
typedLiteral = TypedLit <$> hidden (typeName' True) <*> singleQuotesOnlyStringTok
|
||||
keywordFunctionOrIden = do
|
||||
d <- askDialect id
|
||||
x <- hidden (keywordTok (diIdentifierKeywords d ++ diAppKeywords d))
|
||||
let i = T.toLower x `elem` diIdentifierKeywords d
|
||||
a = T.toLower x `elem` diAppKeywords d
|
||||
case () of
|
||||
_ | i && a -> pure [Name Nothing x] <**> option Iden app
|
||||
| i -> pure (Iden [Name Nothing x])
|
||||
| a -> pure [Name Nothing x] <**> app
|
||||
| otherwise -> fail ""
|
||||
|
||||
_ | i && a -> pure [Name Nothing x] <**> hoption Iden app
|
||||
| i -> pure (Iden [Name Nothing x])
|
||||
| a -> pure [Name Nothing x] <**> app
|
||||
| otherwise -> -- shouldn't get here
|
||||
fail $ "unexpected keyword: " <> T.unpack x
|
||||
|
||||
{-
|
||||
=== special
|
||||
|
|
@ -814,7 +848,7 @@ specialOpK opName firstArg kws =
|
|||
case (e,kws) of
|
||||
(Iden [Name Nothing i], (k,_):_)
|
||||
| T.toLower i == k ->
|
||||
fail $ "cannot use keyword here: " ++ T.unpack i
|
||||
fail $ "unexpected " ++ T.unpack i
|
||||
_ -> pure ()
|
||||
pure e
|
||||
fa <- case firstArg of
|
||||
|
|
@ -921,24 +955,24 @@ together.
|
|||
|
||||
app :: Parser ([Name] -> ScalarExpr)
|
||||
app =
|
||||
openParen *> choice
|
||||
[duplicates
|
||||
hidden openParen *> choice
|
||||
[hidden duplicates
|
||||
<**> (commaSep1 scalarExpr
|
||||
<**> ((option [] orderBy <* closeParen)
|
||||
<**> (optional afilter <$$$$$> AggregateApp)))
|
||||
<**> ((hoption [] orderBy <* closeParen)
|
||||
<**> (hoptional afilter <$$$$$> AggregateApp)))
|
||||
-- separate cases with no all or distinct which must have at
|
||||
-- least one scalar expr
|
||||
,commaSep1 scalarExpr
|
||||
<**> choice
|
||||
[closeParen *> choice
|
||||
[closeParen *> hidden (choice
|
||||
[window
|
||||
,withinGroup
|
||||
,(Just <$> afilter) <$$$> aggAppWithoutDupeOrd
|
||||
,pure (flip App)]
|
||||
,orderBy <* closeParen
|
||||
<**> (optional afilter <$$$$> aggAppWithoutDupe)]
|
||||
,pure (flip App)])
|
||||
,hidden orderBy <* closeParen
|
||||
<**> (hoptional afilter <$$$$> aggAppWithoutDupe)]
|
||||
-- no scalarExprs: duplicates and order by not allowed
|
||||
,([] <$ closeParen) <**> option (flip App) (window <|> withinGroup)
|
||||
,([] <$ closeParen) <**> hoption (flip App) (window <|> withinGroup)
|
||||
]
|
||||
where
|
||||
aggAppWithoutDupeOrd n es f = AggregateApp n SQDefault es [] f
|
||||
|
|
@ -970,8 +1004,11 @@ window =
|
|||
<**> (option [] orderBy
|
||||
<**> ((optional frameClause <* closeParen) <$$$$$> WindowApp))
|
||||
where
|
||||
partitionBy = keywords_ ["partition","by"] *> commaSep1 scalarExpr
|
||||
partitionBy =
|
||||
label "partition by" $
|
||||
keywords_ ["partition","by"] *> commaSep1 scalarExpr
|
||||
frameClause =
|
||||
label "frame clause" $
|
||||
frameRowsRange -- TODO: this 'and' could be an issue
|
||||
<**> choice [(keyword_ "between" *> frameLimit True)
|
||||
<**> ((keyword_ "and" *> frameLimit True)
|
||||
|
|
@ -1128,8 +1165,8 @@ scalar expressions (the other is a variation on joins)
|
|||
|
||||
|
||||
odbcExpr :: Parser ScalarExpr
|
||||
odbcExpr = between (symbol "{") (symbol "}")
|
||||
(odbcTimeLit <|> odbcFunc)
|
||||
odbcExpr =
|
||||
braces (odbcTimeLit <|> odbcFunc)
|
||||
where
|
||||
odbcTimeLit =
|
||||
OdbcLiteral <$> choice [OLDate <$ keyword "d"
|
||||
|
|
@ -1232,33 +1269,33 @@ opTable bExpr =
|
|||
|
||||
]
|
||||
where
|
||||
binarySymL nm = E.InfixL (mkBinOp nm <$ symbol_ nm)
|
||||
binarySymR nm = E.InfixR (mkBinOp nm <$ symbol_ nm)
|
||||
binarySymN nm = E.InfixN (mkBinOp nm <$ symbol_ nm)
|
||||
binaryKeywordN nm = E.InfixN (mkBinOp nm <$ keyword_ nm)
|
||||
binaryKeywordL nm = E.InfixL (mkBinOp nm <$ keyword_ nm)
|
||||
binarySymL nm = E.InfixL (hidden $ mkBinOp nm <$ symbol_ nm)
|
||||
binarySymR nm = E.InfixR (hidden $ mkBinOp nm <$ symbol_ nm)
|
||||
binarySymN nm = E.InfixN (hidden $ mkBinOp nm <$ symbol_ nm)
|
||||
binaryKeywordN nm = E.InfixN (hidden $ mkBinOp nm <$ keyword_ nm)
|
||||
binaryKeywordL nm = E.InfixL (hidden $ mkBinOp nm <$ keyword_ nm)
|
||||
mkBinOp nm a b = BinOp a (mkNm nm) b
|
||||
prefixSym nm = prefix (PrefixOp (mkNm nm) <$ symbol_ nm)
|
||||
prefixKeyword nm = prefix (PrefixOp (mkNm nm) <$ keyword_ nm)
|
||||
prefixSym nm = prefix (hidden $ PrefixOp (mkNm nm) <$ symbol_ nm)
|
||||
prefixKeyword nm = prefix (hidden $ PrefixOp (mkNm nm) <$ keyword_ nm)
|
||||
mkNm nm = [Name Nothing nm]
|
||||
binaryKeywordsN p =
|
||||
E.InfixN (do
|
||||
E.InfixN (hidden $ do
|
||||
o <- try p
|
||||
pure (\a b -> BinOp a [Name Nothing $ T.unwords o] b))
|
||||
multisetBinOp = E.InfixL (do
|
||||
multisetBinOp = E.InfixL (hidden $ do
|
||||
keyword_ "multiset"
|
||||
o <- choice [Union <$ keyword_ "union"
|
||||
,Intersect <$ keyword_ "intersect"
|
||||
,Except <$ keyword_ "except"]
|
||||
d <- option SQDefault duplicates
|
||||
d <- hoption SQDefault duplicates
|
||||
pure (\a b -> MultisetBinOp a o d b))
|
||||
postfixKeywords p =
|
||||
postfix $ do
|
||||
postfix $ hidden $ do
|
||||
o <- try p
|
||||
pure $ PostfixOp [Name Nothing $ T.unwords o]
|
||||
-- parse repeated prefix or postfix operators
|
||||
postfix p = E.Postfix $ foldr1 (flip (.)) <$> some p
|
||||
prefix p = E.Prefix $ foldr1 (.) <$> some p
|
||||
postfix p = E.Postfix $ foldr1 (flip (.)) <$> some (hidden p)
|
||||
prefix p = E.Prefix $ foldr1 (.) <$> some (hidden p)
|
||||
|
||||
{-
|
||||
== scalar expression top level
|
||||
|
|
@ -1271,31 +1308,32 @@ documenting/fixing.
|
|||
-}
|
||||
|
||||
scalarExpr :: Parser ScalarExpr
|
||||
scalarExpr = E.makeExprParser term (opTable False)
|
||||
scalarExpr = label "expression" $ E.makeExprParser term (opTable False)
|
||||
|
||||
term :: Parser ScalarExpr
|
||||
term = choice [simpleLiteral
|
||||
,parameter
|
||||
,positionalArg
|
||||
,star
|
||||
,parensExpr
|
||||
,caseExpr
|
||||
,cast
|
||||
,convertSqlServer
|
||||
,arrayCtor
|
||||
,multisetCtor
|
||||
,nextValueFor
|
||||
,subquery
|
||||
,intervalLit
|
||||
,specialOpKs
|
||||
,idenExpr
|
||||
,odbcExpr]
|
||||
<?> "scalar expression"
|
||||
term = label "expression" $
|
||||
choice
|
||||
[simpleLiteral
|
||||
,parameter
|
||||
,positionalArg
|
||||
,star
|
||||
,parensExpr
|
||||
,caseExpr
|
||||
,cast
|
||||
,convertSqlServer
|
||||
,arrayCtor
|
||||
,multisetCtor
|
||||
,nextValueFor
|
||||
,subquery
|
||||
,intervalLit
|
||||
,specialOpKs
|
||||
,idenExpr
|
||||
,odbcExpr]
|
||||
|
||||
-- expose the b expression for window frame clause range between
|
||||
|
||||
scalarExprB :: Parser ScalarExpr
|
||||
scalarExprB = E.makeExprParser term (opTable True)
|
||||
scalarExprB = label "expression" $ E.makeExprParser term (opTable True)
|
||||
|
||||
{-
|
||||
== helper parsers
|
||||
|
|
@ -1321,9 +1359,10 @@ use a data type for the datetime field?
|
|||
-}
|
||||
|
||||
datetimeField :: Parser Text
|
||||
datetimeField = choice (map keyword ["year","month","day"
|
||||
,"hour","minute","second"])
|
||||
<?> "datetime field"
|
||||
datetimeField =
|
||||
choice (map keyword ["year","month","day"
|
||||
,"hour","minute","second"])
|
||||
<?> "datetime field"
|
||||
|
||||
{-
|
||||
This is used in multiset operations (scalar expr), selects (query expr)
|
||||
|
|
@ -1344,8 +1383,8 @@ duplicates =
|
|||
-}
|
||||
|
||||
selectItem :: Parser (ScalarExpr,Maybe Name)
|
||||
selectItem = (,) <$> scalarExpr <*> optional als
|
||||
where als = optional (keyword_ "as") *> name
|
||||
selectItem = label "select item" ((,) <$> scalarExpr <*> optional als)
|
||||
where als = label "alias" $ optional (keyword_ "as") *> name
|
||||
|
||||
selectList :: Parser [(ScalarExpr,Maybe Name)]
|
||||
selectList = commaSep1 selectItem
|
||||
|
|
@ -1366,33 +1405,33 @@ aliases.
|
|||
-}
|
||||
|
||||
from :: Parser [TableRef]
|
||||
from = keyword_ "from" *> commaSep1 tref
|
||||
from = label "from" (keyword_ "from" *> commaSep1 tref)
|
||||
where
|
||||
-- TODO: use P (a->) for the join tref suffix
|
||||
-- chainl or buildexpressionparser
|
||||
tref = (nonJoinTref <?> "table ref") >>= optionSuffix joinTrefSuffix
|
||||
tref = (nonJoinTref <?> "table ref") >>= hoptionSuffix joinTrefSuffix
|
||||
nonJoinTref = choice
|
||||
[parens $ choice
|
||||
[hidden $ parens $ choice
|
||||
[TRQueryExpr <$> queryExpr
|
||||
,TRParens <$> tref]
|
||||
,TRLateral <$> (keyword_ "lateral"
|
||||
,TRLateral <$> (hidden (keyword_ "lateral")
|
||||
*> nonJoinTref)
|
||||
,do
|
||||
n <- names
|
||||
choice [TRFunction n
|
||||
<$> parens (commaSep scalarExpr)
|
||||
<$> hidden (parens (commaSep scalarExpr))
|
||||
,pure $ TRSimple n]
|
||||
-- todo: I think you can only have outer joins inside the oj,
|
||||
-- not sure.
|
||||
,TROdbc <$> (symbol "{" *> keyword_ "oj" *> tref <* symbol "}")
|
||||
,TROdbc <$> (hidden (braces (keyword_ "oj" *> tref)))
|
||||
] <??> aliasSuffix
|
||||
aliasSuffix = fromAlias <$$> TRAlias
|
||||
aliasSuffix = hidden (fromAlias <$$> TRAlias)
|
||||
joinTrefSuffix t =
|
||||
((TRJoin t <$> option False (True <$ keyword_ "natural")
|
||||
<*> joinType
|
||||
<*> nonJoinTref
|
||||
<*> optional joinCondition)
|
||||
>>= optionSuffix joinTrefSuffix) <?> ""
|
||||
<*> hoptional joinCondition)
|
||||
>>= hoptionSuffix joinTrefSuffix)
|
||||
|
||||
{-
|
||||
TODO: factor the join stuff to produce better error messages (and make
|
||||
|
|
@ -1422,8 +1461,8 @@ joinCondition = choice
|
|||
fromAlias :: Parser Alias
|
||||
fromAlias = Alias <$> tableAlias <*> columnAliases
|
||||
where
|
||||
tableAlias = optional (keyword_ "as") *> name
|
||||
columnAliases = optional $ parens $ commaSep1 name
|
||||
tableAlias = hoptional (keyword_ "as") *> name
|
||||
columnAliases = hoptional $ parens $ commaSep1 name
|
||||
|
||||
{-
|
||||
== simple other parts
|
||||
|
|
@ -1433,10 +1472,11 @@ pretty trivial.
|
|||
-}
|
||||
|
||||
whereClause :: Parser ScalarExpr
|
||||
whereClause = keyword_ "where" *> scalarExpr
|
||||
whereClause = label "where" (keyword_ "where" *> scalarExpr)
|
||||
|
||||
groupByClause :: Parser [GroupingExpr]
|
||||
groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
|
||||
groupByClause =
|
||||
label "group by" (keywords_ ["group","by"] *> commaSep1 groupingExpression)
|
||||
where
|
||||
groupingExpression = choice
|
||||
[keyword_ "cube" >>
|
||||
|
|
@ -1450,16 +1490,16 @@ groupByClause = keywords_ ["group","by"] *> commaSep1 groupingExpression
|
|||
]
|
||||
|
||||
having :: Parser ScalarExpr
|
||||
having = keyword_ "having" *> scalarExpr
|
||||
having = label "having" (keyword_ "having" *> scalarExpr)
|
||||
|
||||
orderBy :: Parser [SortSpec]
|
||||
orderBy = keywords_ ["order","by"] *> commaSep1 ob
|
||||
orderBy = label "order by" (keywords_ ["order","by"] *> commaSep1 ob)
|
||||
where
|
||||
ob = SortSpec
|
||||
<$> scalarExpr
|
||||
<*> option DirDefault (choice [Asc <$ keyword_ "asc"
|
||||
<*> hoption DirDefault (choice [Asc <$ keyword_ "asc"
|
||||
,Desc <$ keyword_ "desc"])
|
||||
<*> option NullsOrderDefault
|
||||
<*> hoption NullsOrderDefault
|
||||
-- todo: left factor better
|
||||
(keyword_ "nulls" >>
|
||||
choice [NullsFirst <$ keyword "first"
|
||||
|
|
@ -1477,9 +1517,9 @@ offsetFetch =
|
|||
maybePermutation p = P.toPermutationWithDefault Nothing (Just <$> p)
|
||||
|
||||
offset :: Parser ScalarExpr
|
||||
offset = keyword_ "offset" *> scalarExpr
|
||||
offset = label "offset" (keyword_ "offset" *> scalarExpr
|
||||
<* option () (choice [keyword_ "rows"
|
||||
,keyword_ "row"])
|
||||
,keyword_ "row"]))
|
||||
|
||||
fetch :: Parser ScalarExpr
|
||||
fetch = fetchFirst <|> limit
|
||||
|
|
@ -1496,13 +1536,13 @@ fetch = fetchFirst <|> limit
|
|||
|
||||
with :: Parser QueryExpr
|
||||
with = keyword_ "with" >>
|
||||
With <$> option False (True <$ keyword_ "recursive")
|
||||
With <$> hoption False (True <$ keyword_ "recursive")
|
||||
<*> commaSep1 withQuery <*> queryExpr
|
||||
where
|
||||
withQuery = (,) <$> (withAlias <* keyword_ "as")
|
||||
<*> parens queryExpr
|
||||
withAlias = Alias <$> name <*> columnAliases
|
||||
columnAliases = optional $ parens $ commaSep1 name
|
||||
columnAliases = hoptional $ parens $ commaSep1 name
|
||||
|
||||
|
||||
{-
|
||||
|
|
@ -1513,15 +1553,15 @@ and union, etc..
|
|||
-}
|
||||
|
||||
queryExpr :: Parser QueryExpr
|
||||
queryExpr = E.makeExprParser qeterm qeOpTable
|
||||
queryExpr = label "query expr" $ E.makeExprParser qeterm qeOpTable
|
||||
where
|
||||
qeterm = with <|> select <|> table <|> values
|
||||
qeterm = label "query expr" (with <|> select <|> table <|> values)
|
||||
|
||||
select = keyword_ "select" >>
|
||||
mkSelect
|
||||
<$> option SQDefault duplicates
|
||||
<$> hoption SQDefault duplicates
|
||||
<*> selectList
|
||||
<*> optional tableExpression <?> "table expression"
|
||||
<*> optional tableExpression
|
||||
mkSelect d sl Nothing =
|
||||
toQueryExpr $ makeSelect {msSetQuantifier = d, msSelectList = sl}
|
||||
mkSelect d sl (Just (TableExpression f w g h od ofs fe)) =
|
||||
|
|
@ -1535,12 +1575,12 @@ queryExpr = E.makeExprParser qeterm qeOpTable
|
|||
,[E.InfixL $ setOp Except "except"
|
||||
,E.InfixL $ setOp Union "union"]]
|
||||
setOp :: SetOperatorName -> Text -> Parser (QueryExpr -> QueryExpr -> QueryExpr)
|
||||
setOp ctor opName = (cq
|
||||
setOp ctor opName = hidden (cq
|
||||
<$> (ctor <$ keyword_ opName)
|
||||
<*> option SQDefault duplicates
|
||||
<*> corr) <?> ""
|
||||
<*> hoption SQDefault duplicates
|
||||
<*> corr)
|
||||
cq o d c q0 q1 = QueryExprSetOp q0 o d c q1
|
||||
corr = option Respectively (Corresponding <$ keyword_ "corresponding")
|
||||
corr = hoption Respectively (Corresponding <$ keyword_ "corresponding")
|
||||
|
||||
|
||||
{-
|
||||
|
|
@ -1560,12 +1600,15 @@ data TableExpression
|
|||
,_teFetchFirst :: Maybe ScalarExpr}
|
||||
|
||||
tableExpression :: Parser TableExpression
|
||||
tableExpression = mkTe <$> (from <?> "from clause")
|
||||
<*> (optional whereClause <?> "where clause")
|
||||
<*> (option [] groupByClause <?> "group by clause")
|
||||
<*> (optional having <?> "having clause")
|
||||
<*> (option [] orderBy <?> "order by clause")
|
||||
<*> (offsetFetch <?> "")
|
||||
tableExpression =
|
||||
label "from" $
|
||||
mkTe
|
||||
<$> from
|
||||
<*> optional whereClause
|
||||
<*> option [] groupByClause
|
||||
<*> optional having
|
||||
<*> option [] orderBy
|
||||
<*> (hidden offsetFetch)
|
||||
where
|
||||
mkTe f w g h od (ofs,fe) =
|
||||
TableExpression f w g h od ofs fe
|
||||
|
|
@ -1589,7 +1632,8 @@ topLevelStatement = statement
|
|||
-}
|
||||
|
||||
statementWithoutSemicolon :: Parser Statement
|
||||
statementWithoutSemicolon = choice
|
||||
statementWithoutSemicolon =
|
||||
label "statement" $ choice
|
||||
[keyword_ "create" *> choice [createSchema
|
||||
,createTable
|
||||
,createIndex
|
||||
|
|
@ -1623,7 +1667,7 @@ statementWithoutSemicolon = choice
|
|||
]
|
||||
|
||||
statement :: Parser Statement
|
||||
statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ semi
|
||||
statement = statementWithoutSemicolon <* optional semi <|> EmptyStatement <$ hidden semi
|
||||
|
||||
createSchema :: Parser Statement
|
||||
createSchema = keyword_ "schema" >>
|
||||
|
|
@ -1638,7 +1682,7 @@ createTable = do
|
|||
separator = if diNonCommaSeparatedConstraints d
|
||||
then optional comma
|
||||
else Just <$> comma
|
||||
constraints = sepBy parseConstraintDef separator
|
||||
constraints = sepBy parseConstraintDef (hidden separator)
|
||||
entries = ((:) <$> parseColumnDef <*> ((comma >> entries) <|> pure [])) <|> constraints
|
||||
|
||||
keyword_ "table" >>
|
||||
|
|
@ -1660,7 +1704,7 @@ columnDef = ColumnDef <$> name <*> typeName
|
|||
<*> optional defaultClause
|
||||
<*> option [] (some colConstraintDef)
|
||||
where
|
||||
defaultClause = choice [
|
||||
defaultClause = label "column default clause" $ choice [
|
||||
keyword_ "default" >>
|
||||
DefaultClause <$> scalarExpr
|
||||
-- todo: left factor
|
||||
|
|
@ -1689,12 +1733,12 @@ tableConstraintDef =
|
|||
(\cs ft ftcs m (u,d) -> TableReferencesConstraint cs ft ftcs m u d)
|
||||
<$> parens (commaSep1 name)
|
||||
<*> (keyword_ "references" *> names)
|
||||
<*> optional (parens $ commaSep1 name)
|
||||
<*> hoptional (parens $ commaSep1 name)
|
||||
<*> refMatch
|
||||
<*> refActions
|
||||
|
||||
refMatch :: Parser ReferenceMatch
|
||||
refMatch = option DefaultReferenceMatch
|
||||
refMatch = hoption DefaultReferenceMatch
|
||||
(keyword_ "match" *>
|
||||
choice [MatchFull <$ keyword_ "full"
|
||||
,MatchPartial <$ keyword_ "partial"
|
||||
|
|
@ -1833,11 +1877,11 @@ dropTable = keyword_ "table" >>
|
|||
createView :: Parser Statement
|
||||
createView =
|
||||
CreateView
|
||||
<$> (option False (True <$ keyword_ "recursive") <* keyword_ "view")
|
||||
<$> (hoption False (True <$ keyword_ "recursive") <* keyword_ "view")
|
||||
<*> names
|
||||
<*> optional (parens (commaSep1 name))
|
||||
<*> (keyword_ "as" *> queryExpr)
|
||||
<*> optional (choice [
|
||||
<*> hoptional (choice [
|
||||
-- todo: left factor
|
||||
DefaultCheckOption <$ try (keywords_ ["with", "check", "option"])
|
||||
,CascadedCheckOption <$ try (keywords_ ["with", "cascaded", "check", "option"])
|
||||
|
|
@ -1852,7 +1896,7 @@ createDomain :: Parser Statement
|
|||
createDomain = keyword_ "domain" >>
|
||||
CreateDomain
|
||||
<$> names
|
||||
<*> (optional (keyword_ "as") *> typeName)
|
||||
<*> ((optional (keyword_ "as") *> typeName) <?> "alias")
|
||||
<*> optional (keyword_ "default" *> scalarExpr)
|
||||
<*> many con
|
||||
where
|
||||
|
|
@ -1930,7 +1974,7 @@ insert :: Parser Statement
|
|||
insert = keywords_ ["insert", "into"] >>
|
||||
Insert
|
||||
<$> names
|
||||
<*> optional (parens $ commaSep1 name)
|
||||
<*> label "parens column names" (optional (parens $ commaSep1 name))
|
||||
<*> (DefaultInsertValues <$ keywords_ ["default", "values"]
|
||||
<|> InsertQuery <$> queryExpr)
|
||||
|
||||
|
|
@ -1938,7 +1982,7 @@ update :: Parser Statement
|
|||
update = keywords_ ["update"] >>
|
||||
Update
|
||||
<$> names
|
||||
<*> optional (optional (keyword_ "as") *> name)
|
||||
<*> label "alias" (optional (optional (keyword_ "as") *> name))
|
||||
<*> (keyword_ "set" *> commaSep1 setClause)
|
||||
<*> optional (keyword_ "where" *> scalarExpr)
|
||||
where
|
||||
|
|
@ -1974,10 +2018,10 @@ releaseSavepoint = keywords_ ["release","savepoint"] >>
|
|||
ReleaseSavepoint <$> name
|
||||
|
||||
commit :: Parser Statement
|
||||
commit = Commit <$ keyword_ "commit" <* optional (keyword_ "work")
|
||||
commit = Commit <$ keyword_ "commit" <* hoptional (keyword_ "work")
|
||||
|
||||
rollback :: Parser Statement
|
||||
rollback = keyword_ "rollback" >> optional (keyword_ "work") >>
|
||||
rollback = keyword_ "rollback" >> hoptional (keyword_ "work") >>
|
||||
Rollback <$> optional (keywords_ ["to", "savepoint"] *> name)
|
||||
|
||||
|
||||
|
|
@ -2091,6 +2135,7 @@ thick.
|
|||
|
||||
makeKeywordTree :: [Text] -> Parser [Text]
|
||||
makeKeywordTree sets =
|
||||
label (T.intercalate ", " sets) $
|
||||
parseTrees (sort $ map T.words sets)
|
||||
where
|
||||
parseTrees :: [[Text]] -> Parser [Text]
|
||||
|
|
@ -2116,24 +2161,20 @@ makeKeywordTree sets =
|
|||
|
||||
-- parser helpers
|
||||
|
||||
(<$$>) :: Applicative f =>
|
||||
f b -> (a -> b -> c) -> f (a -> c)
|
||||
(<$$>) :: Parser b -> (a -> b -> c) -> Parser (a -> c)
|
||||
(<$$>) pa c = pa <**> pure (flip c)
|
||||
|
||||
(<$$$>) :: Applicative f =>
|
||||
f c -> (a -> b -> c -> t) -> f (b -> a -> t)
|
||||
(<$$$>) :: Parser c -> (a -> b -> c -> t) -> Parser (b -> a -> t)
|
||||
p <$$$> c = p <**> pure (flip3 c)
|
||||
|
||||
(<$$$$>) :: Applicative f =>
|
||||
f d -> (a -> b -> c -> d -> t) -> f (c -> b -> a -> t)
|
||||
(<$$$$>) :: Parser d -> (a -> b -> c -> d -> t) -> Parser (c -> b -> a -> t)
|
||||
p <$$$$> c = p <**> pure (flip4 c)
|
||||
|
||||
(<$$$$$>) :: Applicative f =>
|
||||
f e -> (a -> b -> c -> d -> e -> t) -> f (d -> c -> b -> a -> t)
|
||||
(<$$$$$>) :: Parser e -> (a -> b -> c -> d -> e -> t) -> Parser (d -> c -> b -> a -> t)
|
||||
p <$$$$$> c = p <**> pure (flip5 c)
|
||||
|
||||
optionSuffix :: (a -> Parser a) -> a -> Parser a
|
||||
optionSuffix p a = option a (p a)
|
||||
hoptionSuffix :: (a -> Parser a) -> a -> Parser a
|
||||
hoptionSuffix p a = hoption a (p a)
|
||||
|
||||
{-
|
||||
parses an optional postfix element and applies its result to its left
|
||||
|
|
@ -2144,12 +2185,12 @@ other operators so it can be used nicely
|
|||
-}
|
||||
|
||||
(<??>) :: Parser a -> Parser (a -> a) -> Parser a
|
||||
p <??> q = p <**> option id q
|
||||
p <??> q = p <**> hoption id q
|
||||
|
||||
-- 0 to many repeated applications of suffix parser
|
||||
|
||||
(<??*>) :: Parser a -> Parser (a -> a) -> Parser a
|
||||
p <??*> q = foldr ($) <$> p <*> (reverse <$> many q)
|
||||
p <??*> q = foldr ($) <$> p <*> (reverse <$> many (hidden q))
|
||||
|
||||
{-
|
||||
These are to help with left factored parsers:
|
||||
|
|
@ -2177,7 +2218,7 @@ unsignedInteger = read . T.unpack <$> sqlNumberTok True <?> "natural number"
|
|||
-- todo: work out the symbol parsing better
|
||||
|
||||
symbol :: Text -> Parser Text
|
||||
symbol s = symbolTok (Just s) <?> T.unpack s
|
||||
symbol s = symbolTok (Just s) <?> s
|
||||
|
||||
singleCharSymbol :: Char -> Parser Char
|
||||
singleCharSymbol c = c <$ symbol (T.singleton c)
|
||||
|
|
@ -2185,44 +2226,39 @@ singleCharSymbol c = c <$ symbol (T.singleton c)
|
|||
questionMark :: Parser Char
|
||||
questionMark = singleCharSymbol '?' <?> "question mark"
|
||||
|
||||
openParen :: Parser Char
|
||||
openParen = singleCharSymbol '('
|
||||
|
||||
closeParen :: Parser Char
|
||||
closeParen = singleCharSymbol ')'
|
||||
|
||||
openBracket :: Parser Char
|
||||
openBracket = singleCharSymbol '['
|
||||
|
||||
closeBracket :: Parser Char
|
||||
closeBracket = singleCharSymbol ']'
|
||||
openParen :: Parser ()
|
||||
openParen = void $ singleCharSymbol '('
|
||||
|
||||
closeParen :: Parser ()
|
||||
closeParen = void $ singleCharSymbol ')'
|
||||
|
||||
comma :: Parser Char
|
||||
comma = singleCharSymbol ',' <?> ""
|
||||
comma = singleCharSymbol ','
|
||||
|
||||
semi :: Parser Char
|
||||
semi = singleCharSymbol ';' <?> ""
|
||||
semi = singleCharSymbol ';'
|
||||
|
||||
-- = helper functions
|
||||
|
||||
keyword :: Text -> Parser Text
|
||||
keyword k = unquotedIdentifierTok [] (Just k) <?> T.unpack k
|
||||
keyword k = keywordTok [k] <?> k
|
||||
|
||||
-- helper function to improve error messages
|
||||
|
||||
keywords_ :: [Text] -> Parser ()
|
||||
keywords_ ks = mapM_ keyword_ ks <?> T.unpack (T.unwords ks)
|
||||
|
||||
keywords_ ks = label (T.unwords ks) $ mapM_ keyword_ ks
|
||||
|
||||
parens :: Parser a -> Parser a
|
||||
parens = between openParen closeParen
|
||||
|
||||
brackets :: Parser a -> Parser a
|
||||
brackets = between openBracket closeBracket
|
||||
brackets = between (singleCharSymbol '[') (singleCharSymbol ']')
|
||||
|
||||
braces :: Parser a -> Parser a
|
||||
braces = between (singleCharSymbol '{') (singleCharSymbol '}')
|
||||
|
||||
commaSep :: Parser a -> Parser [a]
|
||||
commaSep = (`sepBy` comma)
|
||||
commaSep = (`sepBy` hidden comma)
|
||||
|
||||
keyword_ :: Text -> Parser ()
|
||||
keyword_ = void . keyword
|
||||
|
|
@ -2231,7 +2267,19 @@ symbol_ :: Text -> Parser ()
|
|||
symbol_ = void . symbol
|
||||
|
||||
commaSep1 :: Parser a -> Parser [a]
|
||||
commaSep1 = (`sepBy1` comma)
|
||||
commaSep1 = (`sepBy1` hidden comma)
|
||||
|
||||
hoptional :: Parser a -> Parser (Maybe a)
|
||||
hoptional = hidden . optional
|
||||
|
||||
hoption :: a -> Parser a -> Parser a
|
||||
hoption a p = hidden $ option a p
|
||||
|
||||
label :: Text -> Parser a -> Parser a
|
||||
label x = M.label (T.unpack x)
|
||||
|
||||
(<?>) :: Parser a -> Text -> Parser a
|
||||
(<?>) p a = (M.<?>) p (T.unpack a)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -2277,25 +2325,25 @@ stringTokExtend = do
|
|||
]
|
||||
|
||||
hostParamTok :: Parser Text
|
||||
hostParamTok = token test Set.empty <?> ""
|
||||
hostParamTok = token test Set.empty <?> "host param"
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.PrefixedVariable c p)) = Just $ T.cons c p
|
||||
test _ = Nothing
|
||||
|
||||
positionalArgTok :: Parser Int
|
||||
positionalArgTok = token test Set.empty <?> ""
|
||||
positionalArgTok = token test Set.empty <?> "positional arg"
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.PositionalArg p)) = Just p
|
||||
test _ = Nothing
|
||||
|
||||
sqlNumberTok :: Bool -> Parser Text
|
||||
sqlNumberTok intOnly = token test Set.empty <?> ""
|
||||
sqlNumberTok intOnly = token test Set.empty <?> "number"
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.SqlNumber p)) | not intOnly || T.all isDigit p = Just p
|
||||
test _ = Nothing
|
||||
|
||||
symbolTok :: Maybe Text -> Parser Text
|
||||
symbolTok sym = token test Set.empty <?> ""
|
||||
symbolTok sym = token test Set.empty <?> lbl
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.Symbol p)) =
|
||||
case sym of
|
||||
|
|
@ -2303,6 +2351,9 @@ symbolTok sym = token test Set.empty <?> ""
|
|||
Just sym' | sym' == p -> Just p
|
||||
_ -> Nothing
|
||||
test _ = Nothing
|
||||
lbl = case sym of
|
||||
Nothing -> "symbol"
|
||||
Just p -> p
|
||||
|
||||
{-
|
||||
The blacklisted names are mostly needed when we parse something with
|
||||
|
|
@ -2341,21 +2392,19 @@ will likely mean many things don't parse anymore.
|
|||
-}
|
||||
|
||||
identifierTok :: [Text] -> Parser (Maybe (Text,Text), Text)
|
||||
identifierTok blackList = token test Set.empty <?> ""
|
||||
identifierTok blackList = do
|
||||
token test Set.empty <?> "identifier"
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.Identifier q@(Just {}) p)) = Just (q,p)
|
||||
test (L.WithPos _ _ _ (L.Identifier q p))
|
||||
test (L.WithPos _ _ _ (L.Identifier q@Nothing p))
|
||||
| T.toLower p `notElem` blackList = Just (q,p)
|
||||
test _ = Nothing
|
||||
|
||||
unquotedIdentifierTok :: [Text] -> Maybe Text -> Parser Text
|
||||
unquotedIdentifierTok blackList kw = token test Set.empty <?> ""
|
||||
where
|
||||
test (L.WithPos _ _ _ (L.Identifier Nothing p)) =
|
||||
case kw of
|
||||
Nothing | T.toLower p `notElem` blackList -> Just p
|
||||
Just k | k == T.toLower p -> Just p
|
||||
_ -> Nothing
|
||||
keywordTok :: [Text] -> Parser Text
|
||||
keywordTok allowed = do
|
||||
token test Set.empty where
|
||||
test (L.WithPos _ _ _ (L.Identifier Nothing p))
|
||||
| T.toLower p `elem` allowed = Just p
|
||||
test _ = Nothing
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue