module FRP.NetWire.Event
(
after,
afterEach,
edge,
edgeBy,
edgeJust,
never,
once,
repeatedly,
repeatedlyList,
dam,
delayEvents,
delayEventsSafe,
dropEvents,
dropFor,
notYet,
takeEvents,
takeFor,
event
)
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
after :: Monad m => Time -> Wire m a a
after t' =
mkGen $ \(wsDTime -> dt) x ->
let t = t' dt in
if t <= 0
then return (Right x, never)
else return (Left noEvent, after t)
afterEach :: forall a b m. Monad m => [(Time, b)] -> Wire m a b
afterEach = afterEach' 0
where
afterEach' :: Time -> [(Time, b)] -> Wire m a 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 x, afterEach' (t int) ds)
else return (Left noEvent, afterEach' t d)
dam :: forall a m. Monad m => Wire m [a] a
dam = dam' []
where
dam' :: [a] -> Wire m [a] a
dam' xs =
mkGen $ \_ ys ->
case xs ++ ys of
[] -> return (Left noEvent, dam' [])
(x:rest) -> return (Right x, dam' rest)
delayEvents :: forall a m. Monad m => Wire m (Time, Maybe a) a
delayEvents = delayEvent' Seq.empty 0
where
delayEvent' :: Seq (Time, a) -> Time -> Wire m (Time, Maybe a) 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 (Left noEvent, delayEvent' es 0)
(et, ee) :< rest
| t >= et -> return (Right ee, delayEvent' rest t)
| otherwise -> return (Left noEvent, delayEvent' es t)
delayEventsSafe :: forall a m. Monad m => Wire m (Time, Int, Maybe a) a
delayEventsSafe = delayEventSafe' Seq.empty 0
where
delayEventSafe' :: Seq (Time, a) -> Time -> Wire m (Time, Int, Maybe a) 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 (Left noEvent, delayEventSafe' es 0)
(et, ee) :< rest
| t >= et -> return (Right ee, delayEventSafe' rest t)
| otherwise -> return (Left noEvent, delayEventSafe' es t)
dropEvents :: forall a m. Monad m => Int -> Wire m a a
dropEvents 0 = identity
dropEvents n =
mkGen $ \_ x -> return (Right x, dropEvents (pred n))
dropFor :: forall a m. Monad m => Wire m (Time, a) a
dropFor = dropFor' 0
where
dropFor' :: Time -> Wire m (Time, a) a
dropFor' t' =
mkGen $ \(wsDTime -> dt) (int, x) ->
let t = t' + dt in
if t >= int
then return (Right x, arr snd)
else return (Left noEvent, dropFor' t)
edge :: Monad m => Wire m (Bool, a) a
edge = edgeBy fst snd
edgeBy :: forall a b m. Monad m => (a -> Bool) -> (a -> b) -> Wire m a b
edgeBy p f = edgeBy'
where
edgeBy' :: Wire m a b
edgeBy' =
mkGen $ \_ subject ->
if p subject
then return (Right (f subject), switchBack)
else return (Left noEvent, edgeBy')
switchBack :: Wire m a b
switchBack =
mkGen $ \_ subject ->
return (Left noEvent, if p subject then switchBack else edgeBy')
edgeJust :: Monad m => Wire m (Maybe a) a
edgeJust = edgeBy isJust fromJust
event :: Monad m => Wire m a b -> Wire m a (Maybe b)
event w' =
mkGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
Left _ -> return (Right Nothing, event w)
Right x -> return (Right (Just x), event w)
never :: Monad m => Wire m a b
never = mkGen $ \_ _ -> return (Left noEvent, never)
notYet :: Monad m => Wire m a a
notYet = mkGen $ \_ _ -> return (Left noEvent, identity)
once :: Monad m => Wire m a a
once = mkGen $ \_ x -> return (Right x, never)
repeatedly :: forall a m. Monad m => Wire m (Time, a) a
repeatedly = repeatedly' 0
where
repeatedly' :: Time -> Wire m (Time, a) 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 x, repeatedly' nextT)
else return (Left noEvent, repeatedly' t)
repeatedlyList :: forall a m. Monad m => [a] -> Wire m Time a
repeatedlyList = repeatedly' 0
where
repeatedly' :: Time -> [a] -> Wire m Time a
repeatedly' _ [] = never
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 x0, repeatedly' nextT xs)
else return (Left noEvent, repeatedly' t x)
takeEvents :: forall a m. Monad m => Int -> Wire m a a
takeEvents 0 = never
takeEvents n = mkGen $ \_ x -> return (Right x, takeEvents (pred n))
takeFor :: forall a m. Monad m => Wire m (Time, a) a
takeFor = takeFor' 0
where
takeFor' :: Time -> Wire m (Time, a) a
takeFor' t' =
mkGen $ \(wsDTime -> dt) (int, x) ->
let t = t' + dt in
if t >= int
then return (Left noEvent, never)
else return (Right x, takeFor' t)