module Control.Wire.Prefab.Event
(
after,
at,
delayEvents,
delayEventsSafe,
periodically,
inhibit,
never,
asSoonAs,
edge,
require,
forbid,
while,
notYet,
once
)
where
import qualified Data.Map as M
import qualified Data.Sequence as S
import Control.Arrow
import Control.Monad.Fix
import Control.Wire.Classes
import Control.Wire.Prefab.Simple
import Control.Wire.Types
import Data.Monoid
import Data.Map (Map)
import Data.Sequence (Seq, ViewL(..), (><))
after ::
forall e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) t ()
after =
mkGen $ proc dt -> do
t0 <- arrTime -< ()
returnA -<
if dt <= 0
then (Right (), never)
else (Left mempty, after' t0)
where
after' :: t -> Wire e (>~) t ()
after' t0 =
fix $ \again ->
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -<
if t t0 >= dt
then (Right (), never)
else (Left mempty, again)
at :: (ArrowClock (>~), Monoid e, Ord t, Time (>~) ~ t) => Wire e (>~) t ()
at =
mkGen $ proc tt -> do
t <- arrTime -< ()
returnA -<
if t >= tt
then (Right (), never)
else (Left mempty, at)
delayEvents ::
forall b e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) ([b], t) b
delayEvents = delayEvents' M.empty
where
delayEvents' :: Map t (Seq b) -> Wire e (>~) ([b], t) b
delayEvents' devs' =
mkGen $ proc (evs, dt) -> do
t <- arrTime -< ()
let devs | null evs = devs'
| otherwise = M.insertWith' (><) (t + dt) (S.fromList evs) devs'
returnA -<
devs `seq`
case M.minViewWithKey devs of
Nothing -> (Left mempty, delayEvents' devs)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' devs)
| otherwise ->
case S.viewl revs of
EmptyL -> (Left mempty, delayEvents' restMap)
rev :< restEvs ->
(Right rev,
delayEvents' (if S.null restEvs
then restMap
else M.insert tt restEvs restMap))
delayEventsSafe ::
forall b e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) (([b], t), Int) b
delayEventsSafe = delayEvents' 0 M.empty
where
delayEvents' :: Int -> Map t (Seq b) -> Wire e (>~) (([b], t), Int) b
delayEvents' curNum' devs' =
mkGen $ proc ((evs, dt), maxNum) -> do
t <- arrTime -< ()
let addSeq = S.fromList evs
(curNum, devs) =
if null evs || curNum' >= maxNum
then (curNum', devs')
else (curNum' + S.length addSeq,
M.insertWith' (><) (t + dt) addSeq devs')
returnA -<
case M.minViewWithKey devs of
Nothing -> (Left mempty, delayEvents' curNum devs)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' curNum devs)
| otherwise ->
case S.viewl revs of
EmptyL -> (Left mempty, delayEvents' curNum restMap)
rev :< restEvs ->
(Right rev,
delayEvents' (pred curNum)
(if S.null restEvs
then restMap
else M.insert tt restEvs restMap))
asSoonAs :: Monoid e => Wire e (>~) Bool ()
asSoonAs =
mkPure $ \b ->
if b then (Right (), constant ()) else (Left mempty, asSoonAs)
edge :: forall e (>~). Monoid e => Wire e (>~) Bool ()
edge =
mkPure $ \b ->
if b then (Right (), switchBack) else (Left mempty, edge)
where
switchBack :: Wire e (>~) Bool ()
switchBack = mkPure $ \b -> (Left mempty, if b then switchBack else edge)
forbid :: Monoid e => Wire e (>~) Bool ()
forbid = mkPureFix (\b -> if b then Left mempty else Right ())
inhibit :: Wire e (>~) e b
inhibit = mkPureFix Left
never :: Monoid e => Wire e (>~) a b
never = mkPureFix (const (Left mempty))
notYet :: Monoid e => Wire e (>~) b b
notYet = mkPure (const (Left mempty, identity))
once :: Monoid e => Wire e (>~) b b
once = mkPure $ \x -> (Right x, never)
periodically ::
forall e t (>~).
(ArrowClock (>~), Monoid e, Num t, Ord t, Time (>~) ~ t)
=> Wire e (>~) t ()
periodically =
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -< (if dt <= 0 then Right () else Left mempty, periodically' t)
where
periodically' :: t -> Wire e (>~) t ()
periodically' t0 =
mkGen $ proc dt -> do
t <- arrTime -< ()
returnA -<
let tt = t0 + dt in
if tt <= t
then (Right (), periodically' tt)
else (Left mempty, periodically' t0)
require :: Monoid e => Wire e (>~) Bool ()
require = mkPureFix (\b -> if b then Right () else Left mempty)
while :: Monoid e => Wire e (>~) Bool ()
while =
mkPure $ \b ->
if b then (Right (), while) else (Left mempty, never)