LegacyAdapters.hs

{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -Wall #-}
module FRP.Reactive.LegacyAdapters 
    ( BehaviorMachine(..)
    , makeBehaviorMachine
    , makeEvent, Sink
    -- * Deprecated and/or for testing.
    , forkE
    , forkB
    ) where

import Control.Compose ((:.)(O))
import Control.Concurrent(ThreadId)

import System.Time

import FRP.Reactive.Improving
import FRP.Reactive.Future
import FRP.Reactive.Fun
import FRP.Reactive.Reactive
import Data.Max
import Data.AddBounds

import qualified FRP.Reactive.Internal.Reactive as R
import FRP.Reactive.Internal.Misc (Sink)
import FRP.Reactive.Behavior (Behavior)
import FRP.Reactive.Internal.Behavior (BehaviorG(..))

import qualified FRP.Reactive.Internal.TVal as TVal
import FRP.Reactive.Internal.Clock


data BehaviorMachine a
    = BehaviorMachine { currentValue :: a
                      , currentTime :: TimeT
                      , waitChange :: IO (BehaviorMachine a)
                      }

makeBehaviorMachine :: ClockTime -> Behavior a -> IO (BehaviorMachine a)
makeBehaviorMachine refTime (Beh (O (R.Stepper initval ev))) = do
    clock <- makeClock refTime
    curTime <- currRelTime refTime
    return $ eventBehaviorMachine refTime clock initval curTime ev

eventBehaviorMachine :: ClockTime -> Clock TimeT 
                     -> Fun TimeT a -> TimeT -> Event (Fun TimeT a) -> BehaviorMachine a
eventBehaviorMachine refTime clock = go 
    where
    go initVal initTime event = 
        BehaviorMachine { currentValue = apply initVal initTime
                        , currentTime = initTime
                        , waitChange = do
                            let fut = eventOcc event
                            schedule clock (fromTime (futTime fut))
                            let (v,nexte) = futVal fut
                            curTime <- currRelTime refTime
                            return $ go v curTime nexte
                        }

fromTime :: Num a => Max (AddBounds (Improving a)) -> a
fromTime (Max MinBound) = 0
fromTime (Max (NoBound t)) = exact t
fromTime (Max MaxBound) = error "maxbound"


makeEvent :: ClockTime -> IO (Event a, Sink a)
makeEvent refTime = TVal.makeEvent =<< makeClock refTime

-- | Forks a behavior given a reference time and a time function sinker. This
-- function is deprecated, but will remain until something better, and working,
-- comes along.
forkB :: ClockTime -> -- The reference time
         Behavior a -> -- The behavior
         Sink (Fun TimeT a) -> -- An action that takes in a Fun of time to a
         IO ThreadId
forkB refTime (Beh (O r)) fSync = do
  clock <- makeClock refTime
  R.forkR (schedule clock . exact) (fmap fSync r)

-- | A version of forkE that acts more like makeEvent and uses Clock as a
-- basis.  Takes reference time and the event to fork.
forkE :: ClockTime    ->
         Event (IO a) ->
         IO ThreadId
forkE refTime e = do
  clock <- makeClock refTime
  R.forkE (schedule clock . exact) e