#if __GLASGOW_HASKELL__ <= 706
#else
#endif
module FRP.Euphoria.Event
(
Event
, externalEvent
, eachStep
, onCreation
, signalToEvent
, apply
, eventToSignal
, stepperS
, accumS
, accumSIO
, accumE
, accumEM
, scanAccumE
, scanAccumEM
, filterE
, justE
, mapMaybeE
, flattenE
, expandE
, withPrevE
, dropE
, dropWhileE
, takeE
, takeWhileE
, partitionEithersE
, leftE
, rightE
, groupByE
, groupWithInitialByE
, groupE
, groupWithInitialE
, splitOnE
, differentE
, delayE
, dropStepE
, mapEIO
, memoE
, joinEventSignal
, generatorE
, Discrete
, stepperD
, stepperMaybeD
, justD
, accumD
, eachStepD
, changesD
, preservesD
, snapshotD
, memoD
, delayD
, generatorD
, minimizeChanges
, discreteToSignal
, freezeD
, signalToDiscrete
, keepJustsD
, keepDJustsD
, module FRP.Euphoria.Signal
, Apply (..)
, (<$?>), (<?*?>), (<-*?>), (<?*->)
, EasyApply (..)
, switchD
, switchDE
, switchDS
, generatorD'
, SignalSet (..)
, forceD
, forceE
, rnfD
, rnfE
, traceSignalMaybe
, traceSignalT
, traceEventT
, traceDiscreteT
, signalFromList
, eventFromList
, networkToList
) where
import Control.Arrow ((&&&))
import Control.Applicative
import Control.DeepSeq
import Control.Monad (join, replicateM)
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Either (partitionEithers, lefts, rights)
import Data.List (foldl')
import Data.Monoid
import Data.Maybe
import Data.Typeable
import Debug.Trace
import FRP.Euphoria.Signal
import FRP.Elerea.Simple.Compat (externalMulti, effectful1, till, stateful)
import Prelude hiding (until)
newtype Event a = Event (Signal [a])
deriving (Functor, Typeable)
newtype Discrete a = Discrete (Signal (Bool, a))
deriving (Functor, Typeable)
instance Monoid (Event a) where
mempty = Event $ pure []
Event a `mappend` Event b = Event $ (++) <$> a <*> b
infixl 4 <@>, <@
class (Functor f, Functor g) => Apply f g where
(<@>) :: f (a -> b) -> g a -> g b
(<@) :: f a -> g b -> g a
f <@ g = const <$> f <@> g
instance Apply Signal Event where
(<@>) = apply
externalEvent :: (MonadSignalGen g, MonadIO m, MonadIO m') => m (g (Event a), a -> m' ())
externalEvent = liftIO $ do
(gen, trigger) <- externalMulti
return (Event . fmap reverse <$> liftSignalGen gen, liftIO . trigger)
apply :: Signal (a -> b) -> Event a -> Event b
apply sig (Event evt) = Event $ map <$> sig <*> evt
filterE :: (a -> Bool) -> Event a -> Event a
filterE cond (Event evt) = Event $ filter cond <$> evt
stepperS :: MonadSignalGen m => a -> Event a -> m (Signal a)
stepperS initial (Event evt) = transferS initial upd evt
where
upd [] old = old
upd occs _ = last occs
eachStep :: Signal a -> Event a
eachStep = Event . fmap (:[])
eachStepD :: MonadSignalGen m => Discrete a -> m (Event a)
eachStepD d = do
sig <- discreteToSignal d
return $ eachStep sig
accumS :: MonadSignalGen m => a -> Event (a -> a) -> m (Signal a)
accumS initial (Event evt) = transferS initial upd evt
where
upd occs old = foldl' (flip ($)) old occs
accumSIO :: (MonadSignalGen m) => a -> Event (a -> IO a) -> m (Signal a)
accumSIO initial (Event evt) = mfix $ \self -> do
prev <- delayS initial self
liftSignalGen $ effectful1 id $ update <$> prev <*> evt
where
update prev upds = foldl' (>>=) (return prev) upds
accumE :: (MonadSignalGen m) => a -> Event (a -> a) -> m (Event a)
accumE initial (Event evt) = fmap Event $ do
(_, occs) <- mfix $ \ ~(self, _) -> do
prev <- delayS initial self
vs <- memoS $ scanl (flip ($)) <$> prev <*> evt
return (last <$> vs, tail <$> vs)
return occs
scanAccumE :: MonadSignalGen m => s -> Event (s -> (s, a)) -> m (Event a)
scanAccumE initial ev = (snd <$>) <$> accumE (initial, undefined) (f <$> ev)
where
f fn (s, _) = fn s
accumEM :: (MonadSignalGen m) => s -> Event (s -> SignalGen s) -> m (Event s)
accumEM initial (Event evt) = fmap Event $ do
rec
prevState <- delayS initial (fst <$> state_out)
state_out <- generatorS $ stateGen <$> prevState <*> evt
memoS $ snd <$> state_out
where
stateGen prev occs = foldr app end occs prev []
app occ next val history = do
val' <- occ val
next val' (val':history)
end val history = return (val, reverse history)
scanAccumEM :: MonadSignalGen m => s -> Event (s -> SignalGen (s, a)) -> m (Event a)
scanAccumEM initial ev = (snd <$>) <$> accumEM (initial, undefined) (f <$> ev)
where
f fn (s, _) = fn s
dropStepE :: MonadSignalGen m => Event a -> m (Event a)
dropStepE ev = do
initial <- delayS True (pure False)
memoE $ justE $ discardIf <$> initial <@> ev
where
discardIf True _ = Nothing
discardIf False x = Just x
flattenE :: Event [a] -> Event a
flattenE (Event evt) = Event $ concat <$> evt
expandE :: Event a -> Event [a]
expandE (Event evt) = Event $ f <$> evt
where
f [] = []
f xs = [xs]
mapEIO :: MonadSignalGen m => (t -> IO a) -> Event t -> m (Event a)
mapEIO mkAction (Event evt) = Event <$> liftSignalGen (effectful1 (mapM mkAction) evt)
memoE :: MonadSignalGen m => Event a -> m (Event a)
memoE (Event evt) = Event <$> memoS evt
joinEventSignal :: Signal (Event a) -> Event a
joinEventSignal sig = Event $ do
Event occs <- sig
occs
justE :: Event (Maybe a) -> Event a
justE (Event evt) = Event $ catMaybes <$> evt
mapMaybeE :: (a -> Maybe b) -> Event a -> Event b
mapMaybeE f evt = justE $ f <$> evt
onCreation :: MonadSignalGen m => a -> m (Event a)
onCreation x = Event <$> delayS [x] (return [])
delayE :: MonadSignalGen m => Event a -> m (Event a)
delayE (Event x) = Event <$> delayS [] x
withPrevE :: MonadSignalGen m => a -> Event a -> m (Event (a, a))
withPrevE initial evt = accumE (initial, undefined) $ toUpd <$> evt
where
toUpd val (new, _old) = (val, new)
generatorE :: MonadSignalGen m => Event (SignalGen a) -> m (Event a)
generatorE (Event evt) = Event <$> generatorS (sequence <$> evt)
dropE :: MonadSignalGen m => Int -> Event a -> m (Event a)
dropE n (Event evt) = Event . fmap fst <$> transferS ([], n) upd evt
where
upd occs (_, k)
| k <= 0 = (occs, 0)
| otherwise = let
!k' = k length occs
in (drop k occs, k')
dropWhileE :: MonadSignalGen m => (a -> Bool) -> Event a -> m (Event a)
dropWhileE p (Event evt) = Event . fmap fst <$> transferS ([], False) upd evt
where
upd occs (_, True) = (occs, True)
upd occs (_, False) = case span p occs of
(_, []) -> ([], False)
(_, rest) -> (rest, True)
takeE :: MonadSignalGen m => Int -> Event a -> m (Event a)
takeE n evt = generalPrefixE (primTakeE n) evt
primTakeE :: MonadSignalGen m => Int -> Signal [a] -> m (Signal (Bool, [a]))
primTakeE n evt = fmap fst <$> transferS ((True, []), n) upd evt
where
upd occs (_, k) = ((k > 0, take k occs), k')
where
!k' = k length occs
takeWhileE :: MonadSignalGen m => (a -> Bool) -> Event a -> m (Event a)
takeWhileE p evt = generalPrefixE (primTakeWhileE p) evt
primTakeWhileE :: MonadSignalGen m => (a -> Bool) -> Signal [a] -> m (Signal (Bool, [a]))
primTakeWhileE p evt = memoS $ f <$> evt
where
f occs = case span p occs of
(_, []) -> (True, occs)
(end, _) -> (False, end)
generalPrefixE
:: MonadSignalGen m
=> (Signal [a] -> m (Signal (Bool, [a])))
-> Event a
-> m (Event a)
generalPrefixE prefixTaker (Event evt) = do
rec
done <- liftSignalGen $ till $ not . fst <$> active_occs
prevDone <- delayS False done
eventSource <- transferS evt upd prevDone
active_occs <- prefixTaker (join eventSource)
Event <$> memoS (snd <$> active_occs)
where
upd done prev = ifelse done (pure []) prev
ifelse b x y = if b then x else y
partitionEithersE :: MonadSignalGen m => Event (Either a b) -> m (Event a, Event b)
partitionEithersE (Event eithersS) = (Event . fmap fst &&& Event . fmap snd)
<$> memoS (partitionEithers <$> eithersS)
leftE :: Event (Either e a) -> Event e
leftE (Event eithersS) = Event (lefts <$> eithersS)
rightE :: Event (Either e a) -> Event a
rightE (Event eithersS) = Event (rights <$> eithersS)
groupByE :: MonadSignalGen m => (a -> a -> Bool) -> Event a -> m (Event (Event a))
groupByE eqv sourceEvt = fmap snd <$> groupWithInitialByE eqv sourceEvt
groupWithInitialByE :: MonadSignalGen m => (a -> a -> Bool) -> Event a -> m (Event (a, Event a))
groupWithInitialByE eqv sourceEvt = do
networkE <- justE <$> scanAccumE Nothing (makeNetwork <$> sourceEvt)
generatorE networkE
where
makeNetwork val currentVal
| maybe False (eqv val) currentVal = (currentVal, Nothing)
| otherwise = (Just val, Just $ (,) val <$> network val)
network val = takeWhileE (eqv val) =<< dropWhileE (not . eqv val) sourceEvt
groupE :: (Eq a, MonadSignalGen m) => Event a -> m (Event (Event a))
groupE = groupByE (==)
groupWithInitialE :: (Eq a, MonadSignalGen m) => Event a -> m (Event (a, Event a))
groupWithInitialE = groupWithInitialByE (==)
splitOnE :: MonadSignalGen m => Event () -> Event a -> m (Event [a])
splitOnE completeE aE = do
let inE = (Right <$> aE) `mappend` (Left <$> completeE)
let f (Left ()) accAs = ([], Just (reverse accAs))
f (Right a) accAs = (a : accAs, Nothing)
memoE =<< justE <$> scanAccumE [] (f <$> inE)
eventToSignal :: Event a -> Signal [a]
eventToSignal (Event x) = x
signalToEvent :: Signal [a] -> Event a
signalToEvent = Event
changesD :: Discrete a -> Event a
changesD (Discrete dis) = Event $ conv <$> dis
where
conv (new, x) = if new then [x] else []
preservesD :: MonadSignalGen m => Discrete a -> m (Event a)
preservesD dis = do
ev <- onCreation ()
sig <- discreteToSignal dis
memoE $ (const <$> sig <@> ev) `mappend` changesD dis
snapshotD :: MonadSignalGen m => Discrete a -> m a
snapshotD (Discrete a) = snd <$> snapshotS a
stepperD :: MonadSignalGen m => a -> Event a -> m (Discrete a)
stepperD initial (Event evt) = Discrete <$> transferS (False, initial) upd evt
where
upd [] (_, old) = (False, old)
upd occs _ = (True, last occs)
stepperMaybeD :: MonadSignalGen m => Event a -> m (Discrete (Maybe a))
stepperMaybeD ev = stepperD Nothing (Just <$> ev)
justD :: MonadSignalGen m => a -> Discrete (Maybe a) -> m (Discrete a)
justD initial mD = do
mE <- preservesD mD
stepperD initial (justE mE)
accumD :: MonadSignalGen m => a -> Event (a -> a) -> m (Discrete a)
accumD initial (Event evt) = Discrete <$> transferS (False, initial) upd evt
where
upd [] (_, old) = (False, old)
upd upds (_, old) = (True, new)
where !new = foldl' (flip ($)) old upds
differentE :: (Eq a, MonadSignalGen m) => Event a -> m (Event a)
differentE ev = (justE . (f <$>)) <$> withPrevE Nothing (Just <$> ev)
where
f :: (Eq a) => (Maybe a, Maybe a) -> Maybe a
f (new, old) = if new /= old then new else old
instance Applicative Discrete where
pure x = Discrete $ pure (False, x)
Discrete f <*> Discrete a = Discrete $ app <$> f <*> a
where
app (newFun, fun) (newArg, arg) = (new, fun arg)
where !new = newFun || newArg
instance Monad Discrete where
return x = Discrete $ return (False, x)
Discrete x >>= f = Discrete $ do
(newX, v) <- x
let Discrete y = f v
(newY, r) <- y
let !new = newX || newY
return (new, r)
memoD :: MonadSignalGen m => Discrete a -> m (Discrete a)
memoD (Discrete dis) = Discrete <$> memoS dis
delayD :: MonadSignalGen m => a -> Discrete a -> m (Discrete a)
delayD initial (Discrete subsequent) = Discrete <$> delayS (True, initial) subsequent
generatorD :: MonadSignalGen m => Discrete (SignalGen a) -> m (Discrete a)
generatorD (Discrete sig) = do
first <- delayS True $ pure False
listResult <- generatorS $ networkOnChanges <$> first <*> sig
stepperD undefined (Event listResult)
where
networkOnChanges first (new, gen)
| first || new = (:[]) <$> gen
| otherwise = return []
generatorD' :: (MonadSignalGen m, SignalSet s) => Discrete (SignalGen s) -> m s
generatorD' dis = generatorD dis >>= switchD
minimizeChanges :: (MonadSignalGen m, Eq a) => Discrete a -> m (Discrete a)
minimizeChanges (Discrete dis) = Discrete . fmap fromJust <$> transferS Nothing upd dis
where
upd (False, _) (Just (_, cache)) = Just (False, cache)
upd (True, val) (Just (_, cache))
| val == cache = Just (False, cache)
upd (new, val) _ = Just (new, val)
recordDiscrete :: MonadSignalGen m => Discrete a -> m (Discrete a)
recordDiscrete (Discrete dis) = Discrete . fmap fromJust <$> transferS Nothing upd dis
where
upd (False, _) (Just (_, cache)) = Just (False, cache)
upd new_val _ = Just new_val
discreteToSignal :: MonadSignalGen m => Discrete a -> m (Signal a)
discreteToSignal dis = discreteToSignalNoMemo <$> recordDiscrete dis
switchD :: (SignalSet s, MonadSignalGen m) => Discrete s -> m s
switchD dis = recordDiscrete dis >>= basicSwitchD >>= memoizeSignalSet
switchDS :: MonadSignalGen m => Discrete (Signal a) -> m (Signal a)
switchDS = switchD
switchDE :: MonadSignalGen m => Discrete (Event a) -> m (Event a)
switchDE = switchD
freezeD :: MonadSignalGen m => Event () -> Discrete a -> m (Discrete a)
freezeD evt dis = do
dis' <- memoD dis
sig <- discreteToSignal dis'
evt1 <- takeE 1 evt
switchD =<< stepperD dis' (pure <$> sig <@ evt1)
signalToDiscrete :: Signal a -> Discrete a
signalToDiscrete x = Discrete $ (,) True <$> x
traceSignalMaybe :: String -> (a -> Maybe String) -> Signal a -> Signal a
traceSignalMaybe loc f sig = do
v <- sig
case f v of
Nothing -> pure v
Just str -> trace (loc ++ ": " ++ str) $ pure v
traceSignalT :: (Show b) => String -> (a -> b) -> Signal a -> Signal a
traceSignalT loc f = traceSignalMaybe loc (Just . show . f)
traceEventT :: (Show b) => String -> (a -> b) -> Event a -> Event a
traceEventT loc f (Event sig) = Event $ traceSignalMaybe loc msg sig
where
msg [] = Nothing
msg occs = Just $ show (map f occs)
traceDiscreteT :: (Show b) => String -> (a -> b) -> Discrete a -> Discrete a
traceDiscreteT loc f (Discrete sig) = Discrete $ traceSignalMaybe loc msg sig
where
msg (True, val) = Just $ show (f val)
msg (False, _) = Nothing
keepJustsD :: MonadSignalGen m => Discrete (Maybe (Maybe a))
-> m (Discrete (Maybe a))
keepJustsD tm = do
emm <- preservesD tm
stepperD Nothing (justE emm)
keepDJustsD :: MonadSignalGen m => Discrete (Maybe (Discrete a))
-> m (Discrete (Maybe a))
keepDJustsD dmd =
fmap (fmap Just) . justE <$> preservesD dmd
>>= stepperD (return Nothing) >>= switchD
infixl 4 <$?>, <?*?>, <-*?>, <?*->
(<$?>) :: (a -> b) -> Discrete (Maybe a) -> Discrete (Maybe b)
f <$?> valmD = fmap f <$> valmD
(<?*?>) :: Discrete (Maybe (a -> b)) -> Discrete (Maybe a) -> Discrete (Maybe b)
fmD <?*?> valmD = do
fm <- fmD
valm <- valmD
return (fm <*> valm)
(<-*?>) :: Discrete (a -> b) -> Discrete (Maybe a) -> Discrete (Maybe b)
f <-*?> valmD = (fmap <$> f) <*> valmD
(<?*->) :: Discrete (Maybe (a -> b)) -> Discrete a -> Discrete (Maybe b)
fmD <?*-> valD = do
fm <- fmD
case fm of
Just f -> Just . f <$> valD
Nothing -> return Nothing
infixl 4 <~~>
class EasyApply a b c | a b -> c where
(<~~>) :: a -> b -> c
instance EasyApply (a -> b) (Discrete a) (Discrete b) where
(<~~>) = (<$>)
instance EasyApply (Discrete (a -> b)) (Discrete a) (Discrete b) where
(<~~>) = (<*>)
instance EasyApply (a -> b) (Discrete (Maybe a)) (Discrete (Maybe b)) where
(<~~>) = (<$?>)
instance EasyApply (Discrete (Maybe (a -> b))) (Discrete (Maybe a)) (Discrete (Maybe b)) where
(<~~>) = (<?*?>)
instance EasyApply (Discrete (a -> b)) (Discrete (Maybe a)) (Discrete (Maybe b)) where
(<~~>) = (<-*?>)
instance EasyApply (Discrete (Maybe (a -> b))) (Discrete a) (Discrete (Maybe b)) where
(<~~>) = (<?*->)
instance EasyApply (Signal (a -> b)) (Event a) (Event b) where
(<~~>) = apply
instance EasyApply (Maybe (a -> b)) (Discrete a) (Discrete (Maybe b)) where
Just f <~~> valD = Just . f <$> valD
Nothing <~~> _ = return Nothing
forceD :: MonadSignalGen m => Discrete a -> m (Discrete a)
forceD aD = generatorD $ (\x -> x `seq` return x) <$> aD
forceE :: MonadSignalGen m => Event a -> m (Event a)
forceE aE = generatorE $ (\x -> x `seq` return x) <$> aE
rnfD :: (NFData a, MonadSignalGen m) => Discrete a -> m (Discrete a)
rnfD = forceD . fmap force
rnfE :: (NFData a, MonadSignalGen m) => Event a -> m (Event a)
rnfE = forceE . fmap force
#if !MIN_VERSION_deepseq(1,2,0)
force :: NFData a => a -> a
force x = x `deepseq` x
#endif
class SignalSet a where
basicSwitchD :: MonadSignalGen m => Discrete a -> m a
memoizeSignalSet :: MonadSignalGen m => a -> m a
instance SignalSet (Signal a) where
basicSwitchD dis = return $ join $ discreteToSignalNoMemo dis
memoizeSignalSet = memoS
instance SignalSet (Event a) where
basicSwitchD dis = return $ joinEventSignal $ discreteToSignalNoMemo dis
memoizeSignalSet = memoE
instance SignalSet (Discrete a) where
basicSwitchD dis = return $ join dis
memoizeSignalSet = memoD
instance (SignalSet a, SignalSet b) => SignalSet (a, b) where
basicSwitchD dis = (,)
<$> (basicSwitchD $ fst <$> dis)
<*> (basicSwitchD $ snd <$> dis)
memoizeSignalSet (x, y) = (,) <$> memoizeSignalSet x <*> memoizeSignalSet y
instance (SignalSet a, SignalSet b, SignalSet c) => SignalSet (a, b, c) where
basicSwitchD dis = (,,)
<$> (basicSwitchD $ e30 <$> dis)
<*> (basicSwitchD $ e31 <$> dis)
<*> (basicSwitchD $ e32 <$> dis)
where
e30 (a, _, _) = a
e31 (_, a, _) = a
e32 (_, _, a) = a
memoizeSignalSet (x, y, z) =
(,,) <$> memoizeSignalSet x <*> memoizeSignalSet y <*> memoizeSignalSet z
instance (SignalSet a, SignalSet b, SignalSet c, SignalSet d) =>
SignalSet (a, b, c, d) where
basicSwitchD dis = (,,,)
<$> (basicSwitchD $ e40 <$> dis)
<*> (basicSwitchD $ e41 <$> dis)
<*> (basicSwitchD $ e42 <$> dis)
<*> (basicSwitchD $ e43 <$> dis)
where
e40 (a, _, _, _) = a
e41 (_, a, _, _) = a
e42 (_, _, a, _) = a
e43 (_, _, _, a) = a
memoizeSignalSet (x0, x1, x2, x3) = (,,,)
<$> memoizeSignalSet x0
<*> memoizeSignalSet x1
<*> memoizeSignalSet x2
<*> memoizeSignalSet x3
instance (SignalSet a, SignalSet b, SignalSet c, SignalSet d, SignalSet e) =>
SignalSet (a, b, c, d, e) where
basicSwitchD dis = (,,,,)
<$> (basicSwitchD $ e50 <$> dis)
<*> (basicSwitchD $ e51 <$> dis)
<*> (basicSwitchD $ e52 <$> dis)
<*> (basicSwitchD $ e53 <$> dis)
<*> (basicSwitchD $ e54 <$> dis)
where
e50 (a, _, _, _, _) = a
e51 (_, a, _, _, _) = a
e52 (_, _, a, _, _) = a
e53 (_, _, _, a, _) = a
e54 (_, _, _, _, a) = a
memoizeSignalSet (x0, x1, x2, x3, x4) = (,,,,)
<$> memoizeSignalSet x0
<*> memoizeSignalSet x1
<*> memoizeSignalSet x2
<*> memoizeSignalSet x3
<*> memoizeSignalSet x4
discreteToSignalNoMemo :: Discrete a -> Signal a
discreteToSignalNoMemo (Discrete x) = snd <$> x
signalFromList :: [a] -> SignalGen (Signal a)
signalFromList list = fmap hd <$> stateful list tl
where
hd [] = error "signalFromList: list exhausted"
hd (x:_) = x
tl [] = error "signalFromList: list exhausted"
tl (_:xs) = xs
eventFromList :: [[a]] -> SignalGen (Event a)
eventFromList list = Event <$> signalFromList (list ++ repeat [])
networkToList :: Int -> SignalGen (Signal a) -> IO [a]
networkToList n network = do
sample <- start network
replicateM n sample