{- -*- 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 -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\''
             s <- many (escapeseq <|> (noneOf "'" >>= (\Char
x -> String -> ParsecT String st Identity String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
x])))
             _ <- char '\''
             return $ "'" ++ (concat s) ++ "'"

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

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 -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"/*"
              c <- manyTill ((try ccomment) <|> 
                             (anyChar >>= (\Char
x -> String -> ParsecT String st Identity String
forall a. a -> ParsecT String st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
x])))
                   (try (string "*/"))
              return $ "/*" ++ concat c ++ "*/"

linecomment :: GenParser Char st [Char]
linecomment :: forall st. GenParser Char st String
linecomment = do _ <- String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"--"
                 c <- many (noneOf "\n")
                 _ <- char '\n'
                 return $ "--" ++ c ++ "\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 -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'?'
           n <- getState
           updateState (+1)
           return $ "$" ++ show n

escapedQmark :: GenParser Char st [Char]
escapedQmark :: forall st. GenParser Char st String
escapedQmark = do _ <- 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
'?')
                  return "?"

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