-- |
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
module Hails.Yampa where

import Control.Monad (when, void)
import Data.CBMVar
import Data.IORef
import Data.Maybe (fromJust)
import Data.ReactiveValue
import Data.Time.Clock
import FRP.Yampa

-- | Define a couple of RVs connected by an SF, so that
-- writing to one makes the SF process the value and make
-- the result available in a readable RV.
yampaReactiveDual :: a -> SF a b
                  -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual :: a -> SF a b -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual a
initial SF a b
sf = do
  CBMVar (Maybe b)
mvar <- Maybe b -> IO (CBMVar (Maybe b))
forall a. a -> IO (CBMVar a)
newCBMVar Maybe b
forall a. Maybe a
Nothing

  -- Initial clock
  UTCTime
initialClock <- IO UTCTime
getCurrentTime
  IORef UTCTime
lastTimeR    <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef UTCTime
initialClock

  -- Reactimation Handle
  ReactHandle a b
rh <- IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit
          -- Initial value
          (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
initial)
          -- Actuation
          (\ReactHandle a b
_ Bool
changed b
output -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CBMVar (Maybe b) -> Maybe b -> IO ()
forall a. CBMVar a -> a -> IO ()
writeCBMVar CBMVar (Maybe b)
mvar (b -> Maybe b
forall a. a -> Maybe a
Just b
output)
                                   Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          )
          -- Processing
          SF a b
sf

  -- RV fields
  let getter :: IO b
getter   = (Maybe b -> b) -> IO (Maybe b) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (IO (Maybe b) -> IO b) -> IO (Maybe b) -> IO b
forall a b. (a -> b) -> a -> b
$ CBMVar (Maybe b) -> IO (Maybe b)
forall a. CBMVar a -> IO a
readCBMVar CBMVar (Maybe b)
mvar
      setter :: a -> IO ()
setter a
y = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- Calculate time delta
                           UTCTime
newTime  <- IO UTCTime
getCurrentTime
                           UTCTime
lastTime <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastTimeR
                           let dt :: DTime
dt = NominalDiffTime -> DTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DTime) -> NominalDiffTime -> DTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
newTime UTCTime
lastTime
                           IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastTimeR UTCTime
newTime

                           -- Run FRP system
                           ReactHandle a b -> (DTime, Maybe a) -> IO Bool
forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a b
rh (DTime
dt, a -> Maybe a
forall a. a -> Maybe a
Just a
y)

      notifier :: IO () -> IO ()
notifier IO ()
evH = CBMVar (Maybe b) -> IO () -> IO ()
forall a. CBMVar a -> IO () -> IO ()
installCallbackCBMVar CBMVar (Maybe b)
mvar IO ()
evH

  let rvRead :: ReactiveFieldRead IO b
rvRead  = IO b -> (IO () -> IO ()) -> ReactiveFieldRead IO b
forall (m :: * -> *) a.
FieldGetter m a -> FieldNotifier m a -> ReactiveFieldRead m a
ReactiveFieldRead IO b
getter IO () -> IO ()
notifier
      rvWrite :: ReactiveFieldWrite IO a
rvWrite = (a -> IO ()) -> ReactiveFieldWrite IO a
forall (m :: * -> *) a. FieldSetter m a -> ReactiveFieldWrite m a
ReactiveFieldWrite a -> IO ()
setter

  (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
-> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldWrite IO a
rvWrite, ReactiveFieldRead IO b
rvRead)

-- | Create an RV that processes the value
-- with an SF every time it is written.
yampaReactive :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive a
initial SF a a
sf = do
  CBMVar a
mvar <- a -> IO (CBMVar a)
forall a. a -> IO (CBMVar a)
newCBMVar a
initial

  -- Initial clock
  UTCTime
initialClock <- IO UTCTime
getCurrentTime
  IORef UTCTime
lastTimeR    <- UTCTime -> IO (IORef UTCTime)
forall a. a -> IO (IORef a)
newIORef UTCTime
initialClock

  -- Reactimation Handle
  ReactHandle a a
rh <- IO a
-> (ReactHandle a a -> Bool -> a -> IO Bool)
-> SF a a
-> IO (ReactHandle a a)
forall a b.
IO a
-> (ReactHandle a b -> Bool -> b -> IO Bool)
-> SF a b
-> IO (ReactHandle a b)
reactInit
          -- Initial value
          (CBMVar a -> IO a
forall a. CBMVar a -> IO a
readCBMVar CBMVar a
mvar)
          -- Actuation
          (\ReactHandle a a
_ Bool
changed a
output -> do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CBMVar a -> a -> IO ()
forall a. CBMVar a -> a -> IO ()
writeCBMVar CBMVar a
mvar a
output
                                   Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          )
          -- Processing
          SF a a
sf

  -- RV fields
  let getter :: IO a
getter   = CBMVar a -> IO a
forall a. CBMVar a -> IO a
readCBMVar CBMVar a
mvar
      setter :: a -> IO ()
setter a
y = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do -- Calculate time delta
                           UTCTime
newTime  <- IO UTCTime
getCurrentTime
                           UTCTime
lastTime <- IORef UTCTime -> IO UTCTime
forall a. IORef a -> IO a
readIORef IORef UTCTime
lastTimeR
                           let dt :: DTime
dt = NominalDiffTime -> DTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> DTime) -> NominalDiffTime -> DTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
newTime UTCTime
lastTime
                           IORef UTCTime -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastTimeR UTCTime
newTime

                           -- Run FRP system
                           ReactHandle a a -> (DTime, Maybe a) -> IO Bool
forall a b. ReactHandle a b -> (DTime, Maybe a) -> IO Bool
react ReactHandle a a
rh (DTime
dt, a -> Maybe a
forall a. a -> Maybe a
Just a
y)

      notifier :: IO () -> IO ()
notifier = CBMVar a -> IO () -> IO ()
forall a. CBMVar a -> IO () -> IO ()
installCallbackCBMVar CBMVar a
mvar

  ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a))
-> ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall a b. (a -> b) -> a -> b
$ (a -> IO ())
-> IO a -> (IO () -> IO ()) -> ReactiveFieldReadWrite IO a
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite a -> IO ()
setter IO a
getter IO () -> IO ()
notifier

-- | Alternative (simpler) definition to 'yampaReactive'
yampaReactive' :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive' :: a -> SF a a -> IO (ReactiveFieldReadWrite IO a)
yampaReactive' a
initial SF a a
sf = do
  (ReactiveFieldWrite IO a
rvW, ReactiveFieldRead IO a
rvR) <- a -> SF a a -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO a)
forall a b.
a -> SF a b -> IO (ReactiveFieldWrite IO a, ReactiveFieldRead IO b)
yampaReactiveDual a
initial SF a a
sf
  ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a))
-> ReactiveFieldReadWrite IO a -> IO (ReactiveFieldReadWrite IO a)
forall a b. (a -> b) -> a -> b
$ ReactiveFieldRead IO a
-> ReactiveFieldWrite IO a -> ReactiveFieldReadWrite IO a
forall r1 a (m :: * -> *) r2.
(ReactiveValueRead r1 a m, ReactiveValueWrite r2 a m) =>
r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite ReactiveFieldRead IO a
rvR ReactiveFieldWrite IO a
rvW

-- | To be moved to Data.ReactiveValue
combineRVReadWrite :: (ReactiveValueRead r1 a m,  ReactiveValueWrite r2 a m)
                   => r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite :: r1 -> r2 -> ReactiveFieldReadWrite m a
combineRVReadWrite r1
rvR r2
rvW = FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter m a
setter FieldGetter m a
getter FieldNotifier m a
notifier
  where getter :: FieldGetter m a
getter   = r1 -> FieldGetter m a
forall a b (m :: * -> *). ReactiveValueRead a b m => a -> m b
reactiveValueRead r1
rvR
        setter :: FieldSetter m a
setter   = r2 -> FieldSetter m a
forall a b (m :: * -> *).
ReactiveValueWrite a b m =>
a -> b -> m ()
reactiveValueWrite r2
rvW
        notifier :: FieldNotifier m a
notifier = r1 -> FieldNotifier m a
forall a b (m :: * -> *).
ReactiveValueRead a b m =>
a -> m () -> m ()
reactiveValueOnCanRead r1
rvR