diff --git a/src/Quasar/Async.hs b/src/Quasar/Async.hs index 9cfbc46cc087e30967b582262c5e2e328f606475..08a2dd86f22a5316fff248b27d0ba281fcbe4e13 100644 --- a/src/Quasar/Async.hs +++ b/src/Quasar/Async.hs @@ -1,7 +1,6 @@ module Quasar.Async ( -- * Async/await MonadAsync(..), - async, -- * Task Task, @@ -21,7 +20,6 @@ import Control.Concurrent (ThreadId, forkIOWithUnmask, throwTo) import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.Reader -import Data.HashSet import Quasar.Awaitable import Quasar.Disposable import Quasar.Prelude @@ -76,10 +74,11 @@ instance MonadAsync (ReaderT ResourceManager IO) where -- Wait for task completion or failure. Tasks must not ignore `CancelTask` or this will hang. pure $ void (toAwaitable resultVar) `catchAll` const (pure ()) - liftUnmask :: (IO a -> IO a) -> (ReaderT ResourceManager IO) a -> (ReaderT ResourceManager IO) a - liftUnmask unmask action = do - resourceManager <- askResourceManager - liftIO $ unmask $ runReaderT action resourceManager +-- | Lift an "unmask" action (e.g. from `mask`) into a `ReaderT`. +liftUnmask :: (IO a -> IO a) -> (ReaderT r IO) a -> (ReaderT r IO) a +liftUnmask unmask action = do + value <- ask + liftIO $ unmask $ runReaderT action value diff --git a/src/Quasar/Awaitable.hs b/src/Quasar/Awaitable.hs index 3d24bbd37173250da085fd599cce5f93e0024c8a..931a39b18fd4ce2742f79d867fef5b8cced2eef3 100644 --- a/src/Quasar/Awaitable.hs +++ b/src/Quasar/Awaitable.hs @@ -144,7 +144,7 @@ instance IsAwaitable r (MonadicAwaitable r) where runAwaitable (MonadicAwaitable x) = x cacheAwaitable = cacheAwaitableDefaultImplementation -mkMonadicAwaitable :: MonadAwait m => (forall m. (MonadQuerySTM m) => m r) -> m r +mkMonadicAwaitable :: MonadAwait m => (forall f. (MonadQuerySTM f) => f r) -> m r mkMonadicAwaitable fn = await $ MonadicAwaitable fn @@ -239,7 +239,7 @@ data AwaitableStepM a instance Functor AwaitableStepM where fmap fn (AwaitableCompleted x) = AwaitableCompleted (fn x) - fmap fn (AwaitableFailed ex) = AwaitableFailed ex + fmap _ (AwaitableFailed ex) = AwaitableFailed ex fmap fn (AwaitableStep query next) = AwaitableStep query (fmap fn <$> next) instance Applicative AwaitableStepM where @@ -248,7 +248,7 @@ instance Applicative AwaitableStepM where instance Monad AwaitableStepM where (AwaitableCompleted x) >>= fn = fn x - (AwaitableFailed ex) >>= fn = AwaitableFailed ex + (AwaitableFailed ex) >>= _ = AwaitableFailed ex (AwaitableStep query next) >>= fn = AwaitableStep query (next >=> fn) instance MonadQuerySTM AwaitableStepM where diff --git a/src/Quasar/Disposable.hs b/src/Quasar/Disposable.hs index 86d46e9735829940c2659b15b133fc64f4312225..89291043e3521fdab94f229e4568074ecbbbe2cf 100644 --- a/src/Quasar/Disposable.hs +++ b/src/Quasar/Disposable.hs @@ -28,7 +28,7 @@ import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.Reader import Data.Foldable (toList) -import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isJust) import Data.Sequence import Data.Sequence qualified as Seq @@ -214,7 +214,7 @@ instance MonadIO m => MonadResourceManager (ReaderT ResourceManager m) where askResourceManager = ask -onResourceManager :: (HasResourceManager a, MonadIO m) => a -> ReaderT ResourceManager m r -> m r +onResourceManager :: (HasResourceManager a) => a -> ReaderT ResourceManager m r -> m r onResourceManager target action = runReaderT action (getResourceManager target) @@ -233,8 +233,8 @@ instance IsDisposable ResourceManager where dispose' :: IO (Awaitable ()) dispose' = do entries <- atomically do - alreadyDisposing <- swapTVar (disposingVar resourceManager) True - if not alreadyDisposing + isAlreadyDisposing <- swapTVar (disposingVar resourceManager) True + if not isAlreadyDisposing then readTVar (entriesVar resourceManager) else pure Empty @@ -310,7 +310,7 @@ collectGarbage resourceManager = go -- Filter completed entries allEntries <- readTVar entriesVar' - filteredEntries <- foldM (\acc entry -> entryIsEmpty entry >>= \empty -> pure if empty then acc else acc |> entry) Empty allEntries + filteredEntries <- foldM (\acc entry -> entryIsEmpty entry >>= \isEmpty -> pure if isEmpty then acc else acc |> entry) Empty allEntries writeTVar entriesVar' filteredEntries if disposing && Seq.null filteredEntries @@ -336,7 +336,7 @@ attachDisposable resourceManager disposable = liftIO $ mask \unmask -> do entry <- newEntry disposable join $ atomically do - mapM throwM =<< tryReadTMVar (exceptionVar resourceManager) + mapM_ throwM =<< tryReadTMVar (exceptionVar resourceManager) disposed <- readTVar (disposedVar resourceManager) when disposed $ throwM (userError "Cannot attach a disposable to a disposed resource manager") diff --git a/src/Quasar/Timer.hs b/src/Quasar/Timer.hs index b05bfaa1222837542bf2d2f64b8c169931bccc69..32a5ef6b8b571b1ff28705940f3646cbdc50d6db 100644 --- a/src/Quasar/Timer.hs +++ b/src/Quasar/Timer.hs @@ -19,9 +19,7 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad.Catch import Data.Heap -import Data.Ord (comparing) -import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Data.Foldable (toList) import Quasar.Async import Quasar.Awaitable @@ -140,8 +138,8 @@ startSchedulerThread scheduler = do where nextTimerChanged :: Awaitable () nextTimerChanged = unsafeAwaitSTM do - min <- Data.Heap.minimum <$> readTVar heap' - unless (min /= nextTimer) retry + minTimer <- Data.Heap.minimum <$> readTVar heap' + unless (minTimer /= nextTimer) retry fireTimers :: UTCTime -> IO () fireTimers now = atomically do @@ -207,4 +205,4 @@ newDelay resourceManager microseconds = onResourceManager resourceManager $ Dela -- From package `extra` mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM op = foldr f (pure []) - where f x xs = do x <- op x; case x of Nothing -> xs; Just x -> do xs <- xs; pure $ x:xs + where f x xs = do y <- op x; case y of Nothing -> xs; Just z -> do ys <- xs; pure $ z:ys diff --git a/test/Quasar/DisposableSpec.hs b/test/Quasar/DisposableSpec.hs index 54ab509b867fb01497496bcfbc3bea2153d569fd..ad3ab96f3c1ad6f7cd1bb52e13e9f90af6a6482b 100644 --- a/test/Quasar/DisposableSpec.hs +++ b/test/Quasar/DisposableSpec.hs @@ -2,7 +2,6 @@ module Quasar.DisposableSpec (spec) where import Control.Exception import Control.Concurrent -import Control.Monad (void) import Quasar.Prelude import Test.Hspec import Quasar.Awaitable