Streamline Disposer interface

Co-authored-by: Jan Beinke <git@janbeinke.com>

src/Quasar/Async.hs

@@ -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

src/Quasar/MonadQuasar.hs

@@ -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

src/Quasar/Observable.hs

@@ -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 =

src/Quasar/Resources.hs

@@ -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
 
 

src/Quasar/Resources/Disposer.hs

@@ -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

src/Quasar/Timer.hs

@@ -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)

src/Quasar/Timer/PosixTimer.hsc

@@ -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