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

import Control.Monad
import Data.Functor
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
Const

at :: Memo a -> IO a
at :: forall a. Memo a -> IO a
at (Const a
a)    = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
at (Memoized IORef (MemoD a)
r) = do
    MemoD a
memo <- forall a. IORef a -> IO a
readIORef IORef (MemoD a)
r
    case MemoD a
memo of
        Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Left IO a
ma -> mdo
            forall a. IORef a -> a -> IO ()
writeIORef IORef (MemoD a)
r forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
a
            a
a <- IO a
ma    -- allow some recursion
            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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef (MemoD a) -> Memo a
Memoized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (IORef a)
newIORef (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 = forall a. IO a -> Memo a
memoize forall a b. (a -> b) -> a -> b
$ a -> IO b
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall a. IO a -> Memo a
memoize forall a b. (a -> b) -> a -> b
$ do
    a
a <- forall a. Memo a -> IO a
at Memo a
ma
    b
b <- forall a. Memo a -> IO a
at Memo b
mb
    a -> b -> IO c
f a
a b
b