{-# LANGUAGE TypeApplications #-}
module Database.PostgreSQL.PQTypes.Internal.QueryResult (
QueryResult(..)
, ntuples
, nfields
) where
import Control.Monad
import Data.Foldable
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr
import System.IO.Unsafe
import qualified Control.Exception as E
import Database.PostgreSQL.PQTypes.Format
import Database.PostgreSQL.PQTypes.FromRow
import Database.PostgreSQL.PQTypes.Internal.C.Interface
import Database.PostgreSQL.PQTypes.Internal.C.Types
import Database.PostgreSQL.PQTypes.Internal.Error
import Database.PostgreSQL.PQTypes.Internal.Exception
import Database.PostgreSQL.PQTypes.SQL.Class
data QueryResult t = forall row. FromRow row => QueryResult
{ QueryResult t -> SomeSQL
qrSQL :: !SomeSQL
, QueryResult t -> ForeignPtr PGresult
qrResult :: !(ForeignPtr PGresult)
, ()
qrFromRow :: !(row -> t)
}
instance Functor QueryResult where
a -> b
f fmap :: (a -> b) -> QueryResult a -> QueryResult b
`fmap` QueryResult SomeSQL
ctx ForeignPtr PGresult
fres row -> a
g = SomeSQL -> ForeignPtr PGresult -> (row -> b) -> QueryResult b
forall t row.
FromRow row =>
SomeSQL -> ForeignPtr PGresult -> (row -> t) -> QueryResult t
QueryResult SomeSQL
ctx ForeignPtr PGresult
fres (a -> b
f (a -> b) -> (row -> a) -> row -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. row -> a
g)
instance Foldable QueryResult where
foldr :: (a -> b -> b) -> b -> QueryResult a -> b
foldr = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
False ((CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> CInt
forall a. Enum a => a -> a
pred (IO CInt -> IO CInt)
-> (Ptr PGresult -> IO CInt) -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PGresult -> IO CInt
c_PQntuples) (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> (CInt -> IO CInt) -> CInt -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Ptr PGresult -> IO CInt)
-> CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ -CInt
1) CInt -> CInt
forall a. Enum a => a -> a
pred
foldr' :: (a -> b -> b) -> b -> QueryResult a -> b
foldr' = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
True ((CInt -> CInt) -> IO CInt -> IO CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> CInt
forall a. Enum a => a -> a
pred (IO CInt -> IO CInt)
-> (Ptr PGresult -> IO CInt) -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PGresult -> IO CInt
c_PQntuples) (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> (CInt -> IO CInt) -> CInt -> Ptr PGresult -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Ptr PGresult -> IO CInt)
-> CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ -CInt
1) CInt -> CInt
forall a. Enum a => a -> a
pred
foldl :: (b -> a -> b) -> b -> QueryResult a -> b
foldl = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
False (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> IO CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0) Ptr PGresult -> IO CInt
c_PQntuples CInt -> CInt
forall a. Enum a => a -> a
succ ((a -> b -> b) -> b -> QueryResult a -> b)
-> ((b -> a -> b) -> a -> b -> b)
-> (b -> a -> b)
-> b
-> QueryResult a
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip
foldl' :: (b -> a -> b) -> b -> QueryResult a -> b
foldl' = Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (a -> b -> b)
-> b
-> QueryResult a
-> b
forall t acc.
Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
True (IO CInt -> Ptr PGresult -> IO CInt
forall a b. a -> b -> a
const (IO CInt -> Ptr PGresult -> IO CInt)
-> IO CInt -> Ptr PGresult -> IO CInt
forall a b. (a -> b) -> a -> b
$ CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
0) Ptr PGresult -> IO CInt
c_PQntuples CInt -> CInt
forall a. Enum a => a -> a
succ ((a -> b -> b) -> b -> QueryResult a -> b)
-> ((b -> a -> b) -> a -> b -> b)
-> (b -> a -> b)
-> b
-> QueryResult a
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> b) -> a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip
foldImpl :: Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl :: Bool
-> (Ptr PGresult -> IO CInt)
-> (Ptr PGresult -> IO CInt)
-> (CInt -> CInt)
-> (t -> acc -> acc)
-> acc
-> QueryResult t
-> acc
foldImpl Bool
strict Ptr PGresult -> IO CInt
initCtr Ptr PGresult -> IO CInt
termCtr CInt -> CInt
advCtr t -> acc -> acc
f acc
iacc (QueryResult (SomeSQL sql
ctx) ForeignPtr PGresult
fres row -> t
g) =
IO acc -> acc
forall a. IO a -> a
unsafePerformIO (IO acc -> acc) -> IO acc -> acc
forall a b. (a -> b) -> a -> b
$ ForeignPtr PGresult -> (Ptr PGresult -> IO acc) -> IO acc
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PGresult
fres ((Ptr PGresult -> IO acc) -> IO acc)
-> (Ptr PGresult -> IO acc) -> IO acc
forall a b. (a -> b) -> a -> b
$ \Ptr PGresult
res -> do
Int
rowlen <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> IO CInt
c_PQnfields Ptr PGresult
res
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
rowlen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Proxy row -> Int
forall t. PQFormat t => Proxy t -> Int
pqVariablesP Proxy row
rowp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DBException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO DBException :: forall e sql. (Exception e, Show sql) => sql -> e -> DBException
DBException {
dbeQueryContext :: sql
dbeQueryContext = sql
ctx
, dbeError :: RowLengthMismatch
dbeError = RowLengthMismatch :: Int -> Int -> RowLengthMismatch
RowLengthMismatch {
lengthExpected :: Int
lengthExpected = Proxy row -> Int
forall t. PQFormat t => Proxy t -> Int
pqVariablesP Proxy row
rowp
, lengthDelivered :: Int
lengthDelivered = Int
rowlen
}
}
(Ptr PGerror -> IO acc) -> IO acc
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr PGerror -> IO acc) -> IO acc)
-> (Ptr PGerror -> IO acc) -> IO acc
forall a b. (a -> b) -> a -> b
$ \Ptr PGerror
err -> do
CInt
i <- Ptr PGresult -> IO CInt
initCtr Ptr PGresult
res
CInt
n <- Ptr PGresult -> IO CInt
termCtr Ptr PGresult
res
Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err CInt
i CInt
n acc
iacc
where
row :: row
row = let t
_ = row -> t
g row
row in row
row
rowp :: Proxy row
rowp = row -> Proxy row
forall (f :: * -> *) a. Applicative f => a -> f a
pure row
row
apply :: (acc -> IO acc) -> acc -> IO acc
apply = if Bool
strict then (acc -> IO acc) -> acc -> IO acc
forall a b. (a -> b) -> a -> b
($!) else (acc -> IO acc) -> acc -> IO acc
forall a b. (a -> b) -> a -> b
($)
worker :: Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err !CInt
i CInt
n acc
acc
| CInt
i CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
n = acc -> IO acc
forall (m :: * -> *) a. Monad m => a -> m a
return acc
acc
| Bool
otherwise = do
t
obj <- IO t -> IO t
forall a. IO a -> IO a
E.mask_ (row -> t
g (row -> t) -> IO row -> IO t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> IO row
forall row.
FromRow row =>
Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> IO row
fromRow Ptr PGresult
res Ptr PGerror
err CInt
0 CInt
i IO row -> (SomeException -> IO row) -> IO row
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` sql -> SomeException -> IO row
forall sql a. IsSQL sql => sql -> SomeException -> IO a
rethrowWithContext sql
ctx)
Ptr PGresult -> Ptr PGerror -> CInt -> CInt -> acc -> IO acc
worker Ptr PGresult
res Ptr PGerror
err (CInt -> CInt
advCtr CInt
i) CInt
n (acc -> IO acc) -> acc -> IO acc
`apply` t -> acc -> acc
f t
obj acc
acc
ntuples :: QueryResult t -> Int
ntuples :: QueryResult t -> Int
ntuples QueryResult t
qr = IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr PGresult -> (Ptr PGresult -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (QueryResult t -> ForeignPtr PGresult
forall t. QueryResult t -> ForeignPtr PGresult
qrResult QueryResult t
qr) Ptr PGresult -> IO CInt
c_PQntuples
nfields :: QueryResult t -> Int
nfields :: QueryResult t -> Int
nfields QueryResult t
qr = IO Int -> Int
forall a. IO a -> a
unsafeDupablePerformIO (IO Int -> Int) -> IO Int -> Int
forall a b. (a -> b) -> a -> b
$ do
CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForeignPtr PGresult -> (Ptr PGresult -> IO CInt) -> IO CInt
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (QueryResult t -> ForeignPtr PGresult
forall t. QueryResult t -> ForeignPtr PGresult
qrResult QueryResult t
qr) Ptr PGresult -> IO CInt
c_PQnfields