module Database.PostgreSQL.Store.Query (
Query (..),
SelectorElement (..),
QueryTable (..),
pgsq,
pgss,
quoteIdentifier,
QueryCode,
QueryBuildable,
QueryBuilder,
runQueryBuilder,
writeCode,
writeStringCode,
writeIdentifier,
writeAbsIdentifier,
writeParam,
writeColumn,
intercalateBuilder
) where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Applicative
import Control.Monad.State.Strict
import Data.List
import Data.Proxy
import Data.Monoid
import Data.String
import qualified Data.Text as T
import qualified Data.ByteString as B
import Data.Char
import Data.Attoparsec.Text
import Database.PostgreSQL.Store.Columns
quoteIdentifier :: String -> String
quoteIdentifier name =
'"' : stripQuotes name ++ "\""
where
stripQuotes [] = []
stripQuotes ('"' : xs) = '"' : '"' : stripQuotes xs
stripQuotes (x : xs) = x : stripQuotes xs
data Query = Query {
queryStatement :: !B.ByteString,
queryParams :: ![Value]
} deriving (Show, Eq, Ord)
data SelectorElement
= SelectorField String
| SelectorSpecial String
deriving (Show, Eq, Ord)
class QueryTable a where
tableName :: Proxy a -> String
tableIDName :: Proxy a -> String
tableSelectors :: Proxy a -> [SelectorElement]
makeTableIdentifier :: (QueryTable a, IsString b) => Proxy a -> b
makeTableIdentifier proxy =
fromString (quoteIdentifier (tableName proxy))
makeTableIDIdentifier :: (QueryTable a, IsString b) => Proxy a -> b
makeTableIDIdentifier proxy =
fromString (quoteIdentifier (tableName proxy) ++
"." ++
quoteIdentifier (tableIDName proxy))
makeTableSelectors :: (QueryTable a, IsString b) => Proxy a -> b
makeTableSelectors proxy =
fromString (intercalate ", " (map makeElement (tableSelectors proxy)))
where
makeElement (SelectorField name) =
quoteIdentifier (tableName proxy) ++ "." ++ quoteIdentifier name
makeElement (SelectorSpecial expr) =
expr
data Segment
= SSelector String
| STable String
| SVariable String
| SIdentifier String
| SQuote Char String
| SOther String
name :: Parser String
name =
(:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_')
typeName :: Parser String
typeName =
(:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_')
qualifiedTypeName :: Parser String
qualifiedTypeName = do
intercalate "." <$> sepBy1 typeName (char '.')
quote :: Char -> Parser Segment
quote delim = do
char delim
cnt <- concat <$> many (choice [escapedDelim, notDelim])
char delim
pure (SQuote delim cnt)
where
escapedDelim = (\ a b -> [a, b]) <$> char '\\' <*> char delim
notDelim = (: []) <$> notChar delim
segments :: Parser [Segment]
segments =
many (choice [quote '"',
quote '\'',
char '#' >> SSelector <$> qualifiedTypeName,
char '@' >> STable <$> qualifiedTypeName,
char '&' >> SIdentifier <$> qualifiedTypeName,
char '$' >> SVariable <$> name,
SOther "#" <$ char '#',
SOther "@" <$ char '@',
SOther "&" <$ char '&',
SOther "$" <$ char '$',
SOther <$> some (satisfy (notInClass "\"'#@&$"))])
reduceSegment :: Segment -> QueryBuilder [Q Exp] (Q Exp)
reduceSegment seg =
case seg of
SOther str ->
writeStringCode str
SQuote delim cnt ->
writeStringCode (delim : cnt ++ [delim])
SVariable varName -> writeParam $ do
mbName <- lookupValueName varName
case mbName of
Just name -> [e| pack $(varE name) |]
Nothing -> fail ("'" ++ varName ++ "' does not refer to anything")
STable tableName -> writeCode $ do
mbName <- lookupTypeName tableName
case mbName of
Just table -> [e| makeTableIdentifier (Proxy :: Proxy $(conT table)) |]
Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything")
SSelector tableName -> writeCode $ do
mbName <- lookupTypeName tableName
case mbName of
Just table -> [e| makeTableSelectors (Proxy :: Proxy $(conT table)) |]
Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything")
SIdentifier tableName -> writeCode $ do
mbName <- lookupTypeName tableName
case mbName of
Just table -> [e| makeTableIDIdentifier (Proxy :: Proxy $(conT table)) |]
Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything")
parseStoreQueryE :: String -> Q Exp
parseStoreQueryE code = do
case parseOnly (segments <* endOfInput) (T.pack code) of
Left msg ->
fail msg
Right xs -> do
runQueryBuilder (mapM_ reduceSegment xs)
pgsq :: QuasiQuoter
pgsq =
QuasiQuoter {
quoteExp = parseStoreQueryE,
quotePat = const (fail "Cannot use 'pgsq' in pattern"),
quoteType = const (fail "Cannot use 'pgsq' in type"),
quoteDec = const (fail "Cannot use 'pgsq' in declaration")
}
parseStoreStatementE :: String -> Q Exp
parseStoreStatementE code = do
case parseOnly (segments <* endOfInput) (T.pack code) of
Left msg ->
fail (show msg)
Right xs -> do
[e| mconcat $(listE (runQueryBuilder_ (mapM_ reduceSegment xs))) |]
pgss :: QuasiQuoter
pgss =
QuasiQuoter {
quoteExp = parseStoreStatementE,
quotePat = const (fail "Cannot use 'pgss' in pattern"),
quoteType = const (fail "Cannot use 'pgss' in type"),
quoteDec = const (fail "Cannot use 'pgss' in declaration")
}
data BuilderState s p = BuilderState s Word [p]
class QueryCode s where
type Code s
appendCode :: s -> Code s -> s
appendStringCode :: s -> String -> s
instance QueryCode B.ByteString where
type Code B.ByteString = B.ByteString
appendCode = B.append
appendStringCode bs str = bs <> fromString str
instance QueryCode [Q Exp] where
type Code [Q Exp] = Q Exp
appendCode segments exp = segments ++ [exp]
appendStringCode segments str = appendCode segments [e| fromString $(stringE str) |]
instance QueryCode String where
type Code String = String
appendCode segments code = segments ++ code
appendStringCode = appendCode
class QueryBuildable s p o | s p -> o where
buildQuery :: s -> [p] -> o
instance QueryBuildable B.ByteString Value Query where
buildQuery = Query
instance QueryBuildable String (Q Exp) (Q Exp) where
buildQuery code params =
[e| Query (fromString $(stringE code)) $(listE params) |]
instance QueryBuildable [Q Exp] (Q Exp) (Q Exp) where
buildQuery codeSegments params =
[e| Query (B.concat $(listE codeSegments)) $(listE params) |]
type QueryBuilder s p = State (BuilderState s p) ()
runQueryBuilder :: (QueryBuildable s p o, Monoid s) => QueryBuilder s p -> o
runQueryBuilder builder =
buildQuery code params
where
BuilderState code _ params = execState builder (BuilderState mempty 1 [])
runQueryBuilder_ :: (Monoid s) => QueryBuilder s p -> s
runQueryBuilder_ builder =
code
where
BuilderState code _ _ = execState builder (BuilderState mempty 1 [])
writeCode :: (QueryCode s) => Code s -> QueryBuilder s p
writeCode code =
modify $ \ (BuilderState stmt idx params) ->
BuilderState (appendCode stmt code) idx params
writeStringCode :: (QueryCode s) => String -> QueryBuilder s p
writeStringCode code =
modify $ \ (BuilderState stmt idx params) ->
BuilderState (appendStringCode stmt code) idx params
writeIdentifier :: (QueryCode s) => String -> QueryBuilder s p
writeIdentifier name =
writeStringCode (quoteIdentifier name)
writeAbsIdentifier :: (QueryCode s) => String -> String -> QueryBuilder s p
writeAbsIdentifier ns name = do
writeIdentifier ns
writeStringCode "."
writeIdentifier name
writeParam :: (QueryCode s) => p -> QueryBuilder s p
writeParam param = do
modify $ \ (BuilderState code idx params) ->
BuilderState (appendStringCode code ("$" ++ show idx)) (idx + 1) (params ++ [param])
writeColumn :: (Column p, QueryCode s) => p -> QueryBuilder s Value
writeColumn param =
writeParam (pack param)
intercalateBuilder :: QueryBuilder s p -> [QueryBuilder s p] -> QueryBuilder s p
intercalateBuilder x xs =
sequence_ (intersperse x xs)