module Database.PostgreSQL.PQTypes.Fold
  ( queryResult
  , foldrDB
  , foldlDB
  , mapDB_
  , fetchMany
  , fetchMaybe
  , fetchOne
  ) where

import Control.Monad.Catch
import Data.Functor
import GHC.Stack

import Database.PostgreSQL.PQTypes.Class
import Database.PostgreSQL.PQTypes.FromRow
import Database.PostgreSQL.PQTypes.Internal.Error
import Database.PostgreSQL.PQTypes.Internal.QueryResult
import Database.PostgreSQL.PQTypes.Utils

-- | Get current 'QueryResult' or throw an exception if there isn't one.
queryResult
  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
  => m (QueryResult row)
queryResult :: forall (m :: * -> *) row.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
m (QueryResult row)
queryResult =
  (HasCallStack => m (QueryResult row)) -> m (QueryResult row)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (QueryResult row)) -> m (QueryResult row))
-> (HasCallStack => m (QueryResult row)) -> m (QueryResult row)
forall a b. (a -> b) -> a -> b
$
    m (Maybe (QueryResult row))
forall row. FromRow row => m (Maybe (QueryResult row))
forall (m :: * -> *) row.
(MonadDB m, FromRow row) =>
m (Maybe (QueryResult row))
getQueryResult
      m (Maybe (QueryResult row))
-> (Maybe (QueryResult row) -> m (QueryResult row))
-> m (QueryResult row)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (QueryResult row)
-> (QueryResult row -> m (QueryResult row))
-> Maybe (QueryResult row)
-> m (QueryResult row)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HPQTypesError -> m (QueryResult row)
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadDB m, MonadThrow m) =>
e -> m a
throwDB (HPQTypesError -> m (QueryResult row))
-> (String -> HPQTypesError) -> String -> m (QueryResult row)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HPQTypesError
HPQTypesError (String -> m (QueryResult row)) -> String -> m (QueryResult row)
forall a b. (a -> b) -> a -> b
$ String
"queryResult: no query result") QueryResult row -> m (QueryResult row)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

----------------------------------------

-- | Fetcher of rows returned by a query as a monadic right fold.
foldrDB
  :: (HasCallStack, MonadDB m, FromRow row)
  => (row -> acc -> m acc)
  -> acc
  -> m acc
foldrDB :: forall (m :: * -> *) row acc.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> acc -> m acc) -> acc -> m acc
foldrDB row -> acc -> m acc
f acc
acc =
  (HasCallStack => m acc) -> m acc
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m acc) -> m acc)
-> (HasCallStack => m acc) -> m acc
forall a b. (a -> b) -> a -> b
$
    m (Maybe (QueryResult row))
forall row. FromRow row => m (Maybe (QueryResult row))
forall (m :: * -> *) row.
(MonadDB m, FromRow row) =>
m (Maybe (QueryResult row))
getQueryResult
      m (Maybe (QueryResult row))
-> (Maybe (QueryResult row) -> m acc) -> m acc
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m acc
-> (QueryResult row -> m acc) -> Maybe (QueryResult row) -> m acc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (acc -> m acc
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc) (Bool -> (row -> acc -> m acc) -> acc -> QueryResult row -> m acc
forall (m :: * -> *) t acc.
(HasCallStack, Monad m) =>
Bool -> (t -> acc -> m acc) -> acc -> QueryResult t -> m acc
foldrImpl Bool
False row -> acc -> m acc
f acc
acc)

-- | Fetcher of rows returned by a query as a monadic left fold.
foldlDB
  :: (HasCallStack, MonadDB m, FromRow row)
  => (acc -> row -> m acc)
  -> acc
  -> m acc
foldlDB :: forall (m :: * -> *) row acc.
(HasCallStack, MonadDB m, FromRow row) =>
(acc -> row -> m acc) -> acc -> m acc
foldlDB acc -> row -> m acc
f acc
acc =
  (HasCallStack => m acc) -> m acc
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m acc) -> m acc)
-> (HasCallStack => m acc) -> m acc
forall a b. (a -> b) -> a -> b
$
    m (Maybe (QueryResult row))
forall row. FromRow row => m (Maybe (QueryResult row))
forall (m :: * -> *) row.
(MonadDB m, FromRow row) =>
m (Maybe (QueryResult row))
getQueryResult
      m (Maybe (QueryResult row))
-> (Maybe (QueryResult row) -> m acc) -> m acc
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m acc
-> (QueryResult row -> m acc) -> Maybe (QueryResult row) -> m acc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (acc -> m acc
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure acc
acc) (Bool -> (acc -> row -> m acc) -> acc -> QueryResult row -> m acc
forall (m :: * -> *) acc t.
(HasCallStack, Monad m) =>
Bool -> (acc -> t -> m acc) -> acc -> QueryResult t -> m acc
foldlImpl Bool
False acc -> row -> m acc
f acc
acc)

-- | Fetcher of rows returned by a query as a monadic map.
mapDB_
  :: (HasCallStack, MonadDB m, FromRow row)
  => (row -> m r)
  -> m ()
mapDB_ :: forall (m :: * -> *) row r.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> m r) -> m ()
mapDB_ row -> m r
f =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    m (Maybe (QueryResult row))
forall row. FromRow row => m (Maybe (QueryResult row))
forall (m :: * -> *) row.
(MonadDB m, FromRow row) =>
m (Maybe (QueryResult row))
getQueryResult
      m (Maybe (QueryResult row))
-> (Maybe (QueryResult row) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m ()
-> (QueryResult row -> m ()) -> Maybe (QueryResult row) -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Bool -> (() -> row -> m ()) -> () -> QueryResult row -> m ()
forall (m :: * -> *) acc t.
(HasCallStack, Monad m) =>
Bool -> (acc -> t -> m acc) -> acc -> QueryResult t -> m acc
foldlImpl Bool
False (\() row
row -> m r -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (row -> m r
f row
row)) ())

----------------------------------------

-- | Specialization of 'foldrDB' that fetches a list of rows.
fetchMany :: (HasCallStack, MonadDB m, FromRow row) => (row -> t) -> m [t]
fetchMany :: forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany row -> t
f = (HasCallStack => m [t]) -> m [t]
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m [t]) -> m [t])
-> (HasCallStack => m [t]) -> m [t]
forall a b. (a -> b) -> a -> b
$ (row -> [t] -> m [t]) -> [t] -> m [t]
forall (m :: * -> *) row acc.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> acc -> m acc) -> acc -> m acc
foldrDB (\row
row [t]
acc -> [t] -> m [t]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([t] -> m [t]) -> [t] -> m [t]
forall a b. (a -> b) -> a -> b
$ row -> t
f row
row t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
acc) []

-- | Specialization of 'foldlDB' that fetches one or zero rows. If
-- more rows are delivered, 'AffectedRowsMismatch' exception is thrown.
fetchMaybe
  :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row)
  => (row -> t)
  -> m (Maybe t)
fetchMaybe :: forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe row -> t
f = (HasCallStack => m (Maybe t)) -> m (Maybe t)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m (Maybe t)) -> m (Maybe t))
-> (HasCallStack => m (Maybe t)) -> m (Maybe t)
forall a b. (a -> b) -> a -> b
$ do
  m (Maybe (QueryResult row))
forall row. FromRow row => m (Maybe (QueryResult row))
forall (m :: * -> *) row.
(MonadDB m, FromRow row) =>
m (Maybe (QueryResult row))
getQueryResult m (Maybe (QueryResult row))
-> (Maybe (QueryResult row) -> m (Maybe t)) -> m (Maybe t)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (QueryResult row)
Nothing -> Maybe t -> m (Maybe t)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe t
forall a. Maybe a
Nothing
    Just QueryResult row
qr -> (Maybe t, QueryResult t) -> Maybe t
forall a b. (a, b) -> a
fst ((Maybe t, QueryResult t) -> Maybe t)
-> m (Maybe t, QueryResult t) -> m (Maybe t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe t, QueryResult t) -> row -> m (Maybe t, QueryResult t))
-> (Maybe t, QueryResult t) -> m (Maybe t, QueryResult t)
forall (m :: * -> *) row acc.
(HasCallStack, MonadDB m, FromRow row) =>
(acc -> row -> m acc) -> acc -> m acc
foldlDB (Maybe t, QueryResult t) -> row -> m (Maybe t, QueryResult t)
go (Maybe t
forall a. Maybe a
Nothing, row -> t
f (row -> t) -> QueryResult row -> QueryResult t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryResult row
qr)
  where
    go :: (Maybe t, QueryResult t) -> row -> m (Maybe t, QueryResult t)
go (Maybe t
Nothing, QueryResult t
qr) row
row = (Maybe t, QueryResult t) -> m (Maybe t, QueryResult t)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> Maybe t
forall a. a -> Maybe a
Just (t -> Maybe t) -> t -> Maybe t
forall a b. (a -> b) -> a -> b
$ row -> t
f row
row, QueryResult t
qr)
    go (Just t
_, QueryResult t
qr) row
_ =
      AffectedRowsMismatch -> m (Maybe t, QueryResult t)
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadDB m, MonadThrow m) =>
e -> m a
throwDB
        AffectedRowsMismatch
          { rowsExpected :: [(Int, Int)]
rowsExpected = [(Int
0, Int
1)]
          , rowsDelivered :: Int
rowsDelivered = QueryResult t -> Int
forall t. QueryResult t -> Int
ntuples QueryResult t
qr
          }

-- | Specialization of 'fetchMaybe' that fetches exactly one row. If
-- no row is delivered, 'AffectedRowsMismatch' exception is thrown.
fetchOne :: (HasCallStack, MonadDB m, MonadThrow m, FromRow row) => (row -> t) -> m t
fetchOne :: forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m t
fetchOne row -> t
f = (HasCallStack => m t) -> m t
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m t) -> m t) -> (HasCallStack => m t) -> m t
forall a b. (a -> b) -> a -> b
$ do
  Maybe t
mt <- (row -> t) -> m (Maybe t)
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, MonadThrow m, FromRow row) =>
(row -> t) -> m (Maybe t)
fetchMaybe row -> t
f
  case Maybe t
mt of
    Just t
t -> t -> m t
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t
    Maybe t
Nothing ->
      AffectedRowsMismatch -> m t
forall e (m :: * -> *) a.
(HasCallStack, Exception e, MonadDB m, MonadThrow m) =>
e -> m a
throwDB
        AffectedRowsMismatch
          { rowsExpected :: [(Int, Int)]
rowsExpected = [(Int
1, Int
1)]
          , rowsDelivered :: Int
rowsDelivered = Int
0
          }