Skip to content

Instantly share code, notes, and snippets.

@tek
Created October 14, 2022 20:53
Show Gist options
  • Save tek/155728a934e574b50e41462016cac0b9 to your computer and use it in GitHub Desktop.
Save tek/155728a934e574b50e41462016cac0b9 to your computer and use it in GitHub Desktop.
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
@tek
Copy link
Author

tek commented Oct 17, 2022

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.

@adlaika
Copy link

adlaika commented Oct 17, 2022

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment