Switch.hs

-- |
-- 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,

      -- * Embedding wires
      appEvent,
      appFirst,
      appFrozen
    )
    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, Maybe (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, Maybe (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, Maybe (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, Maybe 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, Maybe (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, Maybe (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, Maybe (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, Maybe 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'