module FRP.BearRiver.EventS
(
never
, now
, after
, repeatedly
, afterEach
, afterEachCat
, edge
, iEdge
, edgeTag
, edgeJust
, edgeBy
, notYet
, once
, takeEvents
, dropEvents
, snap
)
where
import Control.Arrow (arr, (&&&), (>>>), (>>^))
import Control.Monad.Trans.MSF (ask)
import Data.MonadicStreamFunction (feedback)
import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))
import FRP.BearRiver.Arrow (dup)
import FRP.BearRiver.Basic (constant, identity, (-->), (>--))
import FRP.BearRiver.Event (Event (..), maybeToEvent, tag)
import FRP.BearRiver.InternalCore (SF, Time)
import FRP.BearRiver.Switches (dSwitch, switch)
never :: Monad m => SF m a (Event b)
never :: forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never = forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant forall a. Event a
NoEvent
now :: Monad m => b -> SF m a (Event b)
now :: forall (m :: * -> *) b a. Monad m => b -> SF m a (Event b)
now b
b0 = forall a. a -> Event a
Event b
b0 forall (m :: * -> *) b a. Monad m => b -> SF m a b -> SF m a b
--> forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never
after :: Monad m
=> Time
-> b
-> SF m a (Event b)
after :: forall (m :: * -> *) b a. Monad m => Time -> b -> SF m a (Event b)
after Time
q b
x = forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Time
q forall {a}. MSF (ClockInfo m) (a, Time) (Event b, Time)
go
where
go :: MSF (ClockInfo m) (a, Time) (Event b, Time)
go = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \(a
_, Time
t) -> do
Time
dt <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let t' :: Time
t' = Time
t forall a. Num a => a -> a -> a
- Time
dt
e :: Event b
e = if Time
t forall a. Ord a => a -> a -> Bool
> Time
0 Bool -> Bool -> Bool
&& Time
t' forall a. Ord a => a -> a -> Bool
< Time
0 then forall a. a -> Event a
Event b
x else forall a. Event a
NoEvent
ct :: MSF (ClockInfo m) (a, Time) (Event b, Time)
ct = if Time
t' forall a. Ord a => a -> a -> Bool
< Time
0 then forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant (forall a. Event a
NoEvent, Time
t') else MSF (ClockInfo m) (a, Time) (Event b, Time)
go
forall (m :: * -> *) a. Monad m => a -> m a
return ((Event b
e, Time
t'), MSF (ClockInfo m) (a, Time) (Event b, Time)
ct)
repeatedly :: Monad m => Time -> b -> SF m a (Event b)
repeatedly :: forall (m :: * -> *) b a. Monad m => Time -> b -> SF m a (Event b)
repeatedly Time
q b
x
| Time
q forall a. Ord a => a -> a -> Bool
> Time
0 = forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event b)
afterEach [(Time, b)]
qxs
| Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"bearriver: repeatedly: Non-positive period."
where
qxs :: [(Time, b)]
qxs = (Time
q, b
x)forall a. a -> [a] -> [a]
:[(Time, b)]
qxs
afterEach :: Monad m => [(Time, b)] -> SF m a (Event b)
afterEach :: forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event b)
afterEach [(Time, b)]
qxs = forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event [b])
afterEachCat [(Time, b)]
qxs forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> a
head)
afterEachCat :: Monad m => [(Time, b)] -> SF m a (Event [b])
afterEachCat :: forall (m :: * -> *) b a.
Monad m =>
[(Time, b)] -> SF m a (Event [b])
afterEachCat = forall (m :: * -> *) b a.
Monad m =>
Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
0
where
afterEachCat' :: Monad m => Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' :: forall (m :: * -> *) b a.
Monad m =>
Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
_ [] = forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never
afterEachCat' Time
t [(Time, b)]
qxs = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
_ -> do
Time
dt <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let ([b]
ev, Time
t', [(Time, b)]
qxs') = forall b. [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)])
fireEvents [] (Time
t forall a. Num a => a -> a -> a
+ Time
dt) [(Time, b)]
qxs
ev' :: Event [b]
ev' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
ev
then forall a. Event a
NoEvent
else forall a. a -> Event a
Event (forall a. [a] -> [a]
reverse [b]
ev)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event [b]
ev', forall (m :: * -> *) b a.
Monad m =>
Time -> [(Time, b)] -> SF m a (Event [b])
afterEachCat' Time
t' [(Time, b)]
qxs')
fireEvents :: [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)])
fireEvents :: forall b. [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)])
fireEvents [b]
ev Time
t [] = ([b]
ev, Time
t, [])
fireEvents [b]
ev Time
t ((Time, b)
qx:[(Time, b)]
qxs)
| forall a b. (a, b) -> a
fst (Time, b)
qx forall a. Ord a => a -> a -> Bool
< Time
0 = forall a. HasCallStack => [Char] -> a
error [Char]
"bearriver: afterEachCat: Non-positive period."
| Time
overdue forall a. Ord a => a -> a -> Bool
>= Time
0 = forall b. [b] -> Time -> [(Time, b)] -> ([b], Time, [(Time, b)])
fireEvents (forall a b. (a, b) -> b
snd (Time, b)
qxforall a. a -> [a] -> [a]
:[b]
ev) Time
overdue [(Time, b)]
qxs
| Bool
otherwise = ([b]
ev, Time
t, (Time, b)
qxforall a. a -> [a] -> [a]
:[(Time, b)]
qxs)
where
overdue :: Time
overdue = Time
t forall a. Num a => a -> a -> a
- forall a b. (a, b) -> a
fst (Time, b)
qx
edge :: Monad m => SF m Bool (Event ())
edge :: forall (m :: * -> *). Monad m => SF m Bool (Event ())
edge = forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom Bool
True
iEdge :: Monad m => Bool -> SF m Bool (Event ())
iEdge :: forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
iEdge = forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom
edgeFrom :: Monad m => Bool -> SF m Bool (Event())
edgeFrom :: forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom Bool
prev = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \Bool
a -> do
let res :: Event ()
res | Bool
prev = forall a. Event a
NoEvent
| Bool
a = forall a. a -> Event a
Event ()
| Bool
otherwise = forall a. Event a
NoEvent
ct :: MSF (ReaderT Time m) Bool (Event ())
ct = forall (m :: * -> *). Monad m => Bool -> SF m Bool (Event ())
edgeFrom Bool
a
forall (m :: * -> *) a. Monad m => a -> m a
return (Event ()
res, MSF (ReaderT Time m) Bool (Event ())
ct)
edgeTag :: Monad m => a -> SF m Bool (Event a)
edgeTag :: forall (m :: * -> *) a. Monad m => a -> SF m Bool (Event a)
edgeTag a
a = forall (m :: * -> *). Monad m => SF m Bool (Event ())
edge forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. Event a -> b -> Event b
`tag` a
a)
edgeJust :: Monad m => SF m (Maybe a) (Event a)
edgeJust :: forall (m :: * -> *) a. Monad m => SF m (Maybe a) (Event a)
edgeJust = forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy forall {a} {a}. Maybe a -> Maybe a -> Maybe a
isJustEdge (forall a. a -> Maybe a
Just forall a. HasCallStack => a
undefined)
where
isJustEdge :: Maybe a -> Maybe a -> Maybe a
isJustEdge Maybe a
Nothing Maybe a
Nothing = forall a. Maybe a
Nothing
isJustEdge Maybe a
Nothing ma :: Maybe a
ma@(Just a
_) = Maybe a
ma
isJustEdge (Just a
_) (Just a
_) = forall a. Maybe a
Nothing
isJustEdge (Just a
_) Maybe a
Nothing = forall a. Maybe a
Nothing
edgeBy :: Monad m => (a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy :: forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy a -> a -> Maybe b
isEdge a
aPrev = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
a ->
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a -> Event a
maybeToEvent (a -> a -> Maybe b
isEdge a
aPrev a
a), forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy a -> a -> Maybe b
isEdge a
a)
notYet :: Monad m => SF m (Event a) (Event a)
notYet :: forall (m :: * -> *) a. Monad m => SF m (Event a) (Event a)
notYet = forall (m :: * -> *) c a b.
Monad m =>
c -> MSF m (a, c) (b, c) -> MSF m a b
feedback Bool
False forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(Event a
e, Bool
c) ->
if Bool
c then (Event a
e, Bool
True) else (forall a. Event a
NoEvent, Bool
True))
once :: Monad m => SF m (Event a) (Event a)
once :: forall (m :: * -> *) a. Monad m => SF m (Event a) (Event a)
once = forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
takeEvents Int
1
takeEvents :: Monad m => Int -> SF m (Event a) (Event a)
takeEvents :: forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
takeEvents Int
n | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never
takeEvents Int
n = forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. a -> (a, a)
dup) (forall a b. a -> b -> a
const (forall a. Event a
NoEvent forall (m :: * -> *) a b. Monad m => a -> SF m a b -> SF m a b
>-- forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
takeEvents (Int
n forall a. Num a => a -> a -> a
- Int
1)))
dropEvents :: Monad m => Int -> SF m (Event a) (Event a)
dropEvents :: forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
dropEvents Int
n | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = forall (m :: * -> *) a. Monad m => SF m a a
identity
dropEvents Int
n =
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch (forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: * -> *) a. Monad m => SF m a a
identity)
(forall a b. a -> b -> a
const (forall a. Event a
NoEvent forall (m :: * -> *) a b. Monad m => a -> SF m a b -> SF m a b
>-- forall (m :: * -> *) a. Monad m => Int -> SF m (Event a) (Event a)
dropEvents (Int
n forall a. Num a => a -> a -> a
- Int
1)))
snap :: Monad m => SF m a (Event a)
snap :: forall (m :: * -> *) a. Monad m => SF m a (Event a)
snap =
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch (forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (forall (m :: * -> *) a. Monad m => SF m a a
identity forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (m :: * -> *) b a. Monad m => b -> SF m a (Event b)
now () forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ \(a
a, Event ()
e) -> Event ()
e forall a b. Event a -> b -> Event b
`tag` a
a)) forall (m :: * -> *) b a. Monad m => b -> SF m a (Event b)
now