{----------------------------------------------------------------------------- reactive-banana ------------------------------------------------------------------------------} {-# LANGUAGE RecursiveDo #-} module Reactive.Banana.Prim.Cached ( -- | Utility for executing monadic actions once -- and then retrieving values from a cache. -- -- Very useful for observable sharing. Cached, runCached, cache, fromPure, don'tCache, liftCached1, liftCached2, ) where import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.IORef import System.IO.Unsafe (unsafePerformIO) {----------------------------------------------------------------------------- Cache type ------------------------------------------------------------------------------} data Cached m a = Cached (m a) runCached :: Cached m a -> m a runCached :: Cached m a -> m a runCached (Cached m a x) = m a x -- | An action whose result will be cached. -- Executing the action the first time in the monad will -- execute the side effects. From then on, -- only the generated value will be returned. {-# NOINLINE cache #-} cache :: (MonadFix m, MonadIO m) => m a -> Cached m a cache :: m a -> Cached m a cache m a m = IO (Cached m a) -> Cached m a forall a. IO a -> a unsafePerformIO (IO (Cached m a) -> Cached m a) -> IO (Cached m a) -> Cached m a forall a b. (a -> b) -> a -> b $ do IORef (Maybe a) key <- IO (IORef (Maybe a)) -> IO (IORef (Maybe a)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (IORef (Maybe a)) -> IO (IORef (Maybe a))) -> IO (IORef (Maybe a)) -> IO (IORef (Maybe a)) forall a b. (a -> b) -> a -> b $ Maybe a -> IO (IORef (Maybe a)) forall a. a -> IO (IORef a) newIORef Maybe a forall a. Maybe a Nothing Cached m a -> IO (Cached m a) forall (m :: * -> *) a. Monad m => a -> m a return (Cached m a -> IO (Cached m a)) -> Cached m a -> IO (Cached m a) forall a b. (a -> b) -> a -> b $ m a -> Cached m a forall (m :: * -> *) a. m a -> Cached m a Cached (m a -> Cached m a) -> m a -> Cached m a forall a b. (a -> b) -> a -> b $ do Maybe a ma <- IO (Maybe a) -> m (Maybe a) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Maybe a) -> m (Maybe a)) -> IO (Maybe a) -> m (Maybe a) forall a b. (a -> b) -> a -> b $ IORef (Maybe a) -> IO (Maybe a) forall a. IORef a -> IO a readIORef IORef (Maybe a) key -- read the cached result case Maybe a ma of Just a a -> a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a a -- return the cached result. Maybe a Nothing -> mdo IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ -- write the result already IORef (Maybe a) -> Maybe a -> IO () forall a. IORef a -> a -> IO () writeIORef IORef (Maybe a) key (a -> Maybe a forall a. a -> Maybe a Just a a) a a <- m a m -- evaluate a -> m a forall (m :: * -> *) a. Monad m => a -> m a return a a -- | Return a pure value. Doesn't make use of the cache. fromPure :: Monad m => a -> Cached m a fromPure :: a -> Cached m a fromPure = m a -> Cached m a forall (m :: * -> *) a. m a -> Cached m a Cached (m a -> Cached m a) -> (a -> m a) -> a -> Cached m a forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> m a forall (m :: * -> *) a. Monad m => a -> m a return -- | Lift an action that is /not/ cached, for instance because it is idempotent. don'tCache :: Monad m => m a -> Cached m a don'tCache :: m a -> Cached m a don'tCache = m a -> Cached m a forall (m :: * -> *) a. m a -> Cached m a Cached liftCached1 :: (MonadFix m, MonadIO m) => (a -> m b) -> Cached m a -> Cached m b liftCached1 :: (a -> m b) -> Cached m a -> Cached m b liftCached1 a -> m b f Cached m a ca = m b -> Cached m b forall (m :: * -> *) a. (MonadFix m, MonadIO m) => m a -> Cached m a cache (m b -> Cached m b) -> m b -> Cached m b forall a b. (a -> b) -> a -> b $ do a a <- Cached m a -> m a forall (m :: * -> *) a. Cached m a -> m a runCached Cached m a ca a -> m b f a a liftCached2 :: (MonadFix m, MonadIO m) => (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c liftCached2 :: (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c liftCached2 a -> b -> m c f Cached m a ca Cached m b cb = m c -> Cached m c forall (m :: * -> *) a. (MonadFix m, MonadIO m) => m a -> Cached m a cache (m c -> Cached m c) -> m c -> Cached m c forall a b. (a -> b) -> a -> b $ do a a <- Cached m a -> m a forall (m :: * -> *) a. Cached m a -> m a runCached Cached m a ca b b <- Cached m b -> m b forall (m :: * -> *) a. Cached m a -> m a runCached Cached m b cb a -> b -> m c f a a b b