module FRP.NetWire.Event
(
after,
afterEach,
edge,
edgeBy,
edgeJust,
never,
now,
once,
repeatedly,
repeatedlyList,
wait,
dam,
delayEvents,
delayEventsSafe,
dropEvents,
dropFor,
notYet,
takeEvents,
takeFor,
accum,
hold, dHold
)
where
import qualified Data.Sequence as Seq
import Control.Arrow
import Control.Monad
import Data.Maybe
import Data.Sequence (Seq, (|>), ViewL((:<)))
import FRP.NetWire.Tools
import FRP.NetWire.Wire
accum :: forall a m. Monad m => a -> Wire m (Event (a -> a)) (Event a)
accum ee' = accum'
where
accum' :: Wire m (Event (a -> a)) (Event a)
accum' =
mkGen $ \_ ->
return .
maybe (Right Nothing, accum')
(\f -> let ee = f ee' in ee `seq` (Right (Just ee), accum ee))
after :: Monad m => Time -> Wire m a (Event a)
after t' =
mkGen $ \(wsDTime -> dt) x ->
let t = t' dt in
if t <= 0
then return (Right (Just x), never)
else return (Right Nothing, after t)
afterEach :: forall a b m. Monad m => [(Time, b)] -> Wire m a (Event b)
afterEach = afterEach' 0
where
afterEach' :: Time -> [(Time, b)] -> Wire m a (Event b)
afterEach' _ [] = never
afterEach' t' d@((int, x):ds) =
mkGen $ \(wsDTime -> dt) _ ->
let t = t' + dt in
if t >= int
then let nextT = t int
in nextT `seq` return (Right (Just x), afterEach' (t int) ds)
else return (Right Nothing, afterEach' t d)
dam :: forall a m. Monad m => Wire m [a] (Event a)
dam = dam' []
where
dam' :: [a] -> Wire m [a] (Event a)
dam' xs =
mkGen $ \_ ys ->
case xs ++ ys of
[] -> return (Right Nothing, dam' [])
(ee:rest) -> return (Right (Just ee), dam' rest)
delayEvents :: forall a m. Monad m => Wire m (Time, Event a) (Event a)
delayEvents = delayEvent' Seq.empty 0
where
delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Event a) (Event a)
delayEvent' es' t' =
mkGen $ \(wsDTime -> dt) (int, ev) -> do
let t = t' + dt
es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev
case Seq.viewl es of
Seq.EmptyL -> return (Right Nothing, delayEvent' es 0)
(et, ee) :< rest
| t >= et -> return (Right (Just ee), delayEvent' rest t)
| otherwise -> return (Right Nothing, delayEvent' es t)
delayEventsSafe :: forall a m. Monad m => Wire m (Time, Int, Event a) (Event a)
delayEventsSafe = delayEventSafe' Seq.empty 0
where
delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Event a) (Event a)
delayEventSafe' es' t' =
mkGen $ \(wsDTime -> dt) (int, maxEvs, ev') -> do
let t = t' + dt
ev = guard (Seq.length es' < maxEvs) >> ev'
es = t `seq` maybe es' (\ee -> es' |> (t + int, ee)) ev
case Seq.viewl es of
Seq.EmptyL -> return (Right Nothing, delayEventSafe' es 0)
(et, ee) :< rest
| t >= et -> return (Right (Just ee), delayEventSafe' rest t)
| otherwise -> return (Right Nothing, delayEventSafe' es t)
dHold :: forall a m. Monad m => a -> Wire m (Event a) a
dHold x0 = dHold'
where
dHold' :: Wire m (Event a) a
dHold' =
mkGen $ \_ ->
return . maybe (Right x0, dHold') (\x1 -> (Right x0, dHold x1))
dropEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a)
dropEvents 0 = identity
dropEvents n = drop'
where
drop' :: Wire m (Event a) (Event a)
drop' =
mkGen $ \_ ->
return .
maybe (Right Nothing, drop')
(const (Right Nothing, dropEvents (pred n)))
dropFor :: forall a m. Monad m => Wire m (Time, Event a) (Event a)
dropFor = dropFor' 0
where
dropFor' :: Time -> Wire m (Time, Event a) (Event a)
dropFor' t' =
mkGen $ \(wsDTime -> dt) (int, ev) ->
let t = t' + dt in
if t >= int
then return (Right ev, arr snd)
else return (Right Nothing, dropFor' t)
edge :: Monad m => Wire m (Bool, a) (Event a)
edge = edgeBy fst snd
edgeBy :: forall a b m. Monad m => (a -> Bool) -> (a -> b) -> Wire m a (Event b)
edgeBy p f = edgeBy'
where
edgeBy' :: Wire m a (Event b)
edgeBy' =
mkGen $ \_ subject ->
if p subject
then return (Right (Just (f subject)), switchBack)
else return (Right Nothing, edgeBy')
switchBack :: Wire m a (Event b)
switchBack =
mkGen $ \_ subject ->
return (Right Nothing, if p subject then switchBack else edgeBy')
edgeJust :: Monad m => Wire m (Maybe a) (Event a)
edgeJust = edgeBy isJust fromJust
hold :: forall a m. Monad m => a -> Wire m (Event a) a
hold x0 = hold'
where
hold' :: Wire m (Event a) a
hold' =
mkGen $ \_ ->
return .
maybe (Right x0, hold')
(Right &&& hold)
never :: Monad m => Wire m a (Event b)
never = constant Nothing
notYet :: Monad m => Wire m (Event a) (Event a)
notYet = mkGen $ \_ -> return . maybe (Right Nothing, notYet) (const (Right Nothing, identity))
now :: Monad m => b -> Wire m a (Event b)
now x = constantAfter Nothing (Just x)
once :: Monad m => Wire m (Event a) (Event a)
once =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Right Nothing, once)
Just _ -> return (Right ev, constant Nothing)
repeatedly :: forall a m. Monad m => Wire m (Time, a) (Event a)
repeatedly = repeatedly' 0
where
repeatedly' :: Time -> Wire m (Time, a) (Event a)
repeatedly' t' =
mkGen $ \(wsDTime -> dt) (int, x) ->
let t = t' + dt in
if t >= int
then let nextT = fmod t int
in nextT `seq` return (Right (Just x), repeatedly' nextT)
else return (Right Nothing, repeatedly' t)
repeatedlyList :: forall a m. Monad m => [a] -> Wire m Time (Event a)
repeatedlyList = repeatedly' 0
where
repeatedly' :: Time -> [a] -> Wire m Time (Event a)
repeatedly' _ [] = constant Nothing
repeatedly' t' x@(x0:xs) =
mkGen $ \(wsDTime -> dt) int ->
let t = t' + dt in
if t >= int
then let nextT = fmod t int
in nextT `seq` return (Right (Just x0), repeatedly' nextT xs)
else return (Right Nothing, repeatedly' t x)
takeEvents :: forall a m. Monad m => Int -> Wire m (Event a) (Event a)
takeEvents 0 = constant Nothing
takeEvents n = take'
where
take' :: Wire m (Event a) (Event a)
take' =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Right Nothing, take')
Just _ -> return (Right ev, takeEvents (pred n))
takeFor :: forall a m. Monad m => Wire m (Time, Event a) (Event a)
takeFor = takeFor' 0
where
takeFor' :: Time -> Wire m (Time, Event a) (Event a)
takeFor' t' =
mkGen $ \(wsDTime -> dt) (int, ev) ->
let t = t' + dt in
if t >= int
then return (Right Nothing, constant Nothing)
else return (Right ev, takeFor' t)
wait :: Monad m => Wire m (Event a) a
wait =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Left (inhibitEx "Waiting for event"), wait)
Just ee -> return (Right ee, wait)