module FRP.Euphoria.Update
( Update(..)
, updateUseAll
, updateUseLast
, updateUseAllIO
, stepperUpdate
, discreteToUpdate
, mappendUpdateIO
, startUpdateNetwork
, startUpdateNetworkWithValue
, IOMonoid(..)
) where
import Control.Applicative
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.Monoid
import Data.Unique
import Unsafe.Coerce
import FRP.Euphoria.Event
data Update a = forall s. (Monoid s) => Update (s -> a) (Event s)
instance Functor Update where
f `fmap` Update final evt = Update (f . final) evt
instance Applicative Update where
pure x = Update (const x) (mempty :: Event ())
Update f_final f_evt <*> Update a_final a_evt = Update
(\(f_s, a_s) -> f_final f_s (a_final a_s))
((left <$> f_evt) `mappend` (right <$> a_evt))
where
left f = (f, mempty)
right a = (mempty, a)
instance (Monoid a) => Monoid (Update a) where
mempty = Update (\() -> mempty) mempty
Update f x `mappend` Update g y = Update
(\(s0, s1) -> f s0 `mappend` g s1)
((left <$> x) `mappend` (right <$> y))
where
left val = (val, mempty)
right val = (mempty, val)
updateUseAll :: (Monoid a) => Event a -> Update a
updateUseAll evt = Update id evt
updateUseLast :: Event a -> Update (Maybe a)
updateUseLast evt = Update getLast (Last . Just <$> evt)
stepperUpdate :: a -> Event a -> Update a
stepperUpdate initial aE = fromMaybe initial <$> updateUseLast aE
discreteToUpdate :: MonadSignalGen m => Discrete a -> m (Update (Maybe a))
discreteToUpdate aD = updateUseLast <$> preservesD aD
updateUseAllIO :: Monoid a => Event (IO a) -> Update (IO a)
updateUseAllIO ioE = unIOMonoid <$> updateUseAll (IOMonoid <$> ioE)
mappendUpdateIO :: Monoid a => Update (IO a) -> Update (IO a) -> Update (IO a)
mappendUpdateIO d1 d2 = unIOMonoid <$> ((IOMonoid <$> d1) `mappend` (IOMonoid <$> d2))
mappendUpdateIOUnit :: Update (IO ()) -> Update (IO ()) -> Update (IO ())
mappendUpdateIOUnit = liftA2 (>>)
instance (Monoid a) => SignalSet (Update a) where
basicSwitchD dis = do
updatesE <- preservesD dis
dynUpdatesE <- mapEIO mkDynUpdates updatesE
dynUpdatesD <- stepperD undefined dynUpdatesE
dynE <- switchD dynUpdatesD
initial <- liftSignalGen $ execute newDynUpdateState
return $ Update (applyDynUpdates initial) dynE
where
applyDynUpdates initial (Dual (Endo f)) = case f initial of
DUS toFinal _ acc accFinal -> accFinal `mappend` toFinal acc
memoizeSignalSet = return
mkDynUpdates :: (Monoid a) => Update a -> IO (Event (DynUpdate a))
mkDynUpdates _upd@(Update toFinal evt) = do
u <- newUnique
return $ toUpdate u <$> evt
where
toUpdate u x = Dual $ Endo $ \(DUS currentToFinal current accCurrent accFinal) ->
if current /= u
then
DUS toFinal u x (mappend accFinal (currentToFinal accCurrent))
else
DUS currentToFinal current (mappend accCurrent x') accFinal
where
x' = unsafeCoerce x
newDynUpdateState :: (Monoid a) => IO (DynUpdateState a)
newDynUpdateState = do
u <- newUnique
return $! DUS (const mempty) u () mempty
type DynUpdate a = Dual (Endo (DynUpdateState a))
data DynUpdateState a =
forall s. (Monoid s) => DUS
(s -> a)
!Unique
!s
!a
newtype IOMonoid a = IOMonoid {unIOMonoid :: IO a}
instance (Monoid a) => Monoid (IOMonoid a) where
mempty = IOMonoid (return mempty)
IOMonoid x `mappend` IOMonoid y =
IOMonoid $ do
x' <- x
y' <- y
return (x' `mappend` y')
data Changes a = forall s. (Monoid s) => Changes (s -> a) s
startUpdateNetwork
:: SignalGen (Update a)
-> IO (IO a, IO ())
startUpdateNetwork network = do
(sample, step) <- startUpdateNetworkWithValue network'
return (fst <$> sample, step)
where
network' = flip (,) (pure ()) <$> network
startUpdateNetworkWithValue :: SignalGen (Update a, Signal b) -> IO (IO (a, b), IO b)
startUpdateNetworkWithValue network = do
changesRef <- newIORef Nothing
valueRef <- newIORef undefined
sample <- start $ do
(update, signal) <- network
case update of
Update final updateE -> return $
(>>) <$> updateChanges <*> updateVal
where
updateChanges = updateRef changesRef final <$> eventToSignal updateE
updateVal = writeIORef valueRef <$> signal
return (join sample >> readBoth valueRef changesRef, join sample >> readIORef valueRef)
where
updateRef changesRef final occs = do
changes <- readIORef changesRef
writeIORef changesRef $! Just $! case changes of
Nothing -> Changes final newChanges
Just (Changes _ oldChanges) ->
let !allChanges = unsafeCoerce oldChanges `mappend` newChanges
in Changes final allChanges
where !newChanges = mconcat occs
readBoth valueRef changesRef =
(,) <$> takeChanges changesRef
<*> readIORef valueRef
takeChanges changesRef = do
changes <- readIORef changesRef
case changes of
Nothing -> error "FRP.Elerea.Extras.Update: bug: no changes"
Just (Changes final oldChanges) -> do
writeIORef changesRef Nothing
return $! final oldChanges