{-# LANGUAGE CPP, PatternGuards, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, GADTs, DataKinds, TemplateHaskell #-}
module Database.PostgreSQL.Typed.Query
( PGQuery(..)
, PGSimpleQuery
, PGPreparedQuery
, rawPGSimpleQuery
, rawPGPreparedQuery
, QueryFlags(..)
, simpleQueryFlags
, parseQueryFlags
, makePGQuery
, pgSQL
, pgExecute
, pgQuery
, pgLazyQuery
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow ((***), first, second)
import Control.Exception (try)
import Control.Monad (void, when, mapAndUnzipM)
import Data.Array (listArray, (!), inRange)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import qualified Data.ByteString.UTF8 as BSU
import Data.Char (isSpace, isAlphaNum)
import qualified Data.Foldable as Fold
import Data.List (dropWhileEnd)
import Data.Maybe (fromMaybe, isNothing)
import Data.String (IsString(..))
import Data.Word (Word32)
import Language.Haskell.Meta.Parse (parseExp)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Dynamic
import Database.PostgreSQL.Typed.Protocol
import Database.PostgreSQL.Typed.TH
import Database.PostgreSQL.Typed.SQLToken
class PGQuery q a | q -> a where
pgRunQuery :: PGConnection -> q -> IO (Int, [a])
unsafeModifyQuery :: q -> (BS.ByteString -> BS.ByteString) -> q
getQueryString :: PGTypeEnv -> q -> BS.ByteString
class PGQuery q PGValues => PGRawQuery q
pgExecute :: PGQuery q () => PGConnection -> q -> IO Int
pgExecute :: forall q. PGQuery q () => PGConnection -> q -> IO Int
pgExecute PGConnection
c q
q = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q a. PGQuery q a => PGConnection -> q -> IO (Int, [a])
pgRunQuery PGConnection
c q
q
pgQuery :: PGQuery q a => PGConnection -> q -> IO [a]
pgQuery :: forall q a. PGQuery q a => PGConnection -> q -> IO [a]
pgQuery PGConnection
c q
q = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q a. PGQuery q a => PGConnection -> q -> IO (Int, [a])
pgRunQuery PGConnection
c q
q
instance PGQuery BS.ByteString PGValues where
pgRunQuery :: PGConnection -> ByteString -> IO (Int, [PGValues])
pgRunQuery PGConnection
c ByteString
sql = PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> ByteString
BSL.fromStrict ByteString
sql)
unsafeModifyQuery :: ByteString -> (ByteString -> ByteString) -> ByteString
unsafeModifyQuery ByteString
q ByteString -> ByteString
f = ByteString -> ByteString
f ByteString
q
getQueryString :: PGTypeEnv -> ByteString -> ByteString
getQueryString PGTypeEnv
_ = forall a. a -> a
id
newtype SimpleQuery = SimpleQuery BS.ByteString
deriving (Int -> SimpleQuery -> ShowS
[SimpleQuery] -> ShowS
SimpleQuery -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleQuery] -> ShowS
$cshowList :: [SimpleQuery] -> ShowS
show :: SimpleQuery -> String
$cshow :: SimpleQuery -> String
showsPrec :: Int -> SimpleQuery -> ShowS
$cshowsPrec :: Int -> SimpleQuery -> ShowS
Show)
instance PGQuery SimpleQuery PGValues where
pgRunQuery :: PGConnection -> SimpleQuery -> IO (Int, [PGValues])
pgRunQuery PGConnection
c (SimpleQuery ByteString
sql) = PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> ByteString
BSL.fromStrict ByteString
sql)
unsafeModifyQuery :: SimpleQuery -> (ByteString -> ByteString) -> SimpleQuery
unsafeModifyQuery (SimpleQuery ByteString
sql) ByteString -> ByteString
f = ByteString -> SimpleQuery
SimpleQuery forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
f ByteString
sql
getQueryString :: PGTypeEnv -> SimpleQuery -> ByteString
getQueryString PGTypeEnv
_ (SimpleQuery ByteString
q) = ByteString
q
instance PGRawQuery SimpleQuery
data PreparedQuery = PreparedQuery BS.ByteString [OID] PGValues [Bool]
deriving (Int -> PreparedQuery -> ShowS
[PreparedQuery] -> ShowS
PreparedQuery -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PreparedQuery] -> ShowS
$cshowList :: [PreparedQuery] -> ShowS
show :: PreparedQuery -> String
$cshow :: PreparedQuery -> String
showsPrec :: Int -> PreparedQuery -> ShowS
$cshowsPrec :: Int -> PreparedQuery -> ShowS
Show)
instance PGQuery PreparedQuery PGValues where
pgRunQuery :: PGConnection -> PreparedQuery -> IO (Int, [PGValues])
pgRunQuery PGConnection
c (PreparedQuery ByteString
sql [OID]
types PGValues
bind [Bool]
bc) = PGConnection
-> ByteString
-> [OID]
-> PGValues
-> [Bool]
-> IO (Int, [PGValues])
pgPreparedQuery PGConnection
c ByteString
sql [OID]
types PGValues
bind [Bool]
bc
unsafeModifyQuery :: PreparedQuery -> (ByteString -> ByteString) -> PreparedQuery
unsafeModifyQuery (PreparedQuery ByteString
sql [OID]
types PGValues
bind [Bool]
bc) ByteString -> ByteString
f = ByteString -> [OID] -> PGValues -> [Bool] -> PreparedQuery
PreparedQuery (ByteString -> ByteString
f ByteString
sql) [OID]
types PGValues
bind [Bool]
bc
getQueryString :: PGTypeEnv -> PreparedQuery -> ByteString
getQueryString PGTypeEnv
_ (PreparedQuery ByteString
q [OID]
_ PGValues
_ [Bool]
_) = ByteString
q
instance PGRawQuery PreparedQuery
data QueryParser q a = QueryParser (PGTypeEnv -> q) (PGTypeEnv -> PGValues -> a)
instance PGRawQuery q => PGQuery (QueryParser q a) a where
pgRunQuery :: PGConnection -> QueryParser q a -> IO (Int, [a])
pgRunQuery PGConnection
c (QueryParser PGTypeEnv -> q
q PGTypeEnv -> PGValues -> a
p) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ PGTypeEnv -> PGValues -> a
p PGTypeEnv
e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall q a. PGQuery q a => PGConnection -> q -> IO (Int, [a])
pgRunQuery PGConnection
c (PGTypeEnv -> q
q PGTypeEnv
e) where e :: PGTypeEnv
e = PGConnection -> PGTypeEnv
pgTypeEnv PGConnection
c
unsafeModifyQuery :: QueryParser q a -> (ByteString -> ByteString) -> QueryParser q a
unsafeModifyQuery (QueryParser PGTypeEnv -> q
q PGTypeEnv -> PGValues -> a
p) ByteString -> ByteString
f = forall q a.
(PGTypeEnv -> q) -> (PGTypeEnv -> PGValues -> a) -> QueryParser q a
QueryParser (\PGTypeEnv
e -> forall q a. PGQuery q a => q -> (ByteString -> ByteString) -> q
unsafeModifyQuery (PGTypeEnv -> q
q PGTypeEnv
e) ByteString -> ByteString
f) PGTypeEnv -> PGValues -> a
p
getQueryString :: PGTypeEnv -> QueryParser q a -> ByteString
getQueryString PGTypeEnv
e (QueryParser PGTypeEnv -> q
q PGTypeEnv -> PGValues -> a
_) = forall q a. PGQuery q a => PGTypeEnv -> q -> ByteString
getQueryString PGTypeEnv
e forall a b. (a -> b) -> a -> b
$ PGTypeEnv -> q
q PGTypeEnv
e
instance Functor (QueryParser q) where
fmap :: forall a b. (a -> b) -> QueryParser q a -> QueryParser q b
fmap a -> b
f (QueryParser PGTypeEnv -> q
q PGTypeEnv -> PGValues -> a
p) = forall q a.
(PGTypeEnv -> q) -> (PGTypeEnv -> PGValues -> a) -> QueryParser q a
QueryParser PGTypeEnv -> q
q (\PGTypeEnv
e -> a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTypeEnv -> PGValues -> a
p PGTypeEnv
e)
instance Show q => Show (QueryParser q a) where
showsPrec :: Int -> QueryParser q a -> ShowS
showsPrec Int
p (QueryParser PGTypeEnv -> q
q PGTypeEnv -> PGValues -> a
_) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"QueryParser " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (PGTypeEnv -> q
q PGTypeEnv
unknownPGTypeEnv)
rawParser :: q -> QueryParser q PGValues
rawParser :: forall q. q -> QueryParser q PGValues
rawParser q
q = forall q a.
(PGTypeEnv -> q) -> (PGTypeEnv -> PGValues -> a) -> QueryParser q a
QueryParser (forall a b. a -> b -> a
const q
q) (forall a b. a -> b -> a
const forall a. a -> a
id)
type PGSimpleQuery = QueryParser SimpleQuery
type PGPreparedQuery = QueryParser PreparedQuery
rawPGSimpleQuery :: BS.ByteString -> PGSimpleQuery PGValues
rawPGSimpleQuery :: ByteString -> PGSimpleQuery PGValues
rawPGSimpleQuery = forall q. q -> QueryParser q PGValues
rawParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> SimpleQuery
SimpleQuery
instance IsString (PGSimpleQuery PGValues) where
fromString :: String -> PGSimpleQuery PGValues
fromString = ByteString -> PGSimpleQuery PGValues
rawPGSimpleQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString
instance IsString (PGSimpleQuery ()) where
fromString :: String -> PGSimpleQuery ()
fromString = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PGSimpleQuery PGValues
rawPGSimpleQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString
rawPGPreparedQuery :: BS.ByteString -> PGValues -> PGPreparedQuery PGValues
rawPGPreparedQuery :: ByteString -> PGValues -> PGPreparedQuery PGValues
rawPGPreparedQuery ByteString
sql PGValues
bind = forall q. q -> QueryParser q PGValues
rawParser forall a b. (a -> b) -> a -> b
$ ByteString -> [OID] -> PGValues -> [Bool] -> PreparedQuery
PreparedQuery ByteString
sql [] PGValues
bind []
pgLazyQuery :: PGConnection -> PGPreparedQuery a -> Word32
-> IO [a]
pgLazyQuery :: forall a. PGConnection -> PGPreparedQuery a -> OID -> IO [a]
pgLazyQuery PGConnection
c (QueryParser PGTypeEnv -> PreparedQuery
q PGTypeEnv -> PGValues -> a
p) OID
count =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PGTypeEnv -> PGValues -> a
p PGTypeEnv
e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection
-> ByteString
-> [OID]
-> PGValues
-> [Bool]
-> OID
-> IO [PGValues]
pgPreparedLazyQuery PGConnection
c ByteString
sql [OID]
types PGValues
bind [Bool]
bc OID
count where
e :: PGTypeEnv
e = PGConnection -> PGTypeEnv
pgTypeEnv PGConnection
c
PreparedQuery ByteString
sql [OID]
types PGValues
bind [Bool]
bc = PGTypeEnv -> PreparedQuery
q PGTypeEnv
e
sqlPlaceholders :: String -> (String, [String])
sqlPlaceholders :: String -> (String, [String])
sqlPlaceholders = forall {t}.
(Show t, Enum t) =>
t -> [SQLToken] -> (String, [String])
sst (Int
1 :: Int) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [SQLToken]
sqlTokens where
sst :: t -> [SQLToken] -> (String, [String])
sst t
n (SQLExpr String
e : [SQLToken]
l) = ((Char
'$'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show t
n) forall a. [a] -> [a] -> [a]
++) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String
e forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ t -> [SQLToken] -> (String, [String])
sst (forall a. Enum a => a -> a
succ t
n) [SQLToken]
l
sst t
n (SQLToken
t : [SQLToken]
l) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a. Show a => a -> String
show SQLToken
t forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ t -> [SQLToken] -> (String, [String])
sst t
n [SQLToken]
l
sst t
_ [] = (String
"", [])
sqlSubstitute :: String -> [TH.Exp] -> TH.Exp
sqlSubstitute :: String -> [Exp] -> Exp
sqlSubstitute String
sql [Exp]
exprl = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE 'BS.concat) forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
TH.ListE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SQLToken -> Exp
sst forall a b. (a -> b) -> a -> b
$ String -> [SQLToken]
sqlTokens String
sql where
bnds :: (Int, Int)
bnds = (Int
1, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exprl)
exprs :: Array Int Exp
exprs = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int, Int)
bnds [Exp]
exprl
expr :: Int -> Exp
expr Int
n
| forall a. Ix a => (a, a) -> a -> Bool
inRange (Int, Int)
bnds Int
n = Array Int Exp
exprs forall i e. Ix i => Array i e -> i -> e
! Int
n
| Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"SQL placeholder '$" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
"' out of range (not recognized by PostgreSQL)"
sst :: SQLToken -> Exp
sst (SQLParam Int
n) = Int -> Exp
expr Int
n
sst SQLToken
t = Name -> Exp
TH.VarE 'BSU.fromString Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
TH.LitE (String -> Lit
TH.StringL forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SQLToken
t)
splitCommas :: String -> [String]
splitCommas :: String -> [String]
splitCommas = String -> [String]
spl where
spl :: String -> [String]
spl [] = []
spl [Char
c] = [[Char
c]]
spl (Char
',':String
s) = String
""forall a. a -> [a] -> [a]
:String -> [String]
spl String
s
spl (Char
c:String
s) = (Char
cforall a. a -> [a] -> [a]
:String
h)forall a. a -> [a] -> [a]
:[String]
t where String
h:[String]
t = String -> [String]
spl String
s
trim :: String -> String
trim :: ShowS
trim = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
data QueryFlags = QueryFlags
{ QueryFlags -> Bool
flagQuery :: Bool
, QueryFlags -> Maybe Bool
flagNullable :: Maybe Bool
, QueryFlags -> Maybe [String]
flagPrepare :: Maybe [String]
}
simpleQueryFlags :: QueryFlags
simpleQueryFlags :: QueryFlags
simpleQueryFlags = Bool -> Maybe Bool -> Maybe [String] -> QueryFlags
QueryFlags Bool
True forall a. Maybe a
Nothing forall a. Maybe a
Nothing
newName :: Char -> BS.ByteString -> TH.Q TH.Name
newName :: Char -> ByteString -> Q Name
newName Char
pre = forall (m :: * -> *). Quote m => String -> m Name
TH.newName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'_'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
preforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSC.unpack
makePGQuery :: QueryFlags -> String -> TH.ExpQ
makePGQuery :: QueryFlags -> String -> ExpQ
makePGQuery QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
False } String
sqle = String -> ExpQ
pgSubstituteLiterals String
sqle
makePGQuery QueryFlags{ flagNullable :: QueryFlags -> Maybe Bool
flagNullable = Maybe Bool
nulls, flagPrepare :: QueryFlags -> Maybe [String]
flagPrepare = Maybe [String]
prep } String
sqle = do
([TPGValueInfo]
pt, [TPGValueInfo]
rt) <- forall a. IO a -> Q a
TH.runIO forall a b. (a -> b) -> a -> b
$ ByteString
-> [String] -> Bool -> IO ([TPGValueInfo], [TPGValueInfo])
tpgDescribe (String -> ByteString
BSU.fromString String
sqlp) (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
prep) (forall a. Maybe a -> Bool
isNothing Maybe Bool
nulls)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TPGValueInfo]
pt forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
exprs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not all expression placeholders were recognized by PostgreSQL"
Name
e <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"_tenv"
Name
l <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"l"
([Pat]
vars, [Exp]
vals) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (\TPGValueInfo
t -> do
Name
v <- Char -> ByteString -> Q Name
newName Char
'p' forall a b. (a -> b) -> a -> b
$ TPGValueInfo -> ByteString
tpgValueName TPGValueInfo
t
forall (m :: * -> *) a. Monad m => a -> m a
return
( Name -> Pat
TH.VarP Name
v
, Bool -> TPGValueInfo -> Name -> Exp
tpgTypeEncoder (forall a. Maybe a -> Bool
isNothing Maybe [String]
prep) TPGValueInfo
t Name
e Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v
)) [TPGValueInfo]
pt
([Pat]
pats, [Exp]
conv, [Exp]
bins) <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\TPGValueInfo
t -> do
Name
v <- Char -> ByteString -> Q Name
newName Char
'c' forall a b. (a -> b) -> a -> b
$ TPGValueInfo -> ByteString
tpgValueName TPGValueInfo
t
forall (m :: * -> *) a. Monad m => a -> m a
return
( Name -> Pat
TH.VarP Name
v
, Bool -> TPGValueInfo -> Name -> Exp
tpgTypeDecoder (forall (t :: * -> *). Foldable t => t Bool -> Bool
Fold.and Maybe Bool
nulls) TPGValueInfo
t Name
e Exp -> Exp -> Exp
`TH.AppE` Name -> Exp
TH.VarE Name
v
, TPGValueInfo -> Name -> Exp
tpgTypeBinary TPGValueInfo
t Name
e
)) [TPGValueInfo]
rt
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
TH.AppE ([Pat] -> Exp -> Exp
TH.LamE [Pat]
vars forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE 'QueryParser
Exp -> Exp -> Exp
`TH.AppE` [Pat] -> Exp -> Exp
TH.LamE [Name -> Pat
TH.VarP Name
e] (forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Name -> Exp
TH.ConE 'SimpleQuery
Exp -> Exp -> Exp
`TH.AppE` String -> [Exp] -> Exp
sqlSubstitute String
sqlp [Exp]
vals)
(\[String]
p -> Name -> Exp
TH.ConE 'PreparedQuery
Exp -> Exp -> Exp
`TH.AppE` (Name -> Exp
TH.VarE 'BSU.fromString Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
TH.LitE (String -> Lit
TH.StringL String
sqlp))
Exp -> Exp -> Exp
`TH.AppE` [Exp] -> Exp
TH.ListE (forall a b. (a -> b) -> [a] -> [b]
map (Lit -> Exp
TH.LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
TH.IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPGValueInfo -> OID
tpgValueTypeOID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [String]
p [TPGValueInfo]
pt)
Exp -> Exp -> Exp
`TH.AppE` [Exp] -> Exp
TH.ListE [Exp]
vals
Exp -> Exp -> Exp
`TH.AppE` [Exp] -> Exp
TH.ListE
#ifdef VERSION_postgresql_binary
bins
#else
[]
#endif
)
Maybe [String]
prep)
Exp -> Exp -> Exp
`TH.AppE` [Pat] -> Exp -> Exp
TH.LamE [Name -> Pat
TH.VarP Name
e, Name -> Pat
TH.VarP Name
l] (Exp -> [Match] -> Exp
TH.CaseE (Name -> Exp
TH.VarE Name
l)
[ Pat -> Body -> [Dec] -> Match
TH.Match ([Pat] -> Pat
TH.ListP [Pat]
pats) (Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ case [Exp]
conv of
[Exp
x] -> Exp
x
[Exp]
_ -> [Maybe Exp] -> Exp
TH.TupE
#if MIN_VERSION_template_haskell(2,16,0)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
[Exp]
conv) []
, Pat -> Body -> [Dec] -> Match
TH.Match Pat
TH.WildP (Exp -> Body
TH.NormalB forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE 'error Exp -> Exp -> Exp
`TH.AppE` Lit -> Exp
TH.LitE (String -> Lit
TH.StringL String
"pgSQL: result arity mismatch")) []
]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadFail m => String -> m Exp
parse [String]
exprs
where
(String
sqlp, [String]
exprs) = String -> (String, [String])
sqlPlaceholders String
sqle
parse :: String -> m Exp
parse String
e = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a] -> [a]
(++) (String
"Failed to parse expression {" forall a. [a] -> [a] -> [a]
++ String
e forall a. [a] -> [a] -> [a]
++ String
"}: ")) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Either String Exp
parseExp String
e
parseQueryFlags :: String -> (QueryFlags, String)
parseQueryFlags :: String -> (QueryFlags, String)
parseQueryFlags = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
simpleQueryFlags where
pqf :: QueryFlags -> String -> (QueryFlags, String)
pqf f :: QueryFlags
f@QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
True, flagPrepare :: QueryFlags -> Maybe [String]
flagPrepare = Maybe [String]
Nothing } (Char
'#':String
q) = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
f{ flagQuery :: Bool
flagQuery = Bool
False } String
q
pqf f :: QueryFlags
f@QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
True, flagNullable :: QueryFlags -> Maybe Bool
flagNullable = Maybe Bool
Nothing } (Char
'?':String
q) = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
f{ flagNullable :: Maybe Bool
flagNullable = forall a. a -> Maybe a
Just Bool
True } String
q
pqf f :: QueryFlags
f@QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
True, flagNullable :: QueryFlags -> Maybe Bool
flagNullable = Maybe Bool
Nothing } (Char
'!':String
q) = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
f{ flagNullable :: Maybe Bool
flagNullable = forall a. a -> Maybe a
Just Bool
False } String
q
pqf f :: QueryFlags
f@QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
True, flagPrepare :: QueryFlags -> Maybe [String]
flagPrepare = Maybe [String]
Nothing } (Char
'$':String
q) = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
f{ flagPrepare :: Maybe [String]
flagPrepare = forall a. a -> Maybe a
Just [] } String
q
pqf f :: QueryFlags
f@QueryFlags{ flagQuery :: QueryFlags -> Bool
flagQuery = Bool
True, flagPrepare :: QueryFlags -> Maybe [String]
flagPrepare = Just [] } (Char
'(':String
s) = QueryFlags -> String -> (QueryFlags, String)
pqf QueryFlags
f{ flagPrepare :: Maybe [String]
flagPrepare = forall a. a -> Maybe a
Just [String]
args } (ShowS
sql String
r) where
args :: [String]
args = forall a b. (a -> b) -> [a] -> [b]
map ShowS
trim forall a b. (a -> b) -> a -> b
$ String -> [String]
splitCommas String
arg
(String
arg, String
r) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
')' forall a. Eq a => a -> a -> Bool
==) String
s
sql :: ShowS
sql (Char
')':String
q) = String
q
sql String
_ = forall a. HasCallStack => String -> a
error String
"pgSQL: unterminated argument list"
pqf QueryFlags
f String
q = (QueryFlags
f, String
q)
qqQuery :: String -> TH.ExpQ
qqQuery :: String -> ExpQ
qqQuery = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry QueryFlags -> String -> ExpQ
makePGQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (QueryFlags, String)
parseQueryFlags
qqTop :: Bool -> String -> TH.DecsQ
qqTop :: Bool -> String -> DecsQ
qqTop Bool
True (Char
'!':String
sql) = Bool -> String -> DecsQ
qqTop Bool
False String
sql
qqTop Bool
err String
sql = do
Either PGError (Int, [PGValues])
r <- forall a. IO a -> Q a
TH.runIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. (PGConnection -> IO a) -> IO a
withTPGConnection forall a b. (a -> b) -> a -> b
$ \PGConnection
c ->
PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (String -> ByteString
BSLU.fromString String
sql)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((if Bool
err then String -> Q ()
TH.reportError else String -> Q ()
TH.reportWarning) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Show a => a -> String
show :: PGError -> String)) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) Either PGError (Int, [PGValues])
r
forall (m :: * -> *) a. Monad m => a -> m a
return []
pgSQL :: QuasiQuoter
pgSQL :: QuasiQuoter
pgSQL = QuasiQuoter
{ quoteExp :: String -> ExpQ
quoteExp = String -> ExpQ
qqQuery
, quoteType :: String -> Q Type
quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pgSQL not supported in types"
, quotePat :: String -> Q Pat
quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pgSQL not supported in patterns"
, quoteDec :: String -> DecsQ
quoteDec = Bool -> String -> DecsQ
qqTop Bool
True
}