{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Thanks to our dynamic 'Opaleye' effect, we can write an alternative interpreter which,
as well as performing SQL operations as before, will also keep a tally of the number of
SQL operations (SELECTs, INSERTs etc) that have been performed. This is really useful for debugging.

The intended use-case is a sort of benchmark that runs several Opaleye operations for different
"sizes", counts the SQL operations, and prints the tallies to the console. This lets us detect if
some datbase operations are ineffecient.

For example, suppose our model has users with @UserId@s; those users an have multiple @Transaction@s, which
are composed of multiple @SubTransaction@s etc.
To insert a group of new users, we would need to insert the users, insert the transactions, and insert the subtransactions.
Ideally, the number of @INSERT@s should not depend on the number of @User@s or the number or size of their @Transactions@.
We would expect the number of SELECTs to remain basically constant (O(1)), while the execution time might grow linearly (O(u * t * s)).

A very naive implementation might be:

@
insertUsersNaive :: ('Opaleye' :> es) => [User] -> Eff es ()
insertUsersNaive users = for_ users $ \user -> do
  insertUserFlat user
  for (transactions user) $ \transaction -> do
    insertTransactionFlat transaction
    for (subTransactions transaction) $ \subTransaction -> do
      insertSubTransactionFlat subTransaction
@

However, if we ran a "benchmark" that looked something like this:

@
u1, u5, u10, u50 :: [User]
u1 = [User {transactions = [Transaction [SubTransaction]]}] -- one user, one transaction, one sub-transaction
u5 = ...  -- five users, each with five transactions, each with 5 sub-transactions

benchmark :: ('Opaleye' :> es, State SQLOperationCounts :> es, IOE :> es) => Eff es ()
benchmark = for_ [(1, u1), (5, u5), (10, u10), (50, u50)] $ \(n, users) -> do
  (counts, ()) <- withCounts $ insertUsersNaive users
  liftIO . putStrLn $ "Counts at n=" <> show n <> ": " <> 'renderCountsBrief' counts

main :: IO ()
main = runEff . 'Conn.runWithConnectInfo' connInfo . evalState @SQLOperationCounts mempty . runOpaleyeWithConnectionCounting $ benchmark
  where
    connInfo = ...
@

We will probably see something like:

@
Counts at n=1: INSERT: 3
Counts at n=5: INSERT: 155
Counts at n=10: INSERT: 1110
Counts at n=50: INSERT: 127550
@

This is obviously going to have a severe performance impact. Rearranging our implementatino of @insertUsers@:

@
insertUsersBetter :: ('Opaleye' :> es) => [User] -> Eff es ()
insertUsersBetter users = do
  let transactions_ = concatMap transactions users
      subTransactions_ = concatMap subTransactions transactions_
  insertUsersFlat users
  insertTransactionsFlat transactions_
  insertSubTransactionsFlat subTransactions_
@

As long as @insertTransactionsFlat@ etc are smart enough to only do one 'runInsert', then we should now get:

@
Counts at n=1: INSERT: 3
Counts at n=5: INSERT: 3
Counts at n=10: INSERT: 3
Counts at n=50: INSERT: 3
@

Note that we used 'renderCountsBrief' for simplicity. If we wanted to debug in more detail, we could have used
'renderCounts' instead:

@
Counts at n=1: INSERT: user: 1
                       transaction: 1
                       sub_transaction: 1
Counts at n=5: INSERT: user: 5
                       transaction: 25
                       sub_transaction: 125
Counts at n=10: INSERT: user: 10
                        transaction: 100
                        sub_transaction: 1000
Counts at n=50: INSERT: user: 50
                        transaction: 2500
                        sub_transaction: 125000
@
-}
module Effectful.Opaleye.Count
  ( -- * Counting SQL operations
    SQLOperationCounts (..)
  , opaleyeAddCounting
  , withCounts

    -- * Pretty-printing
  , printCounts
  , printCountsBrief
  , renderCounts
  , renderCountsBrief
  , prettyCounts
  , prettyCountsBrief
  )
where

import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.Text as T
import Database.PostgreSQL.Simple.Types (QualifiedIdentifier (..))
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Opaleye.Effect
import Effectful.State.Static.Shared
import GHC.Generics
import Numeric.Natural
import qualified Opaleye as O
import qualified Opaleye.Internal.PrimQuery as O (TableIdentifier (..))
import qualified Opaleye.Internal.Table as O
import qualified Text.PrettyPrint as P
import qualified Text.PrettyPrint.HughesPJClass as P
#if !MIN_VERSION_effectful_core(2,5,1)
import Control.Monad (when)
import Effectful.Dispatch.Static
import Effectful.Internal.Env
import Effectful.Internal.Monad
import GHC.Stack
#endif

------------------------------------------------------------
-- Tallying SQL operations

{- | This tracks the number of SQL operations that have been performed in the
'Opaleye' effect, along with which table it was performed on (where possible).

@INSERT@, @DELETE@ and @UPDATE@ operations act on one table only, so we can tally the number
of each that are performed on each table (indexed by a t'QualifiedIdentifier').
@SELECT@ operations can act on multiple tables, so we just track the total number of selects.

If required, t'SQLOperationCounts' can be constructed using 'Monoid' and combined using 'Semigroup'.

We use non-negative 'Natural's as a tally since a negative number of operations makes no sense.
-}
data SQLOperationCounts = SQLOperationCounts
  { SQLOperationCounts -> Natural
sqlSelects :: Natural
  , SQLOperationCounts -> Map QualifiedIdentifier Natural
sqlInserts :: Map QualifiedIdentifier Natural
  , SQLOperationCounts -> Map QualifiedIdentifier Natural
sqlDeletes :: Map QualifiedIdentifier Natural
  , SQLOperationCounts -> Map QualifiedIdentifier Natural
sqlUpdates :: Map QualifiedIdentifier Natural
  }
  deriving (Int -> SQLOperationCounts -> ShowS
[SQLOperationCounts] -> ShowS
SQLOperationCounts -> String
(Int -> SQLOperationCounts -> ShowS)
-> (SQLOperationCounts -> String)
-> ([SQLOperationCounts] -> ShowS)
-> Show SQLOperationCounts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SQLOperationCounts -> ShowS
showsPrec :: Int -> SQLOperationCounts -> ShowS
$cshow :: SQLOperationCounts -> String
show :: SQLOperationCounts -> String
$cshowList :: [SQLOperationCounts] -> ShowS
showList :: [SQLOperationCounts] -> ShowS
Show, SQLOperationCounts -> SQLOperationCounts -> Bool
(SQLOperationCounts -> SQLOperationCounts -> Bool)
-> (SQLOperationCounts -> SQLOperationCounts -> Bool)
-> Eq SQLOperationCounts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SQLOperationCounts -> SQLOperationCounts -> Bool
== :: SQLOperationCounts -> SQLOperationCounts -> Bool
$c/= :: SQLOperationCounts -> SQLOperationCounts -> Bool
/= :: SQLOperationCounts -> SQLOperationCounts -> Bool
Eq, (forall x. SQLOperationCounts -> Rep SQLOperationCounts x)
-> (forall x. Rep SQLOperationCounts x -> SQLOperationCounts)
-> Generic SQLOperationCounts
forall x. Rep SQLOperationCounts x -> SQLOperationCounts
forall x. SQLOperationCounts -> Rep SQLOperationCounts x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SQLOperationCounts -> Rep SQLOperationCounts x
from :: forall x. SQLOperationCounts -> Rep SQLOperationCounts x
$cto :: forall x. Rep SQLOperationCounts x -> SQLOperationCounts
to :: forall x. Rep SQLOperationCounts x -> SQLOperationCounts
Generic)

instance Semigroup SQLOperationCounts where
  SQLOperationCounts Natural
s1 Map QualifiedIdentifier Natural
i1 Map QualifiedIdentifier Natural
d1 Map QualifiedIdentifier Natural
u1 <> :: SQLOperationCounts -> SQLOperationCounts -> SQLOperationCounts
<> SQLOperationCounts Natural
s2 Map QualifiedIdentifier Natural
i2 Map QualifiedIdentifier Natural
d2 Map QualifiedIdentifier Natural
u2 =
    Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> SQLOperationCounts
SQLOperationCounts
      (Natural
s1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
s2)
      (Map QualifiedIdentifier Natural
i1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
`addNatMaps` Map QualifiedIdentifier Natural
i2)
      (Map QualifiedIdentifier Natural
d1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
`addNatMaps` Map QualifiedIdentifier Natural
d2)
      (Map QualifiedIdentifier Natural
u1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
`addNatMaps` Map QualifiedIdentifier Natural
u2)
    where
      addNatMaps :: Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
addNatMaps = (Natural -> Natural -> Natural)
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+)

instance Monoid SQLOperationCounts where
  mempty :: SQLOperationCounts
mempty = Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> SQLOperationCounts
SQLOperationCounts Natural
0 Map QualifiedIdentifier Natural
forall a. Monoid a => a
mempty Map QualifiedIdentifier Natural
forall a. Monoid a => a
mempty Map QualifiedIdentifier Natural
forall a. Monoid a => a
mempty

{- | Add counting of SQL operations to the interpreter of an 'Opaleye' effect.
Note that the effect itself is not actually interpreted. We do this using 'passthrough',
which lets us perform some actions based on the 'Opaleye' constructor and then pass them
through to the upstream handler (e.g. 'Effectful.Opaleye.runOpaleyeWithConnection' or
'Effectful.Opaleye.runOpaleyeConnection'). See 'Effectful.Opaleye.runOpaleyeConnectionCounting'
and 'Effectful.Opaleye.runOpaleyeWithConnectionCounting' for interpreters that do both.

Note: this function should only be used once, otherwise the operations will be tallied
more than once. Unless you're sure, it's probably better to use
'Effectful.Opaleye.runOpaleyeConnectionCounting' or
'Effectful.Opaleye.runOpaleyeWithConnectionCounting'.
-}
opaleyeAddCounting ::
  forall a es.
  (HasCallStack, State SQLOperationCounts :> es) =>
  Eff (Opaleye : es) a ->
  Eff (Opaleye : es) a
opaleyeAddCounting :: forall a (es :: [Effect]).
(HasCallStack, State SQLOperationCounts :> es) =>
Eff (Opaleye : es) a -> Eff (Opaleye : es) a
opaleyeAddCounting = EffectHandler Opaleye (Opaleye : es)
-> Eff (Opaleye : es) a -> Eff (Opaleye : es) a
forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic, e :> es) =>
EffectHandler e es -> Eff es a -> Eff es a
interpose (EffectHandler Opaleye (Opaleye : es)
 -> Eff (Opaleye : es) a -> Eff (Opaleye : es) a)
-> EffectHandler Opaleye (Opaleye : es)
-> Eff (Opaleye : es) a
-> Eff (Opaleye : es) a
forall a b. (a -> b) -> a -> b
$ \LocalEnv localEs (Opaleye : es)
env Opaleye (Eff localEs) a
op -> do
  Opaleye (Eff localEs) a -> Eff (Opaleye : es) ()
forall b (localEs :: [Effect]).
Opaleye (Eff localEs) b -> Eff (Opaleye : es) ()
incrementOp Opaleye (Eff localEs) a
op
  LocalEnv localEs (Opaleye : es)
-> Opaleye (Eff localEs) a -> Eff (Opaleye : es) a
forall (e :: Effect) (es :: [Effect]) (localEs :: [Effect])
       (handlerEs :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es, e :> localEs) =>
LocalEnv localEs handlerEs -> e (Eff localEs) a -> Eff es a
passthrough LocalEnv localEs (Opaleye : es)
env Opaleye (Eff localEs) a
op
  where
    incrementOp :: forall b localEs. Opaleye (Eff localEs) b -> Eff (Opaleye : es) ()
    incrementOp :: forall b (localEs :: [Effect]).
Opaleye (Eff localEs) b -> Eff (Opaleye : es) ()
incrementOp = \case
      RunSelectExplicit {} -> Eff (Opaleye : es) ()
incrementSelect
      RunSelectFoldExplicit {} -> Eff (Opaleye : es) ()
incrementSelect
      RunInsert Insert b
ins -> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall {es :: [Effect]}.
(State SQLOperationCounts :> es) =>
QualifiedIdentifier -> Eff es ()
incrementInsert (QualifiedIdentifier -> Eff (Opaleye : es) ())
-> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall a b. (a -> b) -> a -> b
$ Insert b -> QualifiedIdentifier
forall haskells. Insert haskells -> QualifiedIdentifier
insertTableName Insert b
ins
      RunDelete Delete b
del -> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall {es :: [Effect]}.
(State SQLOperationCounts :> es) =>
QualifiedIdentifier -> Eff es ()
incrementDelete (QualifiedIdentifier -> Eff (Opaleye : es) ())
-> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall a b. (a -> b) -> a -> b
$ Delete b -> QualifiedIdentifier
forall haskells. Delete haskells -> QualifiedIdentifier
deleteTableName Delete b
del
      RunUpdate Update b
upd -> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall {es :: [Effect]}.
(State SQLOperationCounts :> es) =>
QualifiedIdentifier -> Eff es ()
incrementUpdate (QualifiedIdentifier -> Eff (Opaleye : es) ())
-> QualifiedIdentifier -> Eff (Opaleye : es) ()
forall a b. (a -> b) -> a -> b
$ Update b -> QualifiedIdentifier
forall haskells. Update haskells -> QualifiedIdentifier
updateTableName Update b
upd

    incrementMap :: QualifiedIdentifier -> Map QualifiedIdentifier Natural -> Map QualifiedIdentifier Natural
    incrementMap :: QualifiedIdentifier
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
incrementMap = (Maybe Natural -> Maybe Natural)
-> QualifiedIdentifier
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural)
-> (Maybe Natural -> Natural) -> Maybe Natural -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> (Natural -> Natural) -> Maybe Natural -> Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Natural
1 Natural -> Natural
forall a. Enum a => a -> a
succ)

    incrementSelect :: Eff (Opaleye : es) ()
incrementSelect = (SQLOperationCounts -> SQLOperationCounts) -> Eff (Opaleye : es) ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((SQLOperationCounts -> SQLOperationCounts)
 -> Eff (Opaleye : es) ())
-> (SQLOperationCounts -> SQLOperationCounts)
-> Eff (Opaleye : es) ()
forall a b. (a -> b) -> a -> b
$ \SQLOperationCounts
counts ->
      SQLOperationCounts
counts {sqlSelects = succ $ sqlSelects counts}
    incrementInsert :: QualifiedIdentifier -> Eff es ()
incrementInsert QualifiedIdentifier
name = (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((SQLOperationCounts -> SQLOperationCounts) -> Eff es ())
-> (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \SQLOperationCounts
counts ->
      SQLOperationCounts
counts {sqlInserts = incrementMap name $ sqlInserts counts}
    incrementUpdate :: QualifiedIdentifier -> Eff es ()
incrementUpdate QualifiedIdentifier
name = (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((SQLOperationCounts -> SQLOperationCounts) -> Eff es ())
-> (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \SQLOperationCounts
counts ->
      SQLOperationCounts
counts {sqlUpdates = incrementMap name $ sqlUpdates counts}
    incrementDelete :: QualifiedIdentifier -> Eff es ()
incrementDelete QualifiedIdentifier
name = (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall s (es :: [Effect]). (State s :> es) => (s -> s) -> Eff es ()
modify ((SQLOperationCounts -> SQLOperationCounts) -> Eff es ())
-> (SQLOperationCounts -> SQLOperationCounts) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \SQLOperationCounts
counts ->
      SQLOperationCounts
counts {sqlDeletes = incrementMap name $ sqlDeletes counts}

-- | This allows us to count the number of SQL operations over the course of a sub-operation.
withCounts ::
  (State SQLOperationCounts :> es) =>
  Eff es a ->
  Eff es (SQLOperationCounts, a)
withCounts :: forall (es :: [Effect]) a.
(State SQLOperationCounts :> es) =>
Eff es a -> Eff es (SQLOperationCounts, a)
withCounts Eff es a
eff = do
  SQLOperationCounts
countsBefore <- Eff es SQLOperationCounts
forall s (es :: [Effect]). (State s :> es) => Eff es s
get
  a
res <- Eff es a
eff
  SQLOperationCounts
countsAfter <- Eff es SQLOperationCounts
forall s (es :: [Effect]). (State s :> es) => Eff es s
get
  (SQLOperationCounts, a) -> Eff es (SQLOperationCounts, a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SQLOperationCounts
countsAfter SQLOperationCounts -> SQLOperationCounts -> SQLOperationCounts
`subtractCounts` SQLOperationCounts
countsBefore, a
res)

subtractNat :: Natural -> Natural -> Natural
Natural
a subtractNat :: Natural -> Natural -> Natural
`subtractNat` Natural
b = if Natural
a Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
b then Natural
a Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
b else Natural
0

subtractNatMaps :: (Ord k) => Map k Natural -> Map k Natural -> Map k Natural
subtractNatMaps :: forall k. Ord k => Map k Natural -> Map k Natural -> Map k Natural
subtractNatMaps Map k Natural
c1 Map k Natural
c2 =
  let f :: k -> Natural -> Map k Natural -> Map k Natural
f k
op Natural
count = (Natural -> Natural) -> k -> Map k Natural -> Map k Natural
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Natural -> Natural -> Natural
`subtractNat` Natural
count) k
op
  in  (k -> Natural -> Map k Natural -> Map k Natural)
-> Map k Natural -> Map k Natural -> Map k Natural
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey k -> Natural -> Map k Natural -> Map k Natural
forall {k}. Ord k => k -> Natural -> Map k Natural -> Map k Natural
f Map k Natural
c1 Map k Natural
c2

subtractCounts :: SQLOperationCounts -> SQLOperationCounts -> SQLOperationCounts
subtractCounts :: SQLOperationCounts -> SQLOperationCounts -> SQLOperationCounts
subtractCounts (SQLOperationCounts Natural
s1 Map QualifiedIdentifier Natural
i1 Map QualifiedIdentifier Natural
d1 Map QualifiedIdentifier Natural
u1) (SQLOperationCounts Natural
s2 Map QualifiedIdentifier Natural
i2 Map QualifiedIdentifier Natural
d2 Map QualifiedIdentifier Natural
u2) =
  Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> SQLOperationCounts
SQLOperationCounts
    (Natural
s1 Natural -> Natural -> Natural
`subtractNat` Natural
s2)
    (Map QualifiedIdentifier Natural
i1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
forall k. Ord k => Map k Natural -> Map k Natural -> Map k Natural
`subtractNatMaps` Map QualifiedIdentifier Natural
i2)
    (Map QualifiedIdentifier Natural
d1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
forall k. Ord k => Map k Natural -> Map k Natural -> Map k Natural
`subtractNatMaps` Map QualifiedIdentifier Natural
d2)
    (Map QualifiedIdentifier Natural
u1 Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
-> Map QualifiedIdentifier Natural
forall k. Ord k => Map k Natural -> Map k Natural -> Map k Natural
`subtractNatMaps` Map QualifiedIdentifier Natural
u2)

#if !MIN_VERSION_effectful_core(2,5,1)
-- passthrough was only added in effectful-core-2.5.1, so if we don't have access to a version
-- after that then we have to replicate it here
passthrough ::
  (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs) =>
  LocalEnv localEs handlerEs ->
  e (Eff localEs) a ->
  Eff es a
passthrough :: forall (e :: Effect) (es :: [Effect]) (localEs :: [Effect])
       (handlerEs :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic, e :> es, e :> localEs) =>
LocalEnv localEs handlerEs -> e (Eff localEs) a -> Eff es a
passthrough (LocalEnv Env localEs
les) e (Eff localEs) a
op = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Handler Env handlerEs
handlerEs EffectHandler e handlerEs
handler <- Env es -> IO (EffectRep (DispatchOf e) e)
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env localEs -> IORef' Storage
forall (es :: [Effect]). Env es -> IORef' Storage
envStorage Env localEs
les IORef' Storage -> IORef' Storage -> Bool
forall a. Eq a => a -> a -> Bool
/= Env handlerEs -> IORef' Storage
forall (es :: [Effect]). Env es -> IORef' Storage
envStorage Env handlerEs
handlerEs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. HasCallStack => String -> a
error String
"les and handlerEs point to different Storages"
  Eff handlerEs a -> Env handlerEs -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff ((HasCallStack =>
 LocalEnv localEs handlerEs -> e (Eff localEs) a -> Eff handlerEs a)
-> LocalEnv localEs handlerEs
-> e (Eff localEs) a
-> Eff handlerEs a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack =>
LocalEnv localEs handlerEs -> e (Eff localEs) a -> Eff handlerEs a
LocalEnv localEs handlerEs -> e (Eff localEs) a -> Eff handlerEs a
EffectHandler e handlerEs
handler (Env localEs -> LocalEnv localEs handlerEs
forall (localEs :: [Effect]) (handlerEs :: [Effect]).
Env localEs -> LocalEnv localEs handlerEs
LocalEnv Env localEs
les) e (Eff localEs) a
op) Env handlerEs
handlerEs
{-# NOINLINE passthrough #-}
#endif

------------------------------------------------------------
-- Getting table identifiers from opaleye operations

tableIdentifierToQualifiedIdentifier :: O.TableIdentifier -> QualifiedIdentifier
tableIdentifierToQualifiedIdentifier :: TableIdentifier -> QualifiedIdentifier
tableIdentifierToQualifiedIdentifier (O.TableIdentifier Maybe String
mSchema String
table) =
  Maybe Text -> Text -> QualifiedIdentifier
QualifiedIdentifier (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mSchema) (String -> Text
T.pack String
table)

insertTableName :: O.Insert haskells -> QualifiedIdentifier
insertTableName :: forall haskells. Insert haskells -> QualifiedIdentifier
insertTableName (O.Insert Table fieldsW fieldsR
table [fieldsW]
_ Returning fieldsR haskells
_ Maybe OnConflict
_) =
  TableIdentifier -> QualifiedIdentifier
tableIdentifierToQualifiedIdentifier (TableIdentifier -> QualifiedIdentifier)
-> (Table fieldsW fieldsR -> TableIdentifier)
-> Table fieldsW fieldsR
-> QualifiedIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table fieldsW fieldsR -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
O.tableIdentifier (Table fieldsW fieldsR -> QualifiedIdentifier)
-> Table fieldsW fieldsR -> QualifiedIdentifier
forall a b. (a -> b) -> a -> b
$ Table fieldsW fieldsR
table

updateTableName :: O.Update haskells -> QualifiedIdentifier
updateTableName :: forall haskells. Update haskells -> QualifiedIdentifier
updateTableName (O.Update Table fieldsW fieldsR
table fieldsR -> fieldsW
_ fieldsR -> Field SqlBool
_ Returning fieldsR haskells
_) =
  TableIdentifier -> QualifiedIdentifier
tableIdentifierToQualifiedIdentifier (TableIdentifier -> QualifiedIdentifier)
-> (Table fieldsW fieldsR -> TableIdentifier)
-> Table fieldsW fieldsR
-> QualifiedIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table fieldsW fieldsR -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
O.tableIdentifier (Table fieldsW fieldsR -> QualifiedIdentifier)
-> Table fieldsW fieldsR -> QualifiedIdentifier
forall a b. (a -> b) -> a -> b
$ Table fieldsW fieldsR
table

deleteTableName :: O.Delete haskells -> QualifiedIdentifier
deleteTableName :: forall haskells. Delete haskells -> QualifiedIdentifier
deleteTableName (O.Delete Table fieldsW fieldsR
table fieldsR -> Field SqlBool
_ Returning fieldsR haskells
_) =
  TableIdentifier -> QualifiedIdentifier
tableIdentifierToQualifiedIdentifier (TableIdentifier -> QualifiedIdentifier)
-> (Table fieldsW fieldsR -> TableIdentifier)
-> Table fieldsW fieldsR
-> QualifiedIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table fieldsW fieldsR -> TableIdentifier
forall writeColumns viewColumns.
Table writeColumns viewColumns -> TableIdentifier
O.tableIdentifier (Table fieldsW fieldsR -> QualifiedIdentifier)
-> Table fieldsW fieldsR -> QualifiedIdentifier
forall a b. (a -> b) -> a -> b
$ Table fieldsW fieldsR
table

------------------------------------------------------------
-- Pretty rendering and printing counts

instance P.Pretty SQLOperationCounts where
  pPrint :: SQLOperationCounts -> Doc
pPrint = SQLOperationCounts -> Doc
prettyCounts

{- | Print an t'SQLOperationCounts' to stdout using 'prettyCounts'.
For less verbose output, see 'printCountsBrief'.
-}
printCounts :: (MonadIO m) => SQLOperationCounts -> m ()
printCounts :: forall (m :: * -> *). MonadIO m => SQLOperationCounts -> m ()
printCounts = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (SQLOperationCounts -> IO ()) -> SQLOperationCounts -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> (SQLOperationCounts -> String) -> SQLOperationCounts -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLOperationCounts -> String
renderCounts

{- | Print an t'SQLOperationCounts' to stdout using 'prettyCountsBrief'.
For more verbose output, see 'printCounts'.
-}
printCountsBrief :: (MonadIO m) => SQLOperationCounts -> m ()
printCountsBrief :: forall (m :: * -> *). MonadIO m => SQLOperationCounts -> m ()
printCountsBrief = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (SQLOperationCounts -> IO ()) -> SQLOperationCounts -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> (SQLOperationCounts -> String) -> SQLOperationCounts -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLOperationCounts -> String
renderCountsBrief

{- | Render an t'SQLOperationCounts' using 'prettyCounts'.
For less verbose output, see 'renderCountsBrief'.

For more control over how the 'P.Doc' gets rendered, use 'P.renderStyle' with a custom 'P.style'.
-}
renderCounts :: SQLOperationCounts -> String
renderCounts :: SQLOperationCounts -> String
renderCounts = Doc -> String
P.render (Doc -> String)
-> (SQLOperationCounts -> Doc) -> SQLOperationCounts -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLOperationCounts -> Doc
prettyCounts

{- | Render an t'SQLOperationCounts' using 'prettyCountsBrief'.
For more verbose output, see 'renderCounts'.

For more control over how the 'P.Doc' gets rendered, use 'P.renderStyle' with a custom 'P.style'.
-}
renderCountsBrief :: SQLOperationCounts -> String
renderCountsBrief :: SQLOperationCounts -> String
renderCountsBrief = Doc -> String
P.render (Doc -> String)
-> (SQLOperationCounts -> Doc) -> SQLOperationCounts -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLOperationCounts -> Doc
prettyCountsBrief

{- | Pretty-print an t'SQLOperationCounts' using "Text.PrettyPrint".
For each 'Map', we'll print one line for each table. For less verbose output,
see 'prettyCountsBrief'.

This is also the implementation of 'P.pPrint' for t'SQLOperationCounts'.
-}
prettyCounts :: SQLOperationCounts -> P.Doc
prettyCounts :: SQLOperationCounts -> Doc
prettyCounts = (Map QualifiedIdentifier Natural -> Maybe Doc)
-> SQLOperationCounts -> Doc
prettyCountsWith ((Map QualifiedIdentifier Natural -> Maybe Doc)
 -> SQLOperationCounts -> Doc)
-> (Map QualifiedIdentifier Natural -> Maybe Doc)
-> SQLOperationCounts
-> Doc
forall a b. (a -> b) -> a -> b
$ \Map QualifiedIdentifier Natural
mp ->
  let counts :: [(QualifiedIdentifier, Natural)]
counts = Map QualifiedIdentifier Natural -> [(QualifiedIdentifier, Natural)]
forall k a. Map k a -> [(k, a)]
Map.toList Map QualifiedIdentifier Natural
mp
      renderPair :: (QualifiedIdentifier, Natural) -> Maybe Doc
renderPair (QualifiedIdentifier
name, Natural
count) = Doc -> Doc -> Doc
prefix (QualifiedIdentifier -> Doc
renderTableName QualifiedIdentifier
name) (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Maybe Doc
renderNat Natural
count
  in  (NonEmpty Doc -> Doc) -> Maybe (NonEmpty Doc) -> Maybe Doc
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Doc] -> Doc
P.vcat ([Doc] -> Doc) -> (NonEmpty Doc -> [Doc]) -> NonEmpty Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Doc -> [Doc]
forall a. NonEmpty a -> [a]
NE.toList) (Maybe (NonEmpty Doc) -> Maybe Doc)
-> ([Doc] -> Maybe (NonEmpty Doc)) -> [Doc] -> Maybe Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Maybe (NonEmpty Doc)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Doc] -> Maybe Doc) -> [Doc] -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ ((QualifiedIdentifier, Natural) -> Maybe Doc)
-> [(QualifiedIdentifier, Natural)] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (QualifiedIdentifier, Natural) -> Maybe Doc
renderPair [(QualifiedIdentifier, Natural)]
counts

{- | Pretty-print an t'SQLOperationCounts' using "Text.PrettyPrint".
For each 'Map', we'll print just the sum of the counts. For more verbose output,
see 'prettyCounts'.
-}
prettyCountsBrief :: SQLOperationCounts -> P.Doc
prettyCountsBrief :: SQLOperationCounts -> Doc
prettyCountsBrief = (Map QualifiedIdentifier Natural -> Maybe Doc)
-> SQLOperationCounts -> Doc
prettyCountsWith ((Map QualifiedIdentifier Natural -> Maybe Doc)
 -> SQLOperationCounts -> Doc)
-> (Map QualifiedIdentifier Natural -> Maybe Doc)
-> SQLOperationCounts
-> Doc
forall a b. (a -> b) -> a -> b
$ \Map QualifiedIdentifier Natural
mp ->
  let total :: Natural
total = [Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ Map QualifiedIdentifier Natural -> [Natural]
forall k a. Map k a -> [a]
Map.elems Map QualifiedIdentifier Natural
mp
  in  Natural -> Maybe Doc
renderNat Natural
total

prettyCountsWith :: (Map QualifiedIdentifier Natural -> Maybe P.Doc) -> SQLOperationCounts -> P.Doc
prettyCountsWith :: (Map QualifiedIdentifier Natural -> Maybe Doc)
-> SQLOperationCounts -> Doc
prettyCountsWith Map QualifiedIdentifier Natural -> Maybe Doc
renderMap (SQLOperationCounts Natural
selects Map QualifiedIdentifier Natural
inserts Map QualifiedIdentifier Natural
deletes Map QualifiedIdentifier Natural
updates) =
  let parts :: [Doc]
parts =
        [Maybe Doc] -> [Doc]
forall a. [Maybe a] -> [a]
catMaybes
          [ Doc -> Doc -> Doc
prefix Doc
"SELECT" (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Maybe Doc
renderNat Natural
selects
          , Doc -> Doc -> Doc
prefix Doc
"INSERT" (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map QualifiedIdentifier Natural -> Maybe Doc
renderMap Map QualifiedIdentifier Natural
inserts
          , Doc -> Doc -> Doc
prefix Doc
"UPDATE" (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map QualifiedIdentifier Natural -> Maybe Doc
renderMap Map QualifiedIdentifier Natural
updates
          , Doc -> Doc -> Doc
prefix Doc
"DELETE" (Doc -> Doc) -> Maybe Doc -> Maybe Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map QualifiedIdentifier Natural -> Maybe Doc
renderMap Map QualifiedIdentifier Natural
deletes
          ]
  in  case [Doc]
parts of
        [] -> Doc
"None"
        [Doc]
_ -> [Doc] -> Doc
P.vcat [Doc]
parts

prefix :: P.Doc -> P.Doc -> P.Doc
prefix :: Doc -> Doc -> Doc
prefix Doc
t Doc
n = Doc
t Doc -> Doc -> Doc
P.<> Doc
":" Doc -> Doc -> Doc
P.<+> Doc
n

renderNat :: Natural -> Maybe P.Doc
renderNat :: Natural -> Maybe Doc
renderNat = \case
  Natural
0 -> Maybe Doc
forall a. Maybe a
Nothing
  Natural
n -> Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
P.pPrint @Integer (Integer -> Doc) -> Integer -> Doc
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
n

renderTableName :: QualifiedIdentifier -> P.Doc
renderTableName :: QualifiedIdentifier -> Doc
renderTableName (QualifiedIdentifier Maybe Text
mSchema Text
table) =
  case Maybe Text
mSchema of
    Maybe Text
Nothing -> Text -> Doc
renderText Text
table
    Just Text
schema -> Text -> Doc
renderText Text
schema Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
renderText Text
table

renderText :: T.Text -> P.Doc
renderText :: Text -> Doc
renderText = String -> Doc
P.text (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack