{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE StrictData            #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# LANGUAGE NamedFieldPuns        #-}

module Control.Monad.Freer.Extras.Beam.Effects where

import Cardano.BM.Trace (Trace)
import Control.Monad (guard)
import Control.Monad.Freer (Eff, Member, send, type (~>))
import Control.Monad.Freer.Extras.Beam.Common (BeamLog (..), BeamThreadingArg, BeamableDb)
import Control.Monad.Freer.Extras.Pagination (Page (..), PageQuery (..), PageSize (..))
import Data.Foldable (traverse_)
import Data.Kind (Type)
import Data.List.NonEmpty qualified as L
import Data.Maybe (isJust, listToMaybe)
import Database.Beam (Beamable, DatabaseEntity, FromBackendRow, HasQBuilder, Identity, MonadBeam, Q, QExpr, SqlDelete,
                      SqlInsert, SqlSelect, SqlUpdate, TableEntity, asc_, filter_, insertValues, limit_, orderBy_,
                      runDelete, runInsert, runSelectReturningList, runSelectReturningOne, runUpdate, select, val_,
                      (>.))
import Database.Beam.Backend.SQL (BeamSqlBackend, BeamSqlBackendSyntax, HasSqlValueSyntax,
                                  IsSql92ExpressionSyntax (Sql92ExpressionValueSyntax),
                                  IsSql92SelectSyntax (Sql92SelectSelectTableSyntax),
                                  IsSql92SelectTableSyntax (Sql92SelectTableExpressionSyntax),
                                  IsSql92Syntax (Sql92SelectSyntax))
import Database.Beam.Backend.SQL.BeamExtensions (BeamHasInsertOnConflict (anyConflict, insertOnConflict, onConflictDoNothing))

type Synt dbt = (Sql92ExpressionValueSyntax
                  (Sql92SelectTableExpressionSyntax
                    (Sql92SelectSelectTableSyntax
                        (Sql92SelectSyntax
                          (BeamSqlBackendSyntax dbt)))))

data BeamEffect dbt r where
  -- Workaround for "too many SQL variables" sqlite error. Provide a
  -- batch size so that we avoid the error. The maximum is 999.
  AddRowsInBatches
    :: BeamableDb dbt table
    => Int
    -> DatabaseEntity dbt db (TableEntity table)
    -> [table Identity]
    -> BeamEffect dbt ()

  AddRows
    :: BeamableDb dbt table
    => SqlInsert dbt table
    -> BeamEffect dbt ()

  UpdateRows
    :: Beamable table
    => SqlUpdate dbt table
    -> BeamEffect dbt ()

  DeleteRows
    :: Beamable table
    => SqlDelete dbt table
    -> BeamEffect dbt ()

  SelectList
    :: FromBackendRow dbt a
    => SqlSelect dbt a
    -> BeamEffect dbt [a]

  -- | Select using Seek Pagination.
  SelectPage ::
      ( FromBackendRow dbt a
      , HasSqlValueSyntax (Synt dbt) a
      , HasQBuilder dbt
      )
      => PageQuery a
      -> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
      -> BeamEffect dbt (Page a)

  SelectOne
    :: FromBackendRow dbt a
    => SqlSelect dbt a
    -> BeamEffect dbt(Maybe a)

  Combined
    :: [BeamEffect dbt ()]
    -> BeamEffect dbt ()

instance Monoid (BeamEffect dbt ()) where
  mempty :: BeamEffect dbt ()
mempty = [BeamEffect dbt ()] -> BeamEffect dbt ()
forall dbt. [BeamEffect dbt ()] -> BeamEffect dbt ()
Combined []

instance Semigroup (BeamEffect dbt ()) where
  BeamEffect dbt ()
a <> :: BeamEffect dbt () -> BeamEffect dbt () -> BeamEffect dbt ()
<> BeamEffect dbt ()
b = [BeamEffect dbt ()] -> BeamEffect dbt ()
forall dbt. [BeamEffect dbt ()] -> BeamEffect dbt ()
Combined [BeamEffect dbt ()
a, BeamEffect dbt ()
b]

addRowsInBatches ::
    forall dbt table db effs.
    (BeamableDb dbt table, Member (BeamEffect dbt) effs)
    => Int
    -> DatabaseEntity dbt db (TableEntity table)
    -> [table Identity]
    -> Eff effs ()
addRowsInBatches :: Int
-> DatabaseEntity dbt db (TableEntity table)
-> [table Identity]
-> Eff effs ()
addRowsInBatches Int
rows DatabaseEntity dbt db (TableEntity table)
dbent [table Identity]
tables
    = BeamEffect dbt () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (Int
-> DatabaseEntity dbt db (TableEntity table)
-> [table Identity]
-> BeamEffect dbt ()
forall dbt (table :: (* -> *) -> *) (db :: (* -> *) -> *).
BeamableDb dbt table =>
Int
-> DatabaseEntity dbt db (TableEntity table)
-> [table Identity]
-> BeamEffect dbt ()
AddRowsInBatches Int
rows DatabaseEntity dbt db (TableEntity table)
dbent [table Identity]
tables)

addRows ::
    forall dbt table effs.
    (BeamableDb dbt table, Member (BeamEffect dbt) effs)
    => SqlInsert dbt table
    -> Eff effs ()
addRows :: SqlInsert dbt table -> Eff effs ()
addRows SqlInsert dbt table
op
    = BeamEffect dbt () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (SqlInsert dbt table -> BeamEffect dbt ()
forall dbt (table :: (* -> *) -> *).
BeamableDb dbt table =>
SqlInsert dbt table -> BeamEffect dbt ()
AddRows SqlInsert dbt table
op)


updateRows ::
    forall dbt table effs.
    (Beamable table, Member (BeamEffect dbt) effs)
    => SqlUpdate dbt table
    -> Eff effs ()
updateRows :: SqlUpdate dbt table -> Eff effs ()
updateRows SqlUpdate dbt table
op
    = BeamEffect dbt () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (SqlUpdate dbt table -> BeamEffect dbt ()
forall (table :: (* -> *) -> *) dbt.
Beamable table =>
SqlUpdate dbt table -> BeamEffect dbt ()
UpdateRows SqlUpdate dbt table
op)


deleteRows ::
    forall dbt table effs.
    (Beamable table, Member (BeamEffect dbt) effs)
    => SqlDelete dbt table
    -> Eff effs ()
deleteRows :: SqlDelete dbt table -> Eff effs ()
deleteRows SqlDelete dbt table
op
    = BeamEffect dbt () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (SqlDelete dbt table -> BeamEffect dbt ()
forall (table :: (* -> *) -> *) dbt.
Beamable table =>
SqlDelete dbt table -> BeamEffect dbt ()
DeleteRows SqlDelete dbt table
op)


selectList ::
    forall dbt a effs.
    (FromBackendRow dbt a, Member (BeamEffect dbt) effs)
    => SqlSelect dbt a
    -> Eff effs [a]
selectList :: SqlSelect dbt a -> Eff effs [a]
selectList SqlSelect dbt a
op
    = BeamEffect dbt [a] -> Eff effs [a]
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (SqlSelect dbt a -> BeamEffect dbt [a]
forall dbt a.
FromBackendRow dbt a =>
SqlSelect dbt a -> BeamEffect dbt [a]
SelectList SqlSelect dbt a
op)


selectPage ::
    forall dbt a db effs.
    ( FromBackendRow dbt a
    , HasSqlValueSyntax (Synt dbt) a
    , Member (BeamEffect dbt) effs
    , HasQBuilder dbt
    )
    => PageQuery a
    -> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
    -> Eff effs (Page a)
selectPage :: PageQuery a
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> Eff effs (Page a)
selectPage PageQuery a
pq Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
query
    = BeamEffect dbt (Page a) -> Eff effs (Page a)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (PageQuery a
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> BeamEffect dbt (Page a)
forall dbt a (db :: (* -> *) -> *).
(FromBackendRow dbt a, HasSqlValueSyntax (Synt dbt) a,
 HasQBuilder dbt) =>
PageQuery a
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> BeamEffect dbt (Page a)
SelectPage PageQuery a
pq Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
query)


selectOne ::
    forall dbt a effs.
    (FromBackendRow dbt a, Member (BeamEffect dbt) effs)
    => SqlSelect dbt a
    -> Eff effs (Maybe a)
selectOne :: SqlSelect dbt a -> Eff effs (Maybe a)
selectOne SqlSelect dbt a
op
    = BeamEffect dbt (Maybe a) -> Eff effs (Maybe a)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) (SqlSelect dbt a -> BeamEffect dbt (Maybe a)
forall dbt a.
FromBackendRow dbt a =>
SqlSelect dbt a -> BeamEffect dbt (Maybe a)
SelectOne SqlSelect dbt a
op)


combined ::
    forall dbt effs.
    Member (BeamEffect dbt) effs
    => [(BeamEffect dbt) ()]
    -> Eff effs ()
combined :: [BeamEffect dbt ()] -> Eff effs ()
combined [BeamEffect dbt ()]
ops
    = BeamEffect dbt () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(BeamEffect dbt) ([BeamEffect dbt ()] -> BeamEffect dbt ()
forall dbt. [BeamEffect dbt ()] -> BeamEffect dbt ()
Combined [BeamEffect dbt ()]
ops)


handleBeam ::
  forall dbt (dbM :: Type -> Type) effs.
  ( BeamSqlBackend dbt
  , MonadBeam dbt dbM
  , BeamHasInsertOnConflict dbt
  )
  =>(Trace IO BeamLog -> dbM ~> Eff effs)
  -> Trace IO BeamLog
  -> BeamEffect dbt
  ~> Eff effs
handleBeam :: (Trace IO BeamLog -> dbM ~> Eff effs)
-> Trace IO BeamLog -> BeamEffect dbt ~> Eff effs
handleBeam Trace IO BeamLog -> dbM ~> Eff effs
run Trace IO BeamLog
trace BeamEffect dbt x
eff = Trace IO BeamLog -> dbM ~> Eff effs
run Trace IO BeamLog
trace (dbM x -> Eff effs x) -> dbM x -> Eff effs x
forall a b. (a -> b) -> a -> b
$ BeamEffect dbt x -> dbM x
BeamEffect dbt ~> dbM
execute BeamEffect dbt x
eff
  where
    execute :: BeamEffect dbt ~> dbM
    execute :: BeamEffect dbt x -> dbM x
execute = \case
        AddRowsInBatches Int
_ DatabaseEntity dbt db (TableEntity table)
_ [] -> () -> dbM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        AddRowsInBatches Int
n DatabaseEntity dbt db (TableEntity table)
table (Int -> [table Identity] -> ([table Identity], [table Identity])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n -> ([table Identity]
batch, [table Identity]
rest)) -> do
            forall be (m :: * -> *) (table :: (* -> *) -> *).
(BeamSqlBackend be, MonadBeam be m) =>
SqlInsert be table -> m ()
forall (table :: (* -> *) -> *).
(BeamSqlBackend dbt, MonadBeam dbt dbM) =>
SqlInsert dbt table -> dbM ()
runInsert @dbt @dbM
                (SqlInsert dbt table -> dbM ()) -> SqlInsert dbt table -> dbM ()
forall a b. (a -> b) -> a -> b
$ DatabaseEntity dbt db (TableEntity table)
-> SqlInsertValues dbt (table (QExpr dbt Any))
-> SqlConflictTarget dbt table
-> SqlConflictAction dbt table
-> SqlInsert dbt table
forall be (table :: (* -> *) -> *) (db :: (* -> *) -> *) s.
(BeamHasInsertOnConflict be, Beamable table) =>
DatabaseEntity be db (TableEntity table)
-> SqlInsertValues be (table (QExpr be s))
-> SqlConflictTarget be table
-> SqlConflictAction be table
-> SqlInsert be table
insertOnConflict DatabaseEntity dbt db (TableEntity table)
table ([table Identity] -> SqlInsertValues dbt (table (QExpr dbt Any))
forall be (table :: (* -> *) -> *) s.
(BeamSqlBackend be, Beamable table,
 FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table) =>
[table Identity] -> SqlInsertValues be (table (QExpr be s))
insertValues [table Identity]
batch) SqlConflictTarget dbt table
forall be (table :: (* -> *) -> *).
BeamHasInsertOnConflict be =>
SqlConflictTarget be table
anyConflict SqlConflictAction dbt table
forall be (table :: (* -> *) -> *).
BeamHasInsertOnConflict be =>
SqlConflictAction be table
onConflictDoNothing
            BeamEffect dbt () -> dbM ()
BeamEffect dbt ~> dbM
execute (BeamEffect dbt () -> dbM ()) -> BeamEffect dbt () -> dbM ()
forall a b. (a -> b) -> a -> b
$ Int
-> DatabaseEntity dbt db (TableEntity table)
-> [table Identity]
-> BeamEffect dbt ()
forall dbt (table :: (* -> *) -> *) (db :: (* -> *) -> *).
BeamableDb dbt table =>
Int
-> DatabaseEntity dbt db (TableEntity table)
-> [table Identity]
-> BeamEffect dbt ()
AddRowsInBatches Int
n DatabaseEntity dbt db (TableEntity table)
table [table Identity]
rest
        AddRows    SqlInsert dbt table
q    -> SqlInsert dbt table -> dbM ()
forall be (m :: * -> *) (table :: (* -> *) -> *).
(BeamSqlBackend be, MonadBeam be m) =>
SqlInsert be table -> m ()
runInsert SqlInsert dbt table
q
        UpdateRows SqlUpdate dbt table
q    -> SqlUpdate dbt table -> dbM ()
forall be (m :: * -> *) (tbl :: (* -> *) -> *).
(BeamSqlBackend be, MonadBeam be m) =>
SqlUpdate be tbl -> m ()
runUpdate SqlUpdate dbt table
q
        DeleteRows SqlDelete dbt table
q    -> SqlDelete dbt table -> dbM ()
forall be (m :: * -> *) (table :: (* -> *) -> *).
(BeamSqlBackend be, MonadBeam be m) =>
SqlDelete be table -> m ()
runDelete SqlDelete dbt table
q
        SelectList SqlSelect dbt a
q    -> SqlSelect dbt a -> dbM [a]
forall be (m :: * -> *) a.
(MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
SqlSelect be a -> m [a]
runSelectReturningList SqlSelect dbt a
q
        SelectPage pageQuery :: PageQuery a
pageQuery@PageQuery { pageQuerySize :: forall a. PageQuery a -> PageSize
pageQuerySize = PageSize Natural
ps, Maybe a
pageQueryLastItem :: forall a. PageQuery a -> Maybe a
pageQueryLastItem :: Maybe a
pageQueryLastItem } Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
q -> do
          let ps' :: Integer
ps' = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ps

          -- Fetch the first @PageSize + 1@ elements after the last query
          -- element. The @+1@ allows to us to know if there is a next page
          -- or not.
          [a]
items <- SqlSelect dbt a -> dbM [a]
forall be (m :: * -> *) a.
(MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
SqlSelect be a -> m [a]
runSelectReturningList
                    (SqlSelect dbt a -> dbM [a]) -> SqlSelect dbt a -> dbM [a]
forall a b. (a -> b) -> a -> b
$ Q dbt db QBaseScope (QGenExpr QValueContext dbt QBaseScope a)
-> SqlSelect
     dbt (QExprToIdentity (QGenExpr QValueContext dbt QBaseScope a))
forall be (db :: (* -> *) -> *) res.
(BeamSqlBackend be, HasQBuilder be, Projectible be res) =>
Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res)
select
                    (Q dbt db QBaseScope (QGenExpr QValueContext dbt QBaseScope a)
 -> SqlSelect
      dbt (QExprToIdentity (QGenExpr QValueContext dbt QBaseScope a)))
-> Q dbt db QBaseScope (QGenExpr QValueContext dbt QBaseScope a)
-> SqlSelect
     dbt (QExprToIdentity (QGenExpr QValueContext dbt QBaseScope a))
forall a b. (a -> b) -> a -> b
$ Integer
-> Q dbt
     db
     (QNested QBaseScope)
     (QGenExpr QValueContext dbt (QNested QBaseScope) a)
-> Q dbt
     db
     QBaseScope
     (WithRewrittenThread
        (QNested QBaseScope)
        QBaseScope
        (QGenExpr QValueContext dbt (QNested QBaseScope) a))
forall s a be (db :: (* -> *) -> *).
(Projectible be a, ThreadRewritable (QNested s) a) =>
Integer
-> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
limit_ (Integer
ps' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
                    (Q dbt
   db
   (QNested QBaseScope)
   (QGenExpr QValueContext dbt (QNested QBaseScope) a)
 -> Q dbt
      db
      QBaseScope
      (WithRewrittenThread
         (QNested QBaseScope)
         QBaseScope
         (QGenExpr QValueContext dbt (QNested QBaseScope) a)))
-> Q dbt
     db
     (QNested QBaseScope)
     (QGenExpr QValueContext dbt (QNested QBaseScope) a)
-> Q dbt
     db
     QBaseScope
     (WithRewrittenThread
        (QNested QBaseScope)
        QBaseScope
        (QGenExpr QValueContext dbt (QNested QBaseScope) a))
forall a b. (a -> b) -> a -> b
$ (QExpr dbt BeamThreadingArg a -> QOrd dbt BeamThreadingArg a)
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> Q dbt
     db
     (QNested QBaseScope)
     (WithRewrittenThread
        BeamThreadingArg
        (QNested QBaseScope)
        (QExpr dbt BeamThreadingArg a))
forall s a ordering be (db :: (* -> *) -> *).
(Projectible be a, SqlOrderable be ordering,
 ThreadRewritable (QNested s) a) =>
(a -> ordering)
-> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
orderBy_ QExpr dbt BeamThreadingArg a -> QOrd dbt BeamThreadingArg a
forall be s a. BeamSqlBackend be => QExpr be s a -> QOrd be s a
asc_
                    (Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
 -> Q dbt
      db
      (QNested QBaseScope)
      (WithRewrittenThread
         BeamThreadingArg
         (QNested QBaseScope)
         (QExpr dbt BeamThreadingArg a)))
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> Q dbt
     db
     (QNested QBaseScope)
     (WithRewrittenThread
        BeamThreadingArg
        (QNested QBaseScope)
        (QExpr dbt BeamThreadingArg a))
forall a b. (a -> b) -> a -> b
$ (QExpr dbt BeamThreadingArg a -> QExpr dbt BeamThreadingArg Bool)
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
-> Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
forall r be (db :: (* -> *) -> *) s.
BeamSqlBackend be =>
(r -> QExpr be s Bool) -> Q be db s r -> Q be db s r
filter_ (\QExpr dbt BeamThreadingArg a
qExpr -> QExpr dbt BeamThreadingArg Bool
-> (a -> QExpr dbt BeamThreadingArg Bool)
-> Maybe a
-> QExpr dbt BeamThreadingArg Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HaskellLiteralForQExpr (QExpr dbt BeamThreadingArg Bool)
-> QExpr dbt BeamThreadingArg Bool
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ Bool
HaskellLiteralForQExpr (QExpr dbt BeamThreadingArg Bool)
True)
                                              (\a
lastItem -> QExpr dbt BeamThreadingArg a
qExpr QExpr dbt BeamThreadingArg a
-> QExpr dbt BeamThreadingArg a -> QExpr dbt BeamThreadingArg Bool
forall (expr :: * -> *) e. SqlOrd expr e => e -> e -> expr Bool
>. HaskellLiteralForQExpr (QExpr dbt BeamThreadingArg a)
-> QExpr dbt BeamThreadingArg a
forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ a
HaskellLiteralForQExpr (QExpr dbt BeamThreadingArg a)
lastItem)
                                              Maybe a
pageQueryLastItem
                              ) Q dbt db BeamThreadingArg (QExpr dbt BeamThreadingArg a)
q

          let lastItemM :: Maybe a
lastItemM = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
items Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ps)
                       Maybe () -> Maybe (NonEmpty a) -> Maybe (NonEmpty a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
L.nonEmpty [a]
items
                       Maybe (NonEmpty a) -> (NonEmpty a -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> (NonEmpty a -> [a]) -> NonEmpty a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
L.tail (NonEmpty a -> [a])
-> (NonEmpty a -> NonEmpty a) -> NonEmpty a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
L.reverse
          let newPageQuery :: Maybe (PageQuery a)
newPageQuery = (a -> PageQuery a) -> Maybe a -> Maybe (PageQuery a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PageSize -> Maybe a -> PageQuery a
forall a. PageSize -> Maybe a -> PageQuery a
PageQuery (Natural -> PageSize
PageSize Natural
ps) (Maybe a -> PageQuery a) -> (a -> Maybe a) -> a -> PageQuery a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) Maybe a
lastItemM

          Page a -> dbM (Page a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Page a -> dbM (Page a)) -> Page a -> dbM (Page a)
forall a b. (a -> b) -> a -> b
$
            Page :: forall a. PageQuery a -> Maybe (PageQuery a) -> [a] -> Page a
Page
                { currentPageQuery :: PageQuery a
currentPageQuery = PageQuery a
pageQuery
                , nextPageQuery :: Maybe (PageQuery a)
nextPageQuery = Maybe (PageQuery a)
newPageQuery
                , pageItems :: [a]
pageItems = if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
lastItemM then [a] -> [a]
forall a. [a] -> [a]
init [a]
items else [a]
items
                }
        SelectOne  SqlSelect dbt a
q    -> SqlSelect dbt a -> dbM (Maybe a)
forall be (m :: * -> *) a.
(MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
SqlSelect be a -> m (Maybe a)
runSelectReturningOne  SqlSelect dbt a
q
        Combined   [BeamEffect dbt ()]
effs -> (BeamEffect dbt () -> dbM ()) -> [BeamEffect dbt ()] -> dbM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ BeamEffect dbt () -> dbM ()
BeamEffect dbt ~> dbM
execute [BeamEffect dbt ()]
effs