-- | -- Module: FRP.NetWire.Switch -- Copyright: (c) 2011 Ertugrul Soeylemez -- License: BSD3 -- Maintainer: Ertugrul Soeylemez <es@ertes.de> -- -- Switching combinators. Note that 'Wire' also provides a -- state-preserving 'Control.Arrow.ArrowApply' instance, which may be -- more convenient than these combinators in many cases. module FRP.NetWire.Switch ( -- * Basic switches switch, dSwitch, rSwitch, drSwitch, -- * Broadcasters parB, rpSwitchB, drpSwitchB, -- * Routers par, rpSwitch, drpSwitch ) where import qualified Data.Traversable as T import Control.Applicative import Data.Traversable (Traversable) import FRP.NetWire.Wire -- | Decoupled variant of 'rpSwitch'. drpSwitch :: (Applicative m, Monad m, Traversable f) => (forall w. a -> f w -> f (b, w)) -> f (Wire m b c) -> Wire m (a, Event (f (Wire m b c) -> f (Wire m b c))) (f c) drpSwitch route wires''' = WGen $ \ws (x'', ev) -> do let wires'' = route x'' wires''' r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires'' let xs = T.sequenceA . fmap fst $ r wires' = fmap snd r wires = maybe id id ev wires' return (xs, rpSwitch route wires) -- | Decoupled variant of 'rpSwitchB'. drpSwitchB :: (Applicative m, Monad m, Traversable f) => f (Wire m a b) -> Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b) drpSwitchB wires'' = WGen $ \ws (x', ev) -> do r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires'' let xs = T.sequenceA . fmap fst $ r wires' = fmap snd r wires = maybe id id ev wires' return (xs, rpSwitchB wires) -- | Decoupled variant of 'rSwitch'. drSwitch :: Monad m => Wire m a b -> Wire m (a, Event (Wire m a b)) b drSwitch w1' = WGen $ \ws (x', swEv) -> do (mx, w1) <- toGen w1' ws x' let w = maybe w1 id swEv w `seq` return (mx, drSwitch w) -- | Decoupled variant of 'switch'. dSwitch :: Monad m => Wire m a (b, Event c) -> (c -> Wire m a b) -> Wire m a b dSwitch w1' f = WGen $ \ws x' -> do (m, w1) <- toGen w1' ws x' case m of Left ex -> return (Left ex, dSwitch w1 f) Right (x, swEv) -> case swEv of Nothing -> return (Right x, dSwitch w1 f) Just sw -> return (Right x, f sw) -- | Route signal to a collection of signal functions using the supplied -- routing function. If any of the wires inhibits, the whole network -- inhibits. par :: (Applicative m, Monad m, Traversable f) => (forall w. a -> f w -> f (b, w)) -> f (Wire m b c) -> Wire m a (f c) par route wires'' = WGen $ \ws x'' -> do let wires' = route x'' wires'' r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires' let xs = T.sequenceA . fmap fst $ r wires = fmap snd r return (xs, par route wires) -- | Broadcast signal to a collection of signal functions. If any of -- the wires inhibits, then the whole parallel network inhibits. parB :: (Applicative m, Monad m, Traversable f) => f (Wire m a b) -> Wire m a (f b) parB wires' = WGen $ \ws x' -> do r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires' let xs = T.sequenceA . fmap fst $ r wires = fmap snd r return (xs, parB wires) -- | Recurrent parallel routing switch. This combinator acts like -- 'par', but takes an additional event signal, which can transform the -- set of wires. This is the most powerful switch. -- -- Just like 'par' if any of the wires inhibits, the whole network -- inhibits. rpSwitch :: (Applicative m, Monad m, Traversable f) => (forall w. a -> f w -> f (b, w)) -> f (Wire m b c) -> Wire m (a, Event (f (Wire m b c) -> f (Wire m b c))) (f c) rpSwitch route wires''' = WGen $ \ws (x'', ev) -> do let wires'' = maybe id id ev wires''' wires' = route x'' wires'' r <- T.sequenceA $ fmap (\(x', w') -> toGen w' ws x') wires' let xs = T.sequenceA . fmap fst $ r wires = fmap snd r return (xs, rpSwitch route wires) -- | Recurrent parallel broadcast switch. This combinator acts like -- 'parB', but takes an additional event signal, which can transform the -- set of wires. -- -- Just like 'parB' if any of the wires inhibits, the whole network -- inhibits. rpSwitchB :: (Applicative m, Monad m, Traversable f) => f (Wire m a b) -> Wire m (a, Event (f (Wire m a b) -> f (Wire m a b))) (f b) rpSwitchB wires'' = WGen $ \ws (x', ev) -> do let wires' = maybe id id ev wires'' r <- T.sequenceA $ fmap (\w' -> toGen w' ws x') wires' let xs = T.sequenceA . fmap fst $ r wires = fmap snd r return (xs, rpSwitchB wires) -- | Combinator for recurrent switches. The wire produced by this -- switch takes switching events and switches to the wires contained in -- the events. The first argument is the initial wire. rSwitch :: Monad m => Wire m a b -> Wire m (a, Event (Wire m a b)) b rSwitch w1 = WGen $ \ws (x', swEv) -> do let w' = maybe w1 id swEv (mx, w) <- toGen w' ws x' return (mx, rSwitch w) -- | This is the most basic switching combinator. It is an event-based -- one-time switch. -- -- The first argument is the initial wire, which may produce a switching -- event at some point. When this event is produced, then the signal -- path switches to the wire produced by the second argument function. switch :: Monad m => Wire m a (b, Event c) -> (c -> Wire m a b) -> Wire m a b switch w1' f = WGen $ \ws x' -> do (m, w1) <- toGen w1' ws x' case m of Left ex -> return (Left ex, switch w1 f) Right (x, swEv) -> case swEv of Nothing -> return (Right x, switch w1 f) Just sw -> toGen (f sw) (ws { wsDTime = 0 }) x'