diff --git a/Language/SQL/SimpleSQL/Lex.lhs b/Language/SQL/SimpleSQL/Lex.lhs index 9e56878..238a889 100644 --- a/Language/SQL/SimpleSQL/Lex.lhs +++ b/Language/SQL/SimpleSQL/Lex.lhs @@ -228,30 +228,32 @@ x'hexidecimal string' > sqlString :: Dialect -> Parser Token -> sqlString d = -> choice [csString -> ,normalString -> ] +> sqlString d = dollarString <|> csString <|> normalString > where -> normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix "") -> normalStringSuffix t -> | diSyntaxFlavour d == Postgres = do -> s <- takeTill (`elem` "'\\") +> dollarString = do +> guard $ diSyntaxFlavour d == Postgres +> -- use try because of ambiguity with symbols and with +> -- positional arg +> s <- choice +> [do +> i <- try (char '$' *> identifierString <* char '$') +> return $ "$" ++ i ++ "$" +> ,try (string "$$") +> ] +> str <- manyTill anyChar (try $ string s) +> return $ SqlString s s str +> normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix False "") +> normalStringSuffix allowBackslash t = do +> s <- takeTill $ if allowBackslash +> then (`elem` "'\\") +> else (== '\'') > -- deal with '' or \' as literal quote character > choice [do > ctu <- choice ["''" <$ try (string "''") > ,"\\'" <$ string "\\'" > ,"\\" <$ char '\\'] -> normalStringSuffix $ concat [t,s,ctu] +> normalStringSuffix allowBackslash $ concat [t,s,ctu] > ,concat [t,s] <$ char '\''] -> | otherwise = do -> s <- takeTill (=='\'') -> void $ char '\'' -> -- deal with '' as literal quote character -> choice [do -> void $ char '\'' -> normalStringSuffix $ concat [t,s,"''"] -> ,return $ concat [t,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 ' @@ -260,9 +262,17 @@ x'hexidecimal string' > -- but only pathalogical stuff, and I think the improved > -- error messages and user predictability make it a good > -- pragmatic choice -> csString = SqlString <$> try cs <*> return "'" <*> normalStringSuffix "" -> csPrefixes | diSyntaxFlavour d == Postgres = "nNbBxXEe" -> | otherwise = "nNbBxX" +> csString +> | diSyntaxFlavour d == Postgres = +> choice [SqlString <$> try (string "e'" <|> string "E'") +> <*> return "'" <*> normalStringSuffix True "" +> ,csString'] +> | otherwise = csString' +> csString' = SqlString +> <$> try cs +> <*> return "'" +> <*> normalStringSuffix False "" +> csPrefixes = "nNbBxX" > cs = choice $ (map (\x -> string ([x] ++ "'")) csPrefixes) > ++ [string "u&'" > ,string "U&'"] diff --git a/tools/Language/SQL/SimpleSQL/LexerTests.lhs b/tools/Language/SQL/SimpleSQL/LexerTests.lhs index 663e67b..7e7e76b 100644 --- a/tools/Language/SQL/SimpleSQL/LexerTests.lhs +++ b/tools/Language/SQL/SimpleSQL/LexerTests.lhs @@ -196,10 +196,12 @@ assurance. > ,("'normalendquote '''", [SqlString "'" "'" "normalendquote ''"]) > ,("e'this '' quote'", [SqlString "e'" "'" "this '' quote"]) > ,("e'this \\' quote'", [SqlString "e'" "'" "this \\' quote"]) -> -- todo: implement only allowing \' in e quoted strings -> {-,("'not this \\' quote", [SqlString "'" "'" "not this \\" -> ,Whitespace " " -> ,Identifier Nothing "quote"])-} +> ,("'not this \\' quote", [SqlString "'" "'" "not this \\" +> ,Whitespace " " +> ,Identifier Nothing "quote"]) +> ,("$$ string 1 $$", [SqlString "$$" "$$" " string 1 "]) +> ,("$$ string $ 2 $$", [SqlString "$$" "$$" " string $ 2 "]) +> ,("$a$ $$string 3$$ $a$", [SqlString "$a$" "$a$" " $$string 3$$ "]) > ] > -- csstrings > ++ map (\c -> (c ++ "'test'", [SqlString (c ++ "'") "'" "test"]))