Bundle.hs

import Conc (interpretScoped, interpretScopedWith, interpretSync)
import Database.PostgreSQL.Simple (Connection)
import qualified Database.PostgreSQL.Simple.Transaction as Psql
import Polysemy.Bundle (Bundle (Bundle), sendBundle)
import Polysemy.Internal.Kind (Append)
import Polysemy.Membership (ElemOf (Here, There))
import qualified Sync

data Connections :: Effect where
  New :: Connections m Connection
  Release :: Connection -> Connections m ()

makeSem ''Connections

-- call withConnectionPool here or something
interpretConnections :: InterpreterFor Connections r
interpretConnections =
  undefined

data Pg a = Pg

data Database :: Effect where
  Query :: Pg a -> Database m (Maybe a)

makeSem ''Database

transact ::
  Member (Scoped res Database) r =>
  InterpreterFor Database r
transact =
  scoped

runQuery :: Connection -> Pg a -> IO (Maybe a)
runQuery =
  undefined

-- Each time 'Database' is scoped in 'storeScope', a new transaction is wrapped around the scoped computation
dbScope ::
  Members [Connections, Resource, Embed IO] r =>
  (Connection -> Sem r a) ->
  Sem r a
dbScope use = do
  bracket new release \ conn -> do
    onException
      do
        embed (Psql.begin conn)
        use conn <* embed (Psql.commit conn)
      do
        embed (Psql.rollback conn)

interpretDatabase ::
  Members [Connections, Resource, Embed IO] r =>
  InterpreterFor (Scoped Connection Database) r
interpretDatabase =
  interpretScoped dbScope \ conn -> \case
    Query q ->
      embed (runQuery conn q)

data Store a :: Effect where
  Fetch :: Store a m (Maybe [a])

makeSem ''Store

-- bolierplate for 'Store' bundles
class InjectStores bundle stores r where
  injectStores :: Sem (Append stores r) a -> Sem r a

instance InjectStores bundle '[] r where
  injectStores =
    id

instance (
  InjectStores bundle stores r,
  Member store bundle,
  Member (Bundle bundle) r,
  Member (Bundle bundle) (Append stores r)
  ) => InjectStores bundle (store : stores) r where
    injectStores =
      injectStores @bundle @stores . sendBundle @store @bundle @(Append stores r)

-- For the convenience of not having to write @withStores [Store Creator, Store Reward]@
type family StoreList (stores :: [Type]) :: EffectRow where
  StoreList '[] = '[]
  StoreList (store : stores) = Store store : StoreList stores

withStores ::
  ∀ stores r a .
  InjectStores (StoreList stores) (StoreList stores) r =>
  Sem (Append (StoreList stores) r) a ->
  Sem r a
withStores =
  injectStores @(StoreList stores) @(StoreList stores)

class HandleStore e r where
  handleStore :: e m a -> Sem (Database : r) a

class HandleStores stores r where
  handleStores :: ElemOf e stores -> e m a -> Sem (Database : r) a

instance HandleStores '[] r where
  handleStores = \case

instance (
    HandleStore store r,
    HandleStores stores r
  ) => HandleStores (store : stores) r where
  handleStores Here e =
    handleStore e
  handleStores (There pr) e =
    handleStores @stores pr e

-- Creates a 'Database' scope within a 'Store' scope that starts a transaction.
storeScope ::
  Member (Scoped res Database) r =>
  (() -> Sem (Database : r) a) ->
  Sem r a
storeScope use =
  transact do
    use ()

-- unwrap a store bundle and use the classes to dispatch to the correct handler
interpretStores ::
  HandleStores stores r =>
  Member (Scoped res Database) r =>
  InterpreterFor (Scoped () (Bundle stores)) r
interpretStores =
  interpretScopedWith @'[Database] storeScope \ _ (Bundle pr e) ->
    handleStores pr e

-----------------
-- business logic
-----------------

data Creator = Creator

data Reward = Reward

endpoint ::
  Members [Store Creator, Store Reward] r =>
  Sem r ()
endpoint =
  void (fetch @Creator)

runEndpoint ::
  Member (Scoped res (Bundle [Store Creator, Store Reward])) r =>
  Sem r ()
runEndpoint =
  scoped do
    withStores @[Creator, Reward] endpoint

instance HandleStore (Store Creator) r where
  handleStore Fetch =
    query Pg

instance HandleStore (Store Reward) r where
  handleStore Fetch =
    query Pg

main :: IO ()
main =
  runFinal $
  embedToFinal $
  resourceToIOFinal $
  interpretConnections $
  interpretDatabase $
  interpretStores runEndpoint

This is amazing--thank you so much! I'm still wrapping my head around how it all works...Is it expected to have to enable AllowAmbiguousTypes and UndecidableInstances in order to compile?

A problem I see with this approach is that it seems to require that all of my *Store query types eventually boil down to a set of queries that are available for every *Store. If Reward, for instance, has a certain key that I want to fetch on which Creator does not have, I have to introduce another constructor to Store that's not possible to implement for Creator, leading to an unsound implementation of instance HandleStore (Store Creator) r. I know just enough to imagine there might be a solution there using phantom types and/or type families, but the problem compounds when I start thinking about joins and other more complicated SQL queries that require more than one parameter.

This is amazing--thank you so much! I'm still wrapping my head around how it all works...Is it expected to have to enable AllowAmbiguousTypes and UndecidableInstances in order to compile?

yeah, you could maybe use a witness proof to get around the first one, but there's no harm in enabling the extension.

A problem I see with this approach is that it seems to require that all of my *Store query types eventually boil down to a set of queries that are available for every *Store.

You don't have to use a common Store effect – just remove the StoreList and use the bundle like the comment above it says!
HandleStore provides the Database dependency to any effect you put in there; they don't have to be the same.

You don't have to use a common Store effect – just remove the StoreList and use the bundle like the comment above it says!

Ooooh I see now, gotcha.