{-# LANGUAGE RecursiveDo #-}
module Reactive.Threepenny.Memo (
    Memo, fromPure, memoize, at, liftMemo1, liftMemo2,
    ) where

import Data.IORef
import System.IO.Unsafe

{-----------------------------------------------------------------------------
    Memoize time-varying values / computations
------------------------------------------------------------------------------}
data Memo a
    = Const a
    | Memoized (IORef (MemoD a))

type MemoD a = Either (IO a) a

fromPure :: a -> Memo a
fromPure :: forall a. a -> Memo a
fromPure = a -> Memo a
forall a. a -> Memo a
Const

at :: Memo a -> IO a
at :: forall a. Memo a -> IO a
at (Const a
a)    = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
at (Memoized IORef (MemoD a)
r) = do
    MemoD a
memo <- IORef (MemoD a) -> IO (MemoD a)
forall a. IORef a -> IO a
readIORef IORef (MemoD a)
r
    case MemoD a
memo of
        Right a
a -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Left IO a
ma -> mdo
            IORef (MemoD a) -> MemoD a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (MemoD a)
r (MemoD a -> IO ()) -> MemoD a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> MemoD a
forall a b. b -> Either a b
Right a
a
            a
a <- IO a
ma    -- allow some recursion
            a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

memoize :: IO a -> Memo a
memoize :: forall a. IO a -> Memo a
memoize IO a
m = IO (Memo a) -> Memo a
forall a. IO a -> a
unsafePerformIO (IO (Memo a) -> Memo a) -> IO (Memo a) -> Memo a
forall a b. (a -> b) -> a -> b
$ IORef (MemoD a) -> Memo a
forall a. IORef (MemoD a) -> Memo a
Memoized (IORef (MemoD a) -> Memo a) -> IO (IORef (MemoD a)) -> IO (Memo a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MemoD a -> IO (IORef (MemoD a))
forall a. a -> IO (IORef a)
newIORef (IO a -> MemoD a
forall a b. a -> Either a b
Left IO a
m)

liftMemo1 :: (a -> IO b) -> Memo a -> Memo b
liftMemo1 :: forall a b. (a -> IO b) -> Memo a -> Memo b
liftMemo1 a -> IO b
f Memo a
ma = IO b -> Memo b
forall a. IO a -> Memo a
memoize (IO b -> Memo b) -> IO b -> Memo b
forall a b. (a -> b) -> a -> b
$ a -> IO b
f (a -> IO b) -> IO a -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Memo a -> IO a
forall a. Memo a -> IO a
at Memo a
ma

liftMemo2 :: (a -> b -> IO c) -> Memo a -> Memo b -> Memo c
liftMemo2 :: forall a b c. (a -> b -> IO c) -> Memo a -> Memo b -> Memo c
liftMemo2 a -> b -> IO c
f Memo a
ma Memo b
mb = IO c -> Memo c
forall a. IO a -> Memo a
memoize (IO c -> Memo c) -> IO c -> Memo c
forall a b. (a -> b) -> a -> b
$ do
    a
a <- Memo a -> IO a
forall a. Memo a -> IO a
at Memo a
ma
    b
b <- Memo b -> IO b
forall a. Memo a -> IO a
at Memo b
mb
    a -> b -> IO c
f a
a b
b