module Control.Wire.Prefab.Event
(
WAfter(..),
WAt(..),
WDelayEvents(..),
WPeriodically(..),
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(..), (><))
import Data.VectorSpace
class Arrow (>~) => WAfter t (>~) | (>~) -> t where
after :: Monoid e => Wire e (>~) t ()
instance (AdditiveGroup t, MonadClock t m, Ord t) => WAfter t (Kleisli m) where
after = after0
where
after0 :: forall e. Monoid e => Wire e (Kleisli m) t ()
after0 =
WmGen $ \int -> do
t0 <- getTime
return (int <= zeroV `orGoWith` after' t0)
where
after' :: t -> Wire e (Kleisli m) t ()
after' t0 =
fix $ \again ->
WmGen $ \int -> do
t <- getTime
return (t ^-^ t0 >= int `orGoWith` again)
class Arrow (>~) => WAt t (>~) | (>~) -> t where
at :: Monoid e => Wire e (>~) t ()
instance (MonadClock t m, Ord t) => WAt t (Kleisli m) where
at =
WmGen $ \tt -> do
t <- getTime
return (t >= tt `orGoWith` at)
class Arrow (>~) => WDelayEvents t (>~) | (>~) -> t where
delayEvents :: Monoid e => Wire e (>~) ([b], t) b
delayEventsSafe :: Monoid e => Wire e (>~) (([b], t), Int) b
instance (AdditiveGroup t, MonadClock t m, Ord t) => WDelayEvents t (Kleisli m) where
delayEvents = delayEvents' M.empty
where
delayEvents' :: Monoid e => Map t (Seq b) -> Wire e (Kleisli m) ([b], t) b
delayEvents' delayed' =
WmGen $ \(evs, int) -> do
t <- getTime
let delayed = M.insertWith' (><) (t ^+^ int) (S.fromList evs) delayed'
return $
case M.minViewWithKey delayed of
Nothing -> (Left mempty, delayEvents' delayed)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' delayed)
| 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 = delayEvents' 0 M.empty
where
delayEvents' :: Monoid e => Int -> Map t (Seq b) -> Wire e (Kleisli m) (([b], t), Int) b
delayEvents' curNum' delayed' =
WmGen $ \((evs, int), maxNum) -> do
t <- getTime
let addSeq = S.fromList evs
(curNum, delayed) =
if null evs || curNum' >= maxNum
then (curNum', delayed')
else (curNum' + S.length addSeq,
M.insertWith' (><) (t ^+^ int) addSeq delayed')
return $
case M.minViewWithKey delayed of
Nothing -> (Left mempty, delayEvents' curNum delayed)
Just ((tt, revs), restMap)
| tt > t -> (Left mempty, delayEvents' curNum delayed)
| 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, WirePure (>~)) => Wire e (>~) Bool ()
asSoonAs =
mkPure $ \b ->
if b then (Right (), constant ()) else (Left mempty, asSoonAs)
edge :: forall e (>~). (Monoid e, WirePure (>~)) => 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, WirePure (>~)) => Wire e (>~) Bool ()
forbid = mkPureFix (\b -> if b then Left mempty else Right ())
inhibit :: WirePure (>~) => Wire e (>~) e b
inhibit = mkPureFix Left
never :: (Monoid e, WirePure (>~)) => Wire e (>~) a b
never = mkPureFix (const (Left mempty))
notYet :: (Monoid e, WirePure (>~)) => Wire e (>~) b b
notYet = mkPure (const (Left mempty, identity))
once :: (Monoid e, WirePure (>~)) => Wire e (>~) b b
once = mkPure $ \x -> (Right x, never)
class Arrow (>~) => WPeriodically t (>~) | (>~) -> t where
periodically :: Monoid e => Wire e (>~) t ()
instance (AdditiveGroup t, MonadClock t m, Ord t) => WPeriodically t (Kleisli m) where
periodically =
WmGen $ \int ->
if int <= zeroV
then return (Right (), periodically)
else do
t <- getTime
return (Left mempty, periodically' t)
where
periodically' :: Monoid e => t -> Wire e (Kleisli m) t ()
periodically' t0 =
WmGen $ \int -> do
t <- getTime
let tt = t0 ^+^ int
return $
if t >= tt
then (Right (), periodically' tt)
else (Left mempty, periodically' t0)
require :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()
require = mkPureFix (\b -> if b then Right () else Left mempty)
while :: (Monoid e, WirePure (>~)) => Wire e (>~) Bool ()
while =
mkPure $ \b ->
if b then (Right (), while) else (Left mempty, never)
orGoWith ::
(Monoid e, WirePure (>~))
=> Bool
-> Wire e (>~) a b
-> (Either e (), Wire e (>~) a b)
orGoWith True _ = (Right (), never)
orGoWith False w = (Left mempty, w)
infixl 3 `orGoWith`