diff --git a/quasar.cabal b/quasar.cabal index 8c069c34ebfe0f28c26353cf4ccf4c9bd60ef5ea..589d624f36a93311883b1bd1df517daecced2c2d 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -104,7 +104,6 @@ library Quasar.PreludeExtras Quasar.ResourceManager Quasar.Resources - Quasar.Subscribable Quasar.Timer Quasar.Timer.PosixTimer Quasar.Timer.TimerFd @@ -136,6 +135,5 @@ test-suite quasar-test Quasar.Observable.ObservableHashMapSpec Quasar.Observable.ObservablePrioritySpec Quasar.ResourceManagerSpec - Quasar.SubscribableSpec hs-source-dirs: test diff --git a/src/Quasar.hs b/src/Quasar.hs index 8c2bf28a6a4884b7f217f56dce8033ee5511928b..c5734c3d2877798562f3b302414f214b4bb5f1df 100644 --- a/src/Quasar.hs +++ b/src/Quasar.hs @@ -4,7 +4,6 @@ module Quasar ( module Quasar.Monad, module Quasar.Observable, module Quasar.Resources, - module Quasar.Subscribable, ) where import Quasar.Async.V2 @@ -12,4 +11,3 @@ import Quasar.Awaitable import Quasar.Monad import Quasar.Observable import Quasar.Resources -import Quasar.Subscribable diff --git a/src/Quasar/Subscribable.hs b/src/Quasar/Subscribable.hs deleted file mode 100644 index 8e6abe6c72b277fcb57d5df2ced45be24e1d5f8e..0000000000000000000000000000000000000000 --- a/src/Quasar/Subscribable.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Quasar.Subscribable ( - SubscribableMessage(..), - IsSubscribable(..), - Subscribable, - SubscribableEvent, - newSubscribableEvent, - raiseSubscribableEvent, -) where - -import Control.Concurrent.STM -import Control.Monad.Catch -import Control.Monad.Reader -import Data.HashMap.Strict qualified as HM -import Quasar.Awaitable -import Quasar.Disposable -import Quasar.Prelude -import Quasar.ResourceManager - - -data SubscribableMessage r - = SubscribableUpdate r - | SubscribableNotAvailable SomeException - deriving stock (Show, Generic) -instance Functor SubscribableMessage where - fmap fn (SubscribableUpdate r) = SubscribableUpdate (fn r) - fmap _ (SubscribableNotAvailable ex) = SubscribableNotAvailable ex - - -class IsSubscribable r a | a -> r where - toSubscribable :: a -> Subscribable r - toSubscribable x = Subscribable x - - subscribe - :: (MonadResourceManager m, MonadIO m, MonadMask m) - => a - -> (SubscribableMessage r -> ResourceManagerIO (Awaitable ())) - -> m () - subscribe x = subscribe (toSubscribable x) - {-# MINIMAL toSubscribable | subscribe #-} - -data Subscribable r where - Subscribable :: IsSubscribable r a => a -> Subscribable r - MappedSubscribable :: IsSubscribable a o => (a -> r) -> o -> Subscribable r - MultiSubscribable :: [Subscribable r] -> Subscribable r - -instance IsSubscribable r (Subscribable r) where - toSubscribable = id - subscribe (Subscribable x) callback = subscribe x callback - subscribe (MappedSubscribable fn x) callback = subscribe x (callback . fmap fn) - subscribe (MultiSubscribable xs) callback = forM_ xs (`subscribe` callback) - -instance Functor Subscribable where - fmap fn (Subscribable x) = MappedSubscribable fn x - fmap fn (MappedSubscribable fn2 x) = MappedSubscribable (fn . fn2) x - fmap fn x@(MultiSubscribable _) = MappedSubscribable fn x - -instance Semigroup (Subscribable r) where - MultiSubscribable [] <> x = x - x <> MultiSubscribable [] = x - MultiSubscribable as <> MultiSubscribable bs = MultiSubscribable $ as <> bs - MultiSubscribable as <> b = MultiSubscribable $ as <> [b] - a <> MultiSubscribable bs = MultiSubscribable $ [a] <> bs - a <> b = MultiSubscribable [a, b] - -instance Monoid (Subscribable r) where - mempty = MultiSubscribable [] - - -newtype SubscribableEvent r = SubscribableEvent (TVar (HM.HashMap Unique (SubscribableMessage r -> IO (Awaitable())))) -instance IsSubscribable r (SubscribableEvent r) where - subscribe (SubscribableEvent tvar) callback = mask_ do - key <- liftIO newUnique - resourceManager <- askResourceManager - runInResourceManagerSTM do - registerDisposable =<< lift do - callbackMap <- readTVar tvar - writeTVar tvar $ HM.insert key (\msg -> runReaderT (callback msg) resourceManager) callbackMap - newDisposable (disposeFn key) - where - disposeFn :: Unique -> IO () - disposeFn key = atomically do - callbackMap <- readTVar tvar - writeTVar tvar $ HM.delete key callbackMap - - -newSubscribableEvent :: MonadIO m => m (SubscribableEvent r) -newSubscribableEvent = liftIO $ SubscribableEvent <$> newTVarIO HM.empty - -raiseSubscribableEvent :: MonadIO m => SubscribableEvent r -> r -> m () -raiseSubscribableEvent (SubscribableEvent tvar) r = liftIO do - callbackMap <- readTVarIO tvar - awaitables <- forM (HM.elems callbackMap) \callback -> do - callback $ SubscribableUpdate r - await $ mconcat awaitables diff --git a/test/Quasar/SubscribableSpec.hs b/test/Quasar/SubscribableSpec.hs deleted file mode 100644 index deefbd4796b594b5379cf9a9908ff60379a07a09..0000000000000000000000000000000000000000 --- a/test/Quasar/SubscribableSpec.hs +++ /dev/null @@ -1,58 +0,0 @@ -module Quasar.SubscribableSpec ( - spec, -) where - -import Control.Concurrent.STM -import Quasar.Prelude -import Quasar.ResourceManager -import Quasar.Subscribable -import Test.Hspec - - -spec :: Spec -spec = do - describe "SubscribableEvent" $ parallel do - - it "can be subscribed" $ io $ withRootResourceManager do - event <- newSubscribableEvent - resultVar <- liftIO newEmptyTMVarIO - subscribe event $ liftIO . \case - SubscribableUpdate r -> atomically (putTMVar resultVar r) >> mempty - SubscribableNotAvailable ex -> throwIO ex - raiseSubscribableEvent event (42 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42 - - it "stops calling the callback after the subscription is disposed" $ io $ withRootResourceManager do - event <- newSubscribableEvent - resultVar <- liftIO $ newEmptyTMVarIO - withScopedResourceManager do - subscribe event $ liftIO . \case - SubscribableUpdate r -> atomically (putTMVar resultVar r) >> mempty - SubscribableNotAvailable ex -> throwIO ex - raiseSubscribableEvent event (42 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42 - raiseSubscribableEvent event (21 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Nothing - - it "can be fmap'ed" $ io $ withRootResourceManager do - event <- newSubscribableEvent - let subscribable = (* 2) <$> toSubscribable event - resultVar <- liftIO $ newEmptyTMVarIO - subscribe subscribable $ liftIO . \case - SubscribableUpdate r -> atomically (putTMVar resultVar r) >> mempty - SubscribableNotAvailable ex -> throwIO ex - raiseSubscribableEvent event (21 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42 - - it "can be combined with other events" $ io $ withRootResourceManager do - event1 <- newSubscribableEvent - event2 <- newSubscribableEvent - let subscribable = toSubscribable event1 <> toSubscribable event2 - resultVar <- liftIO $ newEmptyTMVarIO - subscribe subscribable $ liftIO . \case - SubscribableUpdate r -> atomically (putTMVar resultVar r) >> mempty - SubscribableNotAvailable ex -> throwIO ex - raiseSubscribableEvent event1 (21 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 21 - raiseSubscribableEvent event2 (42 :: Int) - liftIO $ atomically (tryTakeTMVar resultVar) `shouldReturn` Just 42