Require IO to create disposables

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

src/Quasar/Disposable.hs

@@ -2,7 +2,7 @@ module Quasar.Disposable (
   IsDisposable(..),
   Disposable,
   disposeIO,
-  mkDisposable,
+  newDisposable,
   synchronousDisposable,
   noDisposable,
 ) where

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

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

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}