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. a -> Wire (Event (a -> a)) (Event a)
accum ee' = accum'
where
accum' :: Wire (Event (a -> a)) (Event a)
accum' =
mkGen $ \_ ->
return .
maybe (Nothing, accum')
(\f -> let ee = f ee' in ee `seq` (Just (Just ee), accum ee))
after :: forall a. DTime -> Wire a (Event a)
after t' =
mkGen $ \(wsDTime -> dt) x ->
let t = t' dt in
if t <= 0
then return (Just (Just x), never)
else return (Nothing, after t)
afterEach :: forall a b. [(DTime, b)] -> Wire a (Event b)
afterEach = afterEach' 0
where
afterEach' :: DTime -> [(DTime, b)] -> Wire 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 (Just (Just x), afterEach' (t int) ds)
else return (Just Nothing, afterEach' t d)
dam :: forall a. Wire [a] (Event a)
dam = dam' []
where
dam' :: [a] -> Wire [a] (Event a)
dam' xs =
mkGen $ \_ ys ->
case xs ++ ys of
[] -> return (Just Nothing, dam' [])
(ee:rest) -> return (Just (Just ee), dam' rest)
delayEvents :: Wire (DTime, Event a) (Event a)
delayEvents = delayEvent' Seq.empty 0
where
delayEvent' :: Seq (DTime, a) -> Time -> Wire (DTime, 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 (Nothing, delayEvent' es 0)
(et, ee) :< rest
| t >= et -> return (Just (Just ee), delayEvent' rest t)
| otherwise -> return (Just Nothing, delayEvent' es t)
delayEventsSafe :: Wire (DTime, Int, Event a) (Event a)
delayEventsSafe = delayEventSafe' Seq.empty 0
where
delayEventSafe' :: Seq (DTime, a) -> Time -> Wire (DTime, 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 (Nothing, delayEventSafe' es 0)
(et, ee) :< rest
| t >= et -> return (Just (Just ee), delayEventSafe' rest t)
| otherwise -> return (Just Nothing, delayEventSafe' es t)
dHold :: forall a. a -> Wire (Event a) a
dHold x0 = dHold'
where
dHold' :: Wire (Event a) a
dHold' =
mkGen $ \_ ->
return . maybe (Just x0, dHold') (\x1 -> (Just x0, dHold x1))
dropEvents :: forall a. Int -> Wire (Event a) (Event a)
dropEvents 0 = identity
dropEvents n = drop'
where
drop' :: Wire (Event a) (Event a)
drop' =
mkGen $ \_ ->
return .
maybe (Nothing, drop')
(const (Nothing, dropEvents (pred n)))
dropFor :: forall a. Wire (DTime, Event a) (Event a)
dropFor = dropFor' 0
where
dropFor' :: Time -> Wire (DTime, Event a) (Event a)
dropFor' t' =
mkGen $ \(wsDTime -> dt) (int, ev) ->
let t = t' + dt in
if t >= int
then return (Just ev, arr snd)
else return (Just Nothing, dropFor' t)
edge :: Wire (Bool, a) (Event a)
edge = edgeBy fst snd
edgeBy :: forall a b. (a -> Bool) -> (a -> b) -> Wire a (Event b)
edgeBy p f = edgeBy'
where
edgeBy' :: Wire a (Event b)
edgeBy' =
mkGen $ \_ subject ->
if p subject
then return (Just (Just (f subject)), switchBack)
else return (Just Nothing, edgeBy')
switchBack :: Wire a (Event b)
switchBack =
mkGen $ \_ subject ->
if p subject
then return (Just Nothing, switchBack)
else return (Just Nothing, edgeBy')
edgeJust :: Wire (Maybe a) (Event a)
edgeJust = edgeBy isJust fromJust
hold :: forall a. a -> Wire (Event a) a
hold x0 = hold'
where
hold' :: Wire (Event a) a
hold' =
mkGen $ \_ ->
return .
maybe (Just x0, hold')
(\x -> (Just x, hold x))
never :: Wire a (Event b)
never = constant Nothing
notYet :: Wire (Event a) (Event a)
notYet = mkGen $ \_ -> return . maybe (Just Nothing, notYet) (const (Just Nothing, identity))
now :: b -> Wire a (Event b)
now x = constantAfter Nothing (Just x)
once :: Wire (Event a) (Event a)
once =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Just Nothing, once)
Just _ -> return (Just ev, constant Nothing)
repeatedly :: forall a. Wire (DTime, a) (Event a)
repeatedly = repeatedly' 0
where
repeatedly' :: Time -> Wire (DTime, 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 (Just (Just x), repeatedly' nextT)
else return (Just Nothing, repeatedly' t)
repeatedlyList :: forall a. [a] -> Wire DTime (Event a)
repeatedlyList = repeatedly' 0
where
repeatedly' :: DTime -> [a] -> Wire DTime (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 (Just (Just x0), repeatedly' nextT xs)
else return (Just Nothing, repeatedly' t x)
takeEvents :: Int -> Wire (Event a) (Event a)
takeEvents 0 = constant Nothing
takeEvents n = take'
where
take' :: Wire (Event a) (Event a)
take' =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Just Nothing, take')
Just _ -> return (Just ev, takeEvents (pred n))
takeFor :: Wire (DTime, Event a) (Event a)
takeFor = takeFor' 0
where
takeFor' :: Time -> Wire (DTime, Event a) (Event a)
takeFor' t' =
mkGen $ \(wsDTime -> dt) (int, ev) ->
let t = t' + dt in
if t >= int
then return (Just Nothing, constant Nothing)
else return (Just ev, takeFor' t)
wait :: Wire (Event a) a
wait =
mkGen $ \_ ev ->
case ev of
Nothing -> return (Nothing, wait)
Just _ -> return (ev, wait)