{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
module Reactive.Banana.Prim.High.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.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 :: forall (m :: * -> *) a. 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 :: forall (m :: * -> *) a.
(MonadFix m, MonadIO m) =>
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
    key <- IO (IORef (Maybe a)) -> IO (IORef (Maybe a))
forall a. IO a -> IO 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
    return $ Cached $ do
        ma <- liftIO $ readIORef key    -- read the cached result
        case ma of
            Just a
a  -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a         -- return the cached result.
            Maybe a
Nothing -> mdo
                liftIO $                -- write the result already
                    writeIORef key (Just a)
                a <- m                  -- evaluate
                return a

-- | Return a pure value. Doesn't make use of the cache.
fromPure :: Monad m => a -> Cached m a
fromPure :: forall (m :: * -> *) a. Monad m => 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 a. 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 :: forall (m :: * -> *) a. Monad m => 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 :: forall (m :: * -> *) a b.
(MonadFix m, MonadIO m) =>
(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 <- Cached m a -> m a
forall (m :: * -> *) a. Cached m a -> m a
runCached Cached m a
ca
    f a

liftCached2 :: (MonadFix m, MonadIO m) =>
    (a -> b -> m c) -> Cached m a -> Cached m b -> Cached m c
liftCached2 :: forall (m :: * -> *) a b c.
(MonadFix m, MonadIO m) =>
(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 <- Cached m a -> m a
forall (m :: * -> *) a. Cached m a -> m a
runCached Cached m a
ca
    b <- runCached cb
    f a b