module Database.PostgreSQL.Simple.Bind.Representation (
PGFunction(..)
, PGArgument(..)
, PGColumn(..)
, PGResult(..)
, PostgresBindException(..)
, parsePGFunction
) where
import Control.Applicative ((*>), (<*), (<|>))
import Control.Monad.Catch (MonadThrow(..), Exception, throwM)
import Data.Attoparsec.Text (Parser, char, string, decimal, skipSpace, asciiCI, sepBy)
import Data.Attoparsec.Text (takeWhile, takeWhile1, parseOnly, takeTill, inClass)
import Data.Text (Text, toLower, unpack, append, length)
import Data.Typeable (Typeable)
import Prelude hiding (takeWhile, length)
data PostgresBindException
= ParserFailed String
| DefaultValueNotFound String
deriving (Eq, Show, Typeable)
instance Exception PostgresBindException
data PGArgument = PGArgument String String Bool deriving (Show, Eq)
data PGFunction = PGFunction String String [PGArgument] PGResult deriving (Show, Eq)
data PGColumn = PGColumn String String deriving (Show, Eq)
data PGResult = PGSingle String
| PGSetOf String
| PGTable [PGColumn] deriving (Show, Eq)
parsePGFunction :: (MonadThrow m) => Text -> m PGFunction
parsePGFunction s = either
(\err -> throwM . ParserFailed . concat $ ["In declaration `", unpack s, "`: ", err])
return
(parseOnly (ss *> function) s) where
ss = skipSpace
function = do
_ <- asciiCI "function"
schema <- ss *> ((identifier <* (char '.')) <|> (string ""))
name <- ss *> identifier
args <- ss *> char '(' *> (arguments `sepBy` (char ','))
ret <- ss *> char ')' *> returnType
_ <- ss
return $ PGFunction (unpack schema) (unpack name) args ret
arguments = do
name <- ss *> identifier
datatype <- ss *> postgresType
def <- ss *> ((asciiCI "default" <|> string "=") *> (takeTill (inClass ",)"))
<|> (string ""))
return $ PGArgument (unpack name) (unpack datatype) ((length def) > 0)
cols = do
name <- ss *> identifier
datatype <- ss *> postgresType <* ss
return $ PGColumn (unpack name) (unpack datatype)
returnType = do
ret <- ss *> asciiCI "returns" *> ss *> (
asciiCI "setof"
<|> asciiCI "table"
<|> postgresType)
case toLower(ret) of
"setof" -> (PGSetOf . unpack) <$> (ss *> postgresType)
"table" -> PGTable <$> (ss *> char '(' *> cols `sepBy` (char ',') <* ss <* char ')')
t -> return $ PGSingle (unpack t)
identifier = do
s1 <- takeWhile1 (inClass "a-zA-Z_")
s2 <- takeWhile (inClass "a-zA-Z_0-9$")
return $ toLower $ s1 `append` s2
postgresType = toLower <$> (foldr1 (<|>) $
(map asciiCI [ "double precision" ])
++ (map (\t -> (asciiCI t <* ss <* (modifiers $ Just 1))) ["bit", "character varying"])
++ (map (\t -> (asciiCI t <* ss <* (modifiers $ Just 2))) ["numeric", "decimal"])
++ ((asciiCI "timestamptz"):(map timeType ["timestamp", "time"]))
++ [intervalType, identifier <* (modifiers Nothing)])
timeType t = do
base <- asciiCI t <* ss <* (modifiers $ Just 1)
tz <- ss *> ((asciiCI "with time zone") <|> (asciiCI "without time zone") <|> (string ""))
return $ case tz of
"" -> base
_ -> base `append` " " `append` tz
intervalType = do
base <- (asciiCI "interval") <* ss
fields <- foldr1 (<|>) $ map asciiCI [
"year to month"
, "day to hour"
, "day to minute"
, "day to second"
, "hour to minute"
, "hour to second"
, "minute to second"
, "year"
, "month"
, "day"
, "hour"
, "minute"
, "second"
, ""]
_ <- ss *> (modifiers $ Just 1)
return $ case fields of
"" -> base
_ -> base `append` " " `append` fields
modifiers limit = (char '(') *> exact <* (char ')') <|> less where
exact = ($ limit) $ maybe
((modifier `sepBy` (char ',')) *> (string ""))
(\n -> foldl1 ((*>) . (*> ((char ',') *> ss))) (replicate n modifier) *> string "")
less = ($ limit) $ maybe
(string "")
(\n -> case n of
1 -> (string "")
_ -> (modifiers $ Just (n 1)))
modifier = (decimal :: Parser Int) *> ss