add lexing for \' only in e' strings and dollar strings in pg dialect

Language/SQL/SimpleSQL/Lex.lhs

@@ -228,30 +228,32 @@ x'hexidecimal string'
 
 
 > sqlString :: Dialect -> Parser Token
-> sqlString d =
+> sqlString d = dollarString <|> csString <|> normalString
->     choice [csString
->            ,normalString
->            ]
 >   where
->     normalString = SqlString "'" "'" <$> (char '\'' *> normalStringSuffix "")
+>     dollarString = do
->     normalStringSuffix t
+>         guard $ diSyntaxFlavour d == Postgres
->       | diSyntaxFlavour d == Postgres = do
+>         -- use try because of ambiguity with symbols and with
->         s <- takeTill (`elem` "'\\")
+>         -- 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 ""
+>     csString
->     csPrefixes | diSyntaxFlavour d == Postgres = "nNbBxXEe"
+>       | diSyntaxFlavour d == Postgres =
->                | otherwise = "nNbBxX"
+>         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&'"]

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 \\"
->        {-,("'not this \\' quote", [SqlString "'" "'" "not this \\"
 >                                 ,Whitespace " "
->                                  ,Identifier Nothing "quote"])-}
+>                                 ,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"]))