Skip to content
Snippets Groups Projects
Commit a91a3960 authored by Jens Nolte's avatar Jens Nolte
Browse files

Streamline Disposer interface


Co-authored-by: default avatarJan Beinke <git@janbeinke.com>
parent 97e1744a
No related branches found
No related tags found
No related merge requests found
......@@ -37,7 +37,7 @@ import Control.Exception (throwTo)
data Async a = Async (Future a) Disposer
instance Resource (Async a) where
getDisposer (Async _ disposer) = [disposer]
toDisposer (Async _ disposer) = disposer
instance IsFuture a (Async a) where
toFuture (Async awaitable _) = awaitable
......
......@@ -50,7 +50,7 @@ import Quasar.Resources.Disposer
data Quasar = Quasar Logger TIOWorker ExceptionSink ResourceManager
instance Resource Quasar where
getDisposer (Quasar _ _ _ rm) = getDisposer rm
toDisposer (Quasar _ _ _ rm) = toDisposer rm
instance HasField "logger" Quasar Logger where
getField = quasarLogger
......
......@@ -93,7 +93,7 @@ class IsRetrievable r a => IsObservable r a | a -> r where
:: (MonadQuasar m, MonadSTM m)
=> a -- ^ observable
-> ObservableCallback r -- ^ callback
-> m [Disposer]
-> m Disposer
observe observable = observe (toObservable observable)
pingObservable
......@@ -122,7 +122,7 @@ observeIO
:: (IsObservable r a, MonadQuasar m, MonadIO m)
=> a -- ^ observable
-> ObservableCallback r -- ^ callback
-> m [Disposer]
-> m Disposer
observeIO observable callback = quasarAtomically $ observe observable callback
observeIO_
......@@ -250,7 +250,7 @@ instance IsRetrievable a (ConstObservable a) where
instance IsObservable a (ConstObservable a) where
observe (ConstObservable x) callback = liftQuasarSTM do
callback $ ObservableValue x
pure []
pure trivialDisposer
pingObservable _ = pure ()
......@@ -260,7 +260,7 @@ instance IsRetrievable a (ThrowObservable a) where
instance IsObservable a (ThrowObservable a) where
observe (ThrowObservable ex) callback = liftQuasarSTM do
callback $ ObservableNotAvailable ex
pure []
pure trivialDisposer
pingObservable _ = pure ()
......@@ -317,7 +317,7 @@ instance IsObservable a (BindObservable a) where
observe (BindObservable fx fn) callback = liftQuasarSTM do
callback ObservableLoading
keyVar <- newTVar =<< newUniqueSTM
disposableVar <- liftSTM $ newTVar []
disposableVar <- liftSTM (newTVar trivialDisposer)
observe fx (leftCallback keyVar disposableVar)
where
leftCallback keyVar disposableVar lmsg = do
......@@ -328,8 +328,8 @@ instance IsObservable a (BindObservable a) where
disposer <-
case lmsg of
ObservableValue x -> observe (fn x) (rightCallback key)
ObservableLoading -> [] <$ callback ObservableLoading
ObservableNotAvailable ex -> [] <$ callback (ObservableNotAvailable ex)
ObservableLoading -> trivialDisposer <$ callback ObservableLoading
ObservableNotAvailable ex -> trivialDisposer <$ callback (ObservableNotAvailable ex)
writeTVar disposableVar disposer
where
rightCallback :: Unique -> ObservableCallback a
......@@ -353,7 +353,7 @@ instance IsObservable a (CatchObservable e a) where
observe (CatchObservable fx fn) callback = liftQuasarSTM do
callback ObservableLoading
keyVar <- newTVar =<< newUniqueSTM
disposableVar <- liftSTM $ newTVar []
disposableVar <- liftSTM $ newTVar trivialDisposer
observe fx (leftCallback keyVar disposableVar)
where
leftCallback keyVar disposableVar lmsg = do
......@@ -364,7 +364,7 @@ instance IsObservable a (CatchObservable e a) where
disposer <-
case lmsg of
ObservableNotAvailable (fromException -> Just ex) -> observe (fn ex) (rightCallback key)
_ -> [] <$ callback lmsg
_ -> trivialDisposer <$ callback lmsg
writeTVar disposableVar disposer
where
rightCallback :: Unique -> ObservableCallback a
......@@ -384,14 +384,14 @@ newObserverRegistry = ObserverRegistry <$> newTVar mempty
newObserverRegistryIO :: MonadIO m => m (ObserverRegistry a)
newObserverRegistryIO = liftIO $ ObserverRegistry <$> newTVarIO mempty
registerObserver :: ObserverRegistry a -> ObservableCallback a -> ObservableState a -> QuasarSTM [Disposer]
registerObserver :: ObserverRegistry a -> ObservableCallback a -> ObservableState a -> QuasarSTM Disposer
registerObserver (ObserverRegistry var) callback currentState = do
quasar <- askQuasar
key <- newUniqueSTM
modifyTVar var (HM.insert key (execForeignQuasarSTM quasar . callback))
disposer <- registerDisposeTransaction $ modifyTVar var (HM.delete key)
callback currentState
pure [disposer]
pure disposer
updateObservers :: ObserverRegistry a -> ObservableState a -> STM ()
updateObservers (ObserverRegistry var) newState =
......
......@@ -147,24 +147,24 @@ disposeEventuallyIO_ :: (Resource r, MonadIO m) => r -> m ()
disposeEventuallyIO_ res = atomically $ void $ disposeEventually res
captureResources :: (MonadQuasar m, MonadSTM m) => m a -> m (a, [Disposer])
captureResources :: (MonadQuasar m, MonadSTM m) => m a -> m (a, Disposer)
captureResources fn = do
quasar <- newResourceScope
localQuasar quasar do
result <- fn
pure (result, getDisposer (quasarResourceManager quasar))
pure (result, toDisposer (quasarResourceManager quasar))
captureResources_ :: (MonadQuasar m, MonadSTM m) => m () -> m [Disposer]
captureResources_ :: (MonadQuasar m, MonadSTM m) => m () -> m Disposer
captureResources_ fn = snd <$> captureResources fn
captureResourcesIO :: (MonadQuasar m, MonadIO m) => m a -> m (a, [Disposer])
captureResourcesIO :: (MonadQuasar m, MonadIO m) => m a -> m (a, Disposer)
captureResourcesIO fn = do
quasar <- newResourceScopeIO
localQuasar quasar do
result <- fn
pure (result, getDisposer (quasarResourceManager quasar))
pure (result, toDisposer (quasarResourceManager quasar))
captureResourcesIO_ :: (MonadQuasar m, MonadIO m) => m () -> m [Disposer]
captureResourcesIO_ :: (MonadQuasar m, MonadIO m) => m () -> m Disposer
captureResourcesIO_ fn = snd <$> captureResourcesIO fn
......
......@@ -29,49 +29,52 @@ import Quasar.Exceptions
import Quasar.Prelude
import Quasar.Utils.ShortIO
import Quasar.Utils.TOnce
import GHC.IO (unsafePerformIO, unsafeDupablePerformIO)
class Resource a where
getDisposer :: a -> [Disposer]
toDisposer :: a -> Disposer
isDisposed :: a -> Future ()
isDisposed r = foldMap isDisposed $ getDisposer r
isDisposed r = isDisposed (toDisposer r)
isDisposing :: a -> Future ()
isDisposing r = awaitAny $ isDisposing <$> getDisposer r
isDisposing r = isDisposing (toDisposer r)
type DisposerState = TOnce DisposeFn (Future ())
data Disposer
= TrivialDisposer
| FnDisposer Unique TIOWorker ExceptionSink DisposerState Finalizers
data DisposerElement
= FnDisposer Unique TIOWorker ExceptionSink DisposerState Finalizers
| ResourceManagerDisposer ResourceManager
instance Resource Disposer where
getDisposer disposer = [disposer]
instance Resource DisposerElement where
toDisposer disposer = Disposer [disposer]
isDisposed TrivialDisposer = pure ()
isDisposed (FnDisposer _ _ _ state _) = join (toFuture state)
isDisposed (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposed resourceManager
isDisposing TrivialDisposer = pure ()
isDisposing (FnDisposer _ _ _ state _) = unsafeAwaitSTM (check . isRight =<< readTOnceState state)
isDisposing (ResourceManagerDisposer resourceManager) = resourceManagerIsDisposing resourceManager
instance Resource [Disposer] where
getDisposer = id
newtype Disposer = Disposer [DisposerElement]
deriving newtype (Semigroup, Monoid)
instance Resource Disposer where
toDisposer = id
isDisposed (Disposer ds) = foldMap isDisposed ds
isDisposing (Disposer ds) = awaitAny $ isDisposing <$> ds
type DisposeFn = ShortIO (Future ())
-- | A trivial disposer that does not perform any action when disposed.
trivialDisposer :: Disposer
trivialDisposer = TrivialDisposer
trivialDisposer = mempty
newUnmanagedPrimitiveDisposer :: ShortIO (Future ()) -> TIOWorker -> ExceptionSink -> STM Disposer
newUnmanagedPrimitiveDisposer fn worker exChan = do
newUnmanagedPrimitiveDisposer fn worker exChan = toDisposer <$> do
key <- newUniqueSTM
FnDisposer key worker exChan <$> newTOnce fn <*> newFinalizers
......@@ -80,10 +83,9 @@ dispose :: (MonadIO m, Resource r) => r -> m ()
dispose resource = liftIO $ await =<< atomically (disposeEventuallySTM resource)
disposeEventuallySTM :: Resource r => r -> STM (Future ())
disposeEventuallySTM resource = mconcat <$> mapM f (getDisposer resource)
disposeEventuallySTM (toDisposer -> Disposer ds) = mconcat <$> mapM f ds
where
f :: Disposer -> STM (Future ())
f TrivialDisposer = pure (pure ())
f :: DisposerElement -> STM (Future ())
f (FnDisposer _ worker exChan state finalizers) =
beginDisposeFnDisposer worker exChan state finalizers
f (ResourceManagerDisposer resourceManager) =
......@@ -118,18 +120,12 @@ beginDisposeFnDisposer worker exChan disposeState finalizers =
runFinalizersShortIO finalizers
throwM $ DisposeException ex
disposerKey :: Disposer -> Unique
disposerKey TrivialDisposer = trivialDisposableKey
disposerKey :: DisposerElement -> Unique
disposerKey (FnDisposer key _ _ _ _) = key
disposerKey (ResourceManagerDisposer resourceManager) = resourceManagerKey resourceManager
trivialDisposableKey :: Unique
trivialDisposableKey = unsafePerformIO newUnique
{-# NOINLINE trivialDisposableKey #-}
disposerFinalizers :: Disposer -> Finalizers
disposerFinalizers TrivialDisposer = completedFinalizers
disposerFinalizers :: DisposerElement -> Finalizers
disposerFinalizers (FnDisposer _ _ _ _ finalizers) = finalizers
disposerFinalizers (ResourceManagerDisposer rm) = resourceManagerFinalizers rm
......@@ -150,12 +146,12 @@ data ResourceManager = ResourceManager {
}
data ResourceManagerState
= ResourceManagerNormal (TVar (HashMap Unique Disposer)) TIOWorker ExceptionSink
= ResourceManagerNormal (TVar (HashMap Unique DisposerElement)) TIOWorker ExceptionSink
| ResourceManagerDisposing (Future [DisposeDependencies])
| ResourceManagerDisposed
instance Resource ResourceManager where
getDisposer rm = [ResourceManagerDisposer rm]
toDisposer rm = Disposer [ResourceManagerDisposer rm]
isDisposed = resourceManagerIsDisposed
isDisposing = resourceManagerIsDisposing
......@@ -174,10 +170,10 @@ newUnmanagedResourceManagerSTM worker exChan = do
attachResource :: Resource a => ResourceManager -> a -> STM ()
attachResource resourceManager resource =
mapM_ (attachDisposer resourceManager) (getDisposer resource)
attachResource resourceManager (toDisposer -> Disposer ds) =
mapM_ (attachDisposer resourceManager) ds
attachDisposer :: ResourceManager -> Disposer -> STM ()
attachDisposer :: ResourceManager -> DisposerElement -> STM ()
attachDisposer resourceManager disposer = do
readTVar (resourceManagerState resourceManager) >>= \case
ResourceManagerNormal attachedResources _ _ -> do
......@@ -215,7 +211,7 @@ beginDisposeResourceManagerInternal rm = do
ResourceManagerDisposing deps -> pure $ DisposeDependencies rmKey deps
ResourceManagerDisposed -> pure $ DisposeDependencies rmKey mempty
where
disposeThread :: Promise [DisposeDependencies] -> [Disposer] -> IO ()
disposeThread :: Promise [DisposeDependencies] -> [DisposerElement] -> IO ()
disposeThread dependenciesVar attachedDisposers = do
-- Begin to dispose all attached resources
results <- mapM (atomically . resourceManagerBeginDispose) attachedDisposers
......@@ -233,8 +229,7 @@ beginDisposeResourceManagerInternal rm = do
rmKey :: Unique
rmKey = resourceManagerKey rm
resourceManagerBeginDispose :: Disposer -> STM DisposeResult
resourceManagerBeginDispose TrivialDisposer = pure $ DisposeResultAwait $ pure ()
resourceManagerBeginDispose :: DisposerElement -> STM DisposeResult
resourceManagerBeginDispose (FnDisposer _ worker exChan state finalizers) =
DisposeResultAwait <$> beginDisposeFnDisposer worker exChan state finalizers
resourceManagerBeginDispose (ResourceManagerDisposer resourceManager) =
......@@ -297,7 +292,7 @@ runFinalizersShortIO finalizers = unsafeShortIO $ atomically $ runFinalizers fin
runFinalizersAfter :: Finalizers -> Future () -> ShortIO ()
runFinalizersAfter finalizers awaitable = do
-- Peek awaitable to ensure trivial disposables always run without forking
-- Peek awaitable to ensure trivial disposers always run without forking
isCompleted <- isJust <$> peekFutureShortIO awaitable
if isCompleted
then
......@@ -306,6 +301,3 @@ runFinalizersAfter finalizers awaitable = do
void $ forkIOShortIO do
await awaitable
atomically $ runFinalizers finalizers
completedFinalizers :: Finalizers
completedFinalizers = unsafeDupablePerformIO $ Finalizers <$> newEmptyTMVarIO
......@@ -50,7 +50,7 @@ instance Ord Timer where
x `compare` y = time x `compare` time y
instance Resource Timer where
getDisposer Timer{disposer} = [disposer]
toDisposer Timer{disposer} = disposer
instance IsFuture () Timer where
toFuture Timer{completed} = toFuture completed
......@@ -66,7 +66,7 @@ data TimerScheduler = TimerScheduler {
}
instance Resource TimerScheduler where
getDisposer TimerScheduler{thread} = getDisposer thread
toDisposer TimerScheduler{thread} = toDisposer thread
data TimerSchedulerDisposed = TimerSchedulerDisposed
deriving stock (Eq, Show)
......
......@@ -161,7 +161,7 @@ data PosixTimer = PosixTimer {
}
instance Resource PosixTimer where
getDisposer timer = [(disposer timer)]
toDisposer PosixTimer{disposer} = disposer
newPosixTimer :: (MonadQuasar m, MonadIO m) => ClockId -> IO () -> m PosixTimer
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment