/Database/HDBC/PostgreSQL/Parser.hs

 1{- -*- mode: haskell; -*- 
 2-}
 3{- PostgreSQL uses $1, $2, etc. instead of ? in query strings.  So we have to
 4do some basic parsing on these things to fix 'em up. -}
 5
 6
 7module Database.HDBC.PostgreSQL.Parser where
 8
 9import Text.ParserCombinators.Parsec
10
11escapeseq :: GenParser Char st String
12escapeseq = (try $ string "''") <|>
13            (try $ string "\\'")
14
15literal :: GenParser Char st [Char]
16literal = do _ <- char '\''
17             s <- many (escapeseq <|> (noneOf "'" >>= (\x -> return [x])))
18             _ <- char '\''
19             return $ "'" ++ (concat s) ++ "'"
20
21qidentifier :: GenParser Char st [Char]
22qidentifier = do _ <- char '"'
23                 s <- many (noneOf "\"")
24                 _ <- char '"'
25                 return $ "\"" ++ s ++ "\""
26
27comment :: GenParser Char st [Char]
28comment = ccomment <|> linecomment
29
30ccomment :: GenParser Char st [Char]
31ccomment = do _ <- string "/*"
32              c <- manyTill ((try ccomment) <|> 
33                             (anyChar >>= (\x -> return [x])))
34                   (try (string "*/"))
35              return $ "/*" ++ concat c ++ "*/"
36
37linecomment :: GenParser Char st [Char]
38linecomment = do _ <- string "--"
39                 c <- many (noneOf "\n")
40                 _ <- char '\n'
41                 return $ "--" ++ c ++ "\n"
42
43-- FIXME: handle pgsql dollar-quoted constants
44
45qmark :: (Num st, Show st) => GenParser Char st [Char]
46qmark = do _ <- char '?'
47           n <- getState
48           updateState (+1)
49           return $ "$" ++ show n
50
51escapedQmark :: GenParser Char st [Char]
52escapedQmark = do _ <- try (char '\\' >> char '?')
53                  return "?"
54
55statement :: (Num st, Show st) => GenParser Char st [Char]
56statement = 
57    do s <- many ((try escapedQmark) <|>
58                  (try qmark) <|>
59                  (try comment) <|>
60                  (try literal) <|>
61                  (try qidentifier) <|>
62                  (anyChar >>= (\x -> return [x])))
63       return $ concat s
64
65convertSQL :: String -> Either ParseError String
66convertSQL input = runParser statement (1::Integer) "" input