    {-----------------------------------------------------------------------------
        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