{- -*- mode: haskell; -*- 
-}
{- PostgreSQL uses $1, $2, etc. instead of ? in query strings.  So we have to
do some basic parsing on these things to fix 'em up. -}


module Database.HDBC.PostgreSQL.Parser where

import Text.ParserCombinators.Parsec

escapeseq :: GenParser Char st String
escapeseq :: forall st. GenParser Char st String
escapeseq = (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st String -> GenParser Char st String)
-> GenParser Char st String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"''") GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
            (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (GenParser Char st String -> GenParser Char st String)
-> GenParser Char st String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\'")

literal :: GenParser Char st [Char]
literal :: forall st. GenParser Char st String
literal = do Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\''
             [String]
s <- GenParser Char st String -> ParsecT String st Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (GenParser Char st String
forall st. GenParser Char st String
escapeseq GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"'" ParsecT String st Identity Char
-> (Char -> GenParser Char st String) -> GenParser Char st String
forall a b.
ParsecT String st Identity a
-> (a -> ParsecT String st Identity b)
-> ParsecT String st Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
x -> String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
x])))
             Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\''
             String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

qidentifier :: GenParser Char st [Char]
qidentifier :: forall st. GenParser Char st String
qidentifier = do Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
                 String
s <- ParsecT String st Identity Char -> GenParser Char st String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"")
                 Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'
                 String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

comment :: GenParser Char st [Char]
comment :: forall st. GenParser Char st String
comment = GenParser Char st String
forall st. GenParser Char st String
ccomment GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> GenParser Char st String
forall st. GenParser Char st String
linecomment

ccomment :: GenParser Char st [Char]
ccomment :: forall st. GenParser Char st String
ccomment = do String
_ <- String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"/*"
              [String]
c <- GenParser Char st String
-> GenParser Char st String -> ParsecT String st Identity [String]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ((GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. GenParser Char st String
ccomment) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> 
                             (ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String st Identity Char
-> (Char -> GenParser Char st String) -> GenParser Char st String
forall a b.
ParsecT String st Identity a
-> (a -> ParsecT String st Identity b)
-> ParsecT String st Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
x -> String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
x])))
                   (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"*/"))
              String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
"/*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"*/"

linecomment :: GenParser Char st [Char]
linecomment :: forall st. GenParser Char st String
linecomment = do String
_ <- String -> GenParser Char st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"--"
                 String
c <- ParsecT String st Identity Char -> GenParser Char st String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\n")
                 Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
                 String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- FIXME: handle pgsql dollar-quoted constants

qmark :: (Num st, Show st) => GenParser Char st [Char]
qmark :: forall st. (Num st, Show st) => GenParser Char st String
qmark = do Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?'
           st
n <- ParsecT String st Identity st
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
           (st -> st) -> ParsecT String st Identity ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState (st -> st -> st
forall a. Num a => a -> a -> a
+st
1)
           String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ st -> String
forall a. Show a => a -> String
show st
n

escapedQmark :: GenParser Char st [Char]
escapedQmark :: forall st. GenParser Char st String
escapedQmark = do Char
_ <- GenParser Char st Char -> GenParser Char st Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Char -> GenParser Char st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' GenParser Char st Char
-> GenParser Char st Char -> GenParser Char st Char
forall a b.
ParsecT String st Identity a
-> ParsecT String st Identity b -> ParsecT String st Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> GenParser Char st Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?')
                  String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"?"

statement :: (Num st, Show st) => GenParser Char st [Char]
statement :: forall st. (Num st, Show st) => GenParser Char st String
statement = 
    do [String]
s <- GenParser Char st String -> ParsecT String st Identity [String]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. GenParser Char st String
escapedQmark) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                  (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. (Num st, Show st) => GenParser Char st String
qmark) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                  (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. GenParser Char st String
comment) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                  (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. GenParser Char st String
literal) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                  (GenParser Char st String -> GenParser Char st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st String
forall st. GenParser Char st String
qidentifier) GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                  (ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT String st Identity Char
-> (Char -> GenParser Char st String) -> GenParser Char st String
forall a b.
ParsecT String st Identity a
-> (a -> ParsecT String st Identity b)
-> ParsecT String st Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Char
x -> String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
x])))
       String -> GenParser Char st String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
s

convertSQL :: String -> Either ParseError String
convertSQL :: String -> Either ParseError String
convertSQL String
input = GenParser Char Integer String
-> Integer -> String -> String -> Either ParseError String
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser GenParser Char Integer String
forall st. (Num st, Show st) => GenParser Char st String
statement (Integer
1::Integer) String
"" String
input