{-----------------------------------------------------------------------------
    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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    IORef (Maybe a)
key <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m a -> Cached m a
Cached forall a b. (a -> b) -> a -> b
$ do
        Maybe a
ma <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe a)
key    -- read the cached result
        case Maybe a
ma of
            Just a
a  -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a         -- return the cached result.
            Maybe a
Nothing -> mdo
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$                -- write the result already
                    forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe a)
key (forall a. a -> Maybe a
Just a
a)
                a
a <- m a
m                  -- evaluate
                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 :: forall (m :: * -> *) a. Monad m => a -> Cached m a
fromPure = forall (m :: * -> *) a. m a -> Cached m a
Cached forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 = forall (m :: * -> *) a.
(MonadFix m, MonadIO m) =>
m a -> Cached m a
cache forall a b. (a -> b) -> a -> b
$ do
    a
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 :: 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 = forall (m :: * -> *) a.
(MonadFix m, MonadIO m) =>
m a -> Cached m a
cache forall a b. (a -> b) -> a -> b
$ do
    a
a <- forall (m :: * -> *) a. Cached m a -> m a
runCached Cached m a
ca
    b
b <- forall (m :: * -> *) a. Cached m a -> m a
runCached Cached m b
cb
    a -> b -> m c
f a
a b
b