diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for unliftio +## 0.2.8.0 + +* Add 'UnliftIO.Memoize' + ## 0.2.7.1 * Minor doc improvements diff --git a/src/UnliftIO.hs b/src/UnliftIO.hs --- a/src/UnliftIO.hs +++ b/src/UnliftIO.hs @@ -7,6 +7,7 @@ , module UnliftIO.Exception , module UnliftIO.IO , module UnliftIO.IORef + , module UnliftIO.Memoize , module UnliftIO.MVar , module UnliftIO.STM , module UnliftIO.Temporary @@ -19,6 +20,7 @@ import UnliftIO.Exception import UnliftIO.IO import UnliftIO.IORef +import UnliftIO.Memoize import UnliftIO.MVar import UnliftIO.STM import UnliftIO.Temporary diff --git a/src/UnliftIO/Memoize.hs b/src/UnliftIO/Memoize.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Memoize.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Memoize the results of actions. In other words: actions +-- will be run once, on demand, and their results saved. +-- +-- Exceptions semantics: if a synchronous exception is thrown while performing +-- the computation, that result will be saved and rethrown each time +-- 'runMemoized' is called subsequently.' +-- +-- @since 0.2.8.0 +module UnliftIO.Memoize + ( Memoized + , runMemoized + , memoizeRef + , memoizeMVar + ) where + +import Control.Applicative as A +import Control.Monad (join) +import Control.Monad.IO.Unlift +import UnliftIO.Exception +import UnliftIO.IORef +import UnliftIO.MVar + +-- | A \"run once\" value, with results saved. Extract the value with +-- 'runMemoized'. For single-threaded usage, you can use 'memoizeRef' to +-- create a value. If you need guarantees that only one thread will run the +-- action at a time, use 'memoizeMVar'. +-- +-- Note that this type provides a 'Show' instance for convenience, but not +-- useful information can be provided. +-- +-- @since 0.2.8.0 +newtype Memoized a = Memoized (IO a) + deriving (Functor, A.Applicative, Monad) +instance Show (Memoized a) where + show _ = "<>" + +-- | Extract a value from a 'Memoized', running an action if no cached value is +-- available. +-- +-- @since 0.2.8.0 +runMemoized :: MonadIO m => Memoized a -> m a +runMemoized (Memoized m) = liftIO m +{-# INLINE runMemoized #-} + +-- | Create a new 'Memoized' value using an 'IORef' under the surface. Note that +-- the action may be run in multiple threads simultaneously, so this may not be +-- thread safe (depending on the underlying action). Consider using +-- 'memoizeMVar'. +-- +-- @since 0.2.8.0 +memoizeRef :: MonadUnliftIO m => m a -> m (Memoized a) +memoizeRef action = withRunInIO $ \run -> do + ref <- newIORef Nothing + pure $ Memoized $ do + mres <- readIORef ref + res <- + case mres of + Just res -> pure res + Nothing -> do + res <- tryAny $ run action + writeIORef ref $ Just res + pure res + either throwIO pure res + +-- | Same as 'memoizeRef', but uses an 'MVar' to ensure that an action is +-- only run once, even in a multithreaded application. +-- +-- @since 0.2.8.0 +memoizeMVar :: MonadUnliftIO m => m a -> m (Memoized a) +memoizeMVar action = withRunInIO $ \run -> do + var <- newMVar Nothing + pure $ Memoized $ join $ modifyMVar var $ \mres -> do + res <- maybe (tryAny $ run action) pure mres + pure (Just res, either throwIO pure res) diff --git a/test/UnliftIO/MemoizeSpec.hs b/test/UnliftIO/MemoizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/UnliftIO/MemoizeSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module UnliftIO.MemoizeSpec (spec) where + +import Control.Concurrent (threadDelay) +import Control.Monad (replicateM_) +import Test.Hspec +import Test.Hspec.QuickCheck +import UnliftIO +import Data.Typeable + +data Dummy = Dummy + deriving (Show, Typeable) +instance Exception Dummy + +spec :: Spec +spec = do + let basics maker = do + prop "sanity" $ \i -> do + x <- maker $ return (i :: Int) + runMemoized x `shouldReturn` i + prop "runs once" $ \i -> do + count <- newIORef (0 :: Int) + x <- maker $ do + modifyIORef' count (+ 1) + return (i :: Int) + replicateM_ 10 $ runMemoized x `shouldReturn` i + readIORef count `shouldReturn` 1 + it "runs once with exception" $ do + count <- newIORef (0 :: Int) + x <- maker $ do + modifyIORef' count (+ 1) + throwIO Dummy + replicateM_ 10 $ runMemoized x `shouldThrow` (\Dummy -> True) + readIORef count `shouldReturn` 1 + describe "memoizeRef" $ basics memoizeRef + describe "memoizeMVar" $ do + basics memoizeMVar + prop "runs once in multiple threads" $ \i -> do + count <- newIORef (0 :: Int) + x <- memoizeMVar $ do + threadDelay 10000 + atomicModifyIORef' count $ \cnt -> (cnt + 1, ()) + return (i :: Int) + replicateConcurrently_ 10 $ runMemoized x `shouldReturn` i + readIORef count `shouldReturn` 1 diff --git a/unliftio.cabal b/unliftio.cabal --- a/unliftio.cabal +++ b/unliftio.cabal @@ -1,13 +1,13 @@ -cabal-version: >= 1.10 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.29.6. +-- This file has been generated from package.yaml by hpack version 0.30.0. -- -- see: https://github.com/sol/hpack -- --- hash: 80f98ec8618eddf5cd9e60732404c2af04ec9c97f9edefb9aa7b236b776e10ea +-- hash: 943e82967e90e314577381f82ab9a07663e77328d1364a19289e0c5637e3f2d6 name: unliftio -version: 0.2.7.1 +version: 0.2.8.0 synopsis: The MonadUnliftIO typeclass for unlifting monads to IO (batteries included) description: Please see the documentation and README at category: Control @@ -19,8 +19,8 @@ license-file: LICENSE build-type: Simple extra-source-files: - ChangeLog.md README.md + ChangeLog.md library hs-source-dirs: @@ -60,6 +60,7 @@ UnliftIO.Foreign UnliftIO.IO UnliftIO.IORef + UnliftIO.Memoize UnliftIO.MVar UnliftIO.Process UnliftIO.STM @@ -93,5 +94,6 @@ other-modules: UnliftIO.ExceptionSpec UnliftIO.IOSpec + UnliftIO.MemoizeSpec Paths_unliftio default-language: Haskell2010