diff --git a/quasar.cabal b/quasar.cabal index a151df5e288f7ef3af7460edfc60d4ddbf6a165a..bbcd9f455a532345a508f8d5cae4e62d37024e49 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -78,6 +78,7 @@ library exposed-modules: Quasar.Awaitable Quasar.Core + Quasar.Disposable Quasar.Observable Quasar.Observable.Delta Quasar.Observable.ObservableHashMap diff --git a/src/Quasar/Core.hs b/src/Quasar/Core.hs index 15ffc90b780116b3c03cd0e2b6ee3c85f1512b40..863b7e8b98ed666dcfb89965f6921705bb2c74d6 100644 --- a/src/Quasar/Core.hs +++ b/src/Quasar/Core.hs @@ -11,13 +11,6 @@ module Quasar.Core ( newAsyncVar, putAsyncVar, - -- * Disposable - IsDisposable(..), - Disposable, - mkDisposable, - synchronousDisposable, - noDisposable, - -- * Cancellation withCancellationToken, ) where @@ -250,47 +243,3 @@ withCancellationToken action = do -- TODO test if it is better to run readMVar recursively or to keep it uninterruptible either throwIO pure =<< (unmask (readMVar resultMVar) `catchAll` (\ex -> cancel cancellationToken ex >> readMVar resultMVar)) - - --- * Disposable - -class IsDisposable a where - -- TODO document laws: must not throw exceptions, is idempotent - - -- | Dispose a resource. - dispose :: a -> AsyncIO () - - -- | Dispose a resource in the IO monad. - disposeIO :: a -> IO () - - toDisposable :: a -> Disposable - toDisposable = mkDisposable . dispose - -instance IsDisposable a => IsDisposable (Maybe a) where - dispose = mapM_ dispose - disposeIO = mapM_ disposeIO - - -newtype Disposable = Disposable (AsyncIO ()) - -instance IsDisposable Disposable where - dispose (Disposable fn) = fn - disposeIO = runAsyncIO . dispose - toDisposable = id - -instance Semigroup Disposable where - x <> y = mkDisposable $ liftA2 (<>) (dispose x) (dispose y) - -instance Monoid Disposable where - mempty = mkDisposable $ pure () - mconcat disposables = mkDisposable $ traverse_ dispose disposables - - -mkDisposable :: AsyncIO () -> Disposable -mkDisposable = Disposable - -synchronousDisposable :: IO () -> Disposable -synchronousDisposable = mkDisposable . liftIO - -noDisposable :: Disposable -noDisposable = mempty diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs new file mode 100644 index 0000000000000000000000000000000000000000..33eaaff804e3239dedf2cd0e2d3753d95bf826f0 --- /dev/null +++ b/src/Quasar/Disposable.hs @@ -0,0 +1,53 @@ +module Quasar.Disposable ( + IsDisposable(..), + Disposable, + mkDisposable, + synchronousDisposable, + noDisposable, +) where + +import Quasar.Core +import Quasar.Prelude + +-- * Disposable + +class IsDisposable a where + -- TODO document laws: must not throw exceptions, is idempotent + + -- | Dispose a resource. + dispose :: a -> AsyncIO () + + -- | Dispose a resource in the IO monad. + disposeIO :: a -> IO () + disposeIO = runAsyncIO . dispose + + toDisposable :: a -> Disposable + toDisposable = mkDisposable . dispose + +instance IsDisposable a => IsDisposable (Maybe a) where + dispose = mapM_ dispose + disposeIO = mapM_ disposeIO + + +newtype Disposable = Disposable (AsyncIO ()) + +instance IsDisposable Disposable where + dispose (Disposable fn) = fn + toDisposable = id + +instance Semigroup Disposable where + x <> y = mkDisposable $ liftA2 (<>) (dispose x) (dispose y) + +instance Monoid Disposable where + mempty = mkDisposable $ pure () + mconcat disposables = mkDisposable $ traverse_ dispose disposables + + +mkDisposable :: AsyncIO () -> Disposable +mkDisposable = Disposable + +synchronousDisposable :: IO () -> Disposable +synchronousDisposable = mkDisposable . liftIO + +noDisposable :: Disposable +noDisposable = mempty diff --git a/src/Quasar/Observable.hs b/src/Quasar/Observable.hs index e77f8cfa9e2acd765383a1c82efd140cb9256e55..4a4f812b4d1ed9aedde0b7f71bfb7589183bf67f 100644 --- a/src/Quasar/Observable.hs +++ b/src/Quasar/Observable.hs @@ -36,6 +36,7 @@ import Data.HashMap.Strict qualified as HM import Data.IORef import Data.Unique import Quasar.Core +import Quasar.Disposable import Quasar.Prelude diff --git a/src/Quasar/Observable/Delta.hs b/src/Quasar/Observable/Delta.hs index c2862b29ace039326da614874341a14cc983edb6..3adb77d2ae326beb603b5dcbcb6b922833d7f4c4 100644 --- a/src/Quasar/Observable/Delta.hs +++ b/src/Quasar/Observable/Delta.hs @@ -7,7 +7,7 @@ module Quasar.Observable.Delta ( import Data.Binary (Binary) import Data.Binary qualified as B import Data.HashMap.Strict qualified as HM -import Quasar.Core +import Quasar.Disposable import Quasar.Observable import Quasar.Prelude diff --git a/src/Quasar/Observable/ObservableHashMap.hs b/src/Quasar/Observable/ObservableHashMap.hs index b013f031dc641a6d39e004754d1222351fba2f85..a15712897232ab40a14edb81abf22933531372ea 100644 --- a/src/Quasar/Observable/ObservableHashMap.hs +++ b/src/Quasar/Observable/ObservableHashMap.hs @@ -15,6 +15,7 @@ import Data.Maybe (isJust) import Language.Haskell.TH.Syntax (mkName, nameBase) import Lens.Micro.Platform import Quasar.Core +import Quasar.Disposable import Quasar.Observable import Quasar.Observable.Delta import Quasar.Prelude hiding (lookup, lookupDelete) diff --git a/src/Quasar/Observable/ObservablePriority.hs b/src/Quasar/Observable/ObservablePriority.hs index 7c926e30c025f8f594e06a4d84f61628ce956c81..9184e2e6a368afa3cbbe539a9b2d8046ca89c320 100644 --- a/src/Quasar/Observable/ObservablePriority.hs +++ b/src/Quasar/Observable/ObservablePriority.hs @@ -9,7 +9,7 @@ import Data.List (maximumBy) import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Ord (comparing) -import Quasar.Core +import Quasar.Disposable import Quasar.Observable import Quasar.Prelude diff --git a/test/Quasar/Observable/ObservableHashMapSpec.hs b/test/Quasar/Observable/ObservableHashMapSpec.hs index 98848021dca7508cbb9faa484ace26f5907d41e6..f3cc07ee9acc4c61da5577922fd84bef643b0415 100644 --- a/test/Quasar/Observable/ObservableHashMapSpec.hs +++ b/test/Quasar/Observable/ObservableHashMapSpec.hs @@ -1,6 +1,7 @@ module Quasar.Observable.ObservableHashMapSpec (spec) where import Quasar.Core +import Quasar.Disposable import Quasar.Observable import Quasar.Observable.Delta import Quasar.Observable.ObservableHashMap qualified as OM diff --git a/test/Quasar/Observable/ObservablePrioritySpec.hs b/test/Quasar/Observable/ObservablePrioritySpec.hs index 4278a3b39deba99dbbb2465403a3899cd6f0028e..a09b9e38f205349db1b0505bb32b94e59fa877b3 100644 --- a/test/Quasar/Observable/ObservablePrioritySpec.hs +++ b/test/Quasar/Observable/ObservablePrioritySpec.hs @@ -1,6 +1,7 @@ module Quasar.Observable.ObservablePrioritySpec (spec) where import Quasar.Core +import Quasar.Disposable import Quasar.Observable import Quasar.Observable.ObservablePriority (ObservablePriority) import Quasar.Observable.ObservablePriority qualified as OP