diff --git a/src/Quasar/Core.hs b/src/Quasar/Core.hs index c07fa2264ba45fb71b604a0353e384d31a996316..ecc2d4c84b9bcee0047ab181299e9aab8747199c 100644 --- a/src/Quasar/Core.hs +++ b/src/Quasar/Core.hs @@ -29,7 +29,7 @@ module Quasar.Core ( IsDisposable(..), Disposable, disposeIO, - mkDisposable, + newDisposable, synchronousDisposable, noDisposable, disposeEventually, @@ -99,7 +99,7 @@ data ResourceManager = ResourceManager { } instance IsDisposable ResourceManager where - dispose x = pure $ pure () + toDisposable x = undefined -- | A task that is running asynchronously. It has a result and can fail. @@ -112,7 +112,7 @@ instance IsAwaitable r (Task r) where toAwaitable (Task awaitable) = awaitable instance IsDisposable (Task r) where - dispose = undefined + toDisposable = undefined instance Functor Task where fmap fn (Task x) = Task (fn <$> x) @@ -203,7 +203,7 @@ class IsDisposable a where dispose = dispose . toDisposable toDisposable :: a -> Disposable - toDisposable = mkDisposable . dispose + toDisposable = Disposable {-# MINIMAL toDisposable | dispose #-} @@ -215,25 +215,52 @@ instance IsDisposable a => IsDisposable (Maybe a) where dispose = maybe (pure (pure ())) dispose -newtype Disposable = Disposable (IO (Awaitable ())) + +data Disposable = forall a. IsDisposable a => Disposable a instance IsDisposable Disposable where - dispose (Disposable fn) = fn + dispose (Disposable x) = dispose x toDisposable = id instance Semigroup Disposable where - x <> y = mkDisposable $ liftA2 (<>) (dispose x) (dispose y) + x <> y = toDisposable $ CombinedDisposable x y instance Monoid Disposable where - mempty = mkDisposable $ pure $ pure () - mconcat disposables = mkDisposable $ mconcat <$> traverse dispose disposables + mempty = toDisposable EmptyDisposable + mconcat = toDisposable . ListDisposable + + +newtype FnDisposable = FnDisposable (IO (Awaitable ())) + +instance IsDisposable FnDisposable where + dispose (FnDisposable fn) = fn + + +data CombinedDisposable = CombinedDisposable Disposable Disposable + +instance IsDisposable CombinedDisposable where + dispose (CombinedDisposable x y) = liftA2 (<>) (dispose x) (dispose y) + +data ListDisposable = ListDisposable [Disposable] + +instance IsDisposable ListDisposable where + dispose (ListDisposable disposables) = mconcat <$> traverse dispose disposables + + + + +data EmptyDisposable = EmptyDisposable + +instance IsDisposable EmptyDisposable where + dispose EmptyDisposable = pure $ pure () + -mkDisposable :: IO (Awaitable ()) -> Disposable -mkDisposable = Disposable +newDisposable :: IO (Awaitable ()) -> IO Disposable +newDisposable = pure . toDisposable . FnDisposable -synchronousDisposable :: IO () -> Disposable -synchronousDisposable = mkDisposable . fmap pure . liftIO +synchronousDisposable :: IO () -> IO Disposable +synchronousDisposable = newDisposable . fmap pure . liftIO noDisposable :: Disposable noDisposable = mempty diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs index 73f3b9a5381b52147f9b48a1a2830c6d1f36e87f..a6facd139b62534d45aebad4a358713548806083 100644 --- a/src/Quasar/Disposable.hs +++ b/src/Quasar/Disposable.hs @@ -2,7 +2,7 @@ module Quasar.Disposable ( IsDisposable(..), Disposable, disposeIO, - mkDisposable, + newDisposable, synchronousDisposable, noDisposable, ) where diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs index 60bc12ab8e65a40e1334aaaa2784577cb4210a53..19f05a8d7c163f774d30af70eb03b2c9a942dda2 100644 --- a/src/Quasar/Observable.hs +++ b/src/Quasar/Observable.hs @@ -309,7 +309,7 @@ instance IsObservable v (ObservableVar v) where -- Call listener callback (pure state) pure (state, HM.insert key callback subscribers) - pure $ synchronousDisposable (disposeFn key) + synchronousDisposable (disposeFn key) where disposeFn :: Unique -> IO () disposeFn key = modifyMVar_ mvar (\(state, subscribers) -> pure (state, HM.delete key subscribers)) diff --git a/src/Quasar/Observable/ObservableHashMap.hs b/src/Quasar/Observable/ObservableHashMap.hs index c183ffc158ab8a53b0d8220ed87c282989fb7d2c..085d288ed6e3a49d131edfbbfe453ec7664ab74d 100644 --- a/src/Quasar/Observable/ObservableHashMap.hs +++ b/src/Quasar/Observable/ObservableHashMap.hs @@ -47,7 +47,7 @@ instance IsObservable (HM.HashMap k v) (ObservableHashMap k v) where callback $ pure $ toHashMap handle unique <- newUnique let handle' = handle & set (_subscribers . at unique) (Just callback) - pure (handle', synchronousDisposable (unsubscribe unique)) + (handle',) <$> synchronousDisposable (unsubscribe unique) unsubscribe :: Unique -> IO () unsubscribe unique = modifyHandle_ (pure . set (_subscribers . at unique) Nothing) ohm @@ -59,7 +59,7 @@ instance IsDeltaObservable k v (ObservableHashMap k v) where callback (Reset $ toHashMap handle) unique <- newUnique let handle' = handle & set (_deltaSubscribers . at unique) (Just callback) - pure (handle', synchronousDisposable (unsubscribe unique)) + (handle',) <$> synchronousDisposable (unsubscribe unique) unsubscribe :: Unique -> IO () unsubscribe unique = modifyHandle_ (pure . set (_deltaSubscribers . at unique) Nothing) ohm @@ -123,7 +123,7 @@ observeKey key ohm@(ObservableHashMap mvar) = synchronousFnObservable observeFn observeFn callback = do subscriptionKey <- newUnique modifyKeyHandle_ (subscribeFn' subscriptionKey) key ohm - pure $ synchronousDisposable (unsubscribe subscriptionKey) + synchronousDisposable (unsubscribe subscriptionKey) where subscribeFn' :: Unique -> KeyHandle v -> IO (KeyHandle v) subscribeFn' subKey keyHandle@KeyHandle{value} = do diff --git a/src/Quasar/Observable/ObservablePriority.hs b/src/Quasar/Observable/ObservablePriority.hs index 53aa6f7432b305c1a0fcace59cd9da20e76424aa..55acf14cf3a5e639c7b7078eda37ec6722280b7a 100644 --- a/src/Quasar/Observable/ObservablePriority.hs +++ b/src/Quasar/Observable/ObservablePriority.hs @@ -31,7 +31,7 @@ instance IsObservable (Maybe v) (ObservablePriority p v) where -- Call listener callback (pure (currentValue internals)) pure internals{subscribers = HM.insert key callback subscribers} - pure $ synchronousDisposable (unsubscribe key) + synchronousDisposable (unsubscribe key) where unsubscribe :: Unique -> IO () unsubscribe key = modifyMVar_ mvar $ \internals@Internals{subscribers} -> pure internals{subscribers=HM.delete key subscribers} @@ -61,7 +61,7 @@ insertValue :: forall p v. (Ord p, Hashable p) => ObservablePriority p v -> p -> insertValue (ObservablePriority mvar) priority value = modifyMVar mvar $ \internals -> do key <- newUnique newInternals <- insertValue' key internals - pure (newInternals, synchronousDisposable (removeValue key)) + (newInternals,) <$> synchronousDisposable (removeValue key) where insertValue' :: Unique -> Internals p v -> IO (Internals p v) insertValue' key internals@Internals{priorityMap, current}