Wire.hs

-- |
-- Module:     FRP.NetWire.Wire
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- The module contains the main 'Wire' type and its type class
-- instances.  It also provides convenience functions for wire
-- developers.

module FRP.NetWire.Wire
    ( -- * Wires
      Wire(..),
      WireState(..),

      -- * Auxilliary types
      InhibitException(..),
      Output,
      SF,
      Time,

      -- * Utilities
      cleanupWireState,
      inhibitEx,
      initWireState,
      mkFix,
      mkGen,
      noEvent,
      toGen,

      -- * Wire transformers
      appEvent,
      appFirst,
      appFrozen
    )
    where

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Concurrent.STM
import Control.Exception (Exception(..), SomeException)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Functor.Identity
import Data.Typeable
import Prelude hiding ((.), id)
import System.Random.Mersenne


-- | Inhibition exception with an informative message.  This exception
-- is the result of signal inhibition, where no further exception
-- information is available.

data InhibitException =
    InhibitException String
    deriving (Read, Show, Typeable)

instance Exception InhibitException


-- | Functor for output signals.

type Output = Either SomeException


-- | Signal functions are wires over the identity monad.

type SF = Wire Identity


-- | Time.

type Time = Double


-- | A wire is a network of signal transformers.

data Wire :: (* -> *) -> * -> * -> * where
    WArr :: (a -> b) -> Wire m a b
    WGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b


-- | This instance corresponds to the 'ArrowPlus' and 'ArrowZero'
-- instances.

instance Monad m => Alternative (Wire m a) where
    empty = zeroArrow
    (<|>) = (<+>)


-- | Applicative interface to signal networks.

instance Monad m => Applicative (Wire m a) where
    pure = arr . const
    wf <*> wx = wf &&& wx >>> arr (uncurry ($))


-- | Arrow interface to signal networks.

instance Monad m => Arrow (Wire m) where
    arr = WArr

    first (WGen f) = WGen $ \ws (x', y) -> liftM (fmap (, y) *** first) (f ws x')
    first (WArr f) = WArr (first f)

    second (WGen f) = WGen $ \ws (x, y') -> liftM (fmap (x,) *** second) (f ws y')
    second (WArr f) = WArr (second f)

    (***) = wsidebyside 0
    (&&&) = wboth 0


-- | The 'app' combinator has the behaviour of 'appFrozen'.  Note that
-- this effectively keeps a wire bound by the "-<<" syntax from
-- evolving.  For alternative embedding combinators see also 'appEvent'
-- and 'appFirst'.

instance Monad m => ArrowApply (Wire m) where
    app = appFrozen


-- | Signal routing.  Unused routes are ignored.  Note that they still
-- run in real time, i.e. the time deltas passed are accumulated.

instance Monad m => ArrowChoice (Wire m) where
    left w' = wl 0
        where
        wl t' =
            WGen $ \ws@(wsDTime -> dt) mx' ->
                let t = t' + dt in
                t `seq`
                case mx' of
                  Left x' -> liftM (fmap Left *** left) (toGen w' (ws { wsDTime = t }) x')
                  Right x -> return (pure (Right x), wl t)

    right w' = wl 0
        where
        wl t' =
            WGen $ \ws@(wsDTime -> dt) mx' ->
                let t = t' + dt in
                t `seq`
                case mx' of
                  Right x' -> liftM (fmap Right *** right) (toGen w' (ws { wsDTime = t }) x')
                  Left x   -> return (pure (Left x), wl t)

    wf' +++ wg' = wl 0 0 wf' wg'
        where
        wl tf' tg' wf' wg' =
            WGen $ \ws@(wsDTime -> dt) mx' ->
                let tf = tf' + dt
                    tg = tg' + dt in
                tf `seq` tg `seq`
                case mx' of
                  Left x'  -> do
                      (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'
                      return (fmap Left mx, wl 0 tg wf wg')
                  Right x' -> do
                      (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'
                      return (fmap Right mx, wl tf 0 wf' wg)

    wf' ||| wg' = wl 0 0 wf' wg'
        where
        wl tf' tg' wf' wg' =
            WGen $ \ws@(wsDTime -> dt) mx' ->
                let tf = tf' + dt
                    tg = tg' + dt in
                tf `seq` tg `seq`
                case mx' of
                  Left x'  -> do
                      (mx, wf) <- toGen wf' (ws { wsDTime = tf }) x'
                      return (mx, wl 0 tg wf wg')
                  Right x' -> do
                      (mx, wg) <- toGen wg' (ws { wsDTime = tg }) x'
                      return (mx, wl tf 0 wf' wg)


-- | Value recursion.  Warning: Recursive signal networks must never
-- inhibit.  Make use of 'FRP.NetWire.Tools.exhibit' or
-- 'FRP.NetWire.Event.event' for wires that may inhibit.

instance MonadFix m => ArrowLoop (Wire m) where
    loop w' =
        WGen $ \ws x' -> do
            rec (Right (x, d), w) <- toGen w' ws (x', d)
            return (Right x, loop w)


-- | Left-biased signal network combination.  If the left arrow
-- inhibits, the right arrow is tried.  If both inhibit, their
-- combination inhibits.  Ignored wire networks still run in real time,
-- i.e. passed time deltas are accumulated.

instance Monad m => ArrowPlus (Wire m) where
    wf'@(WGen _) <+> wg' = wl 0 wf' wg'
        where
        wl t' wf' wg' =
            WGen $ \ws@(wsDTime -> dt) x' -> do
                let t = t' + dt
                (mx, wf) <- toGen wf' ws x'
                case mx of
                  Right _ -> t `seq` return (mx, wl t wf wg')
                  Left _  -> do
                    (mx2, wg) <- t `seq` toGen wg' (ws { wsDTime = t }) x'
                    return (mx2, wl 0 wf wg)

    wa@(WArr _)   <+> _ = wa


-- | The zero arrow always inhibits.

instance Monad m => ArrowZero (Wire m) where
    zeroArrow = mkFix $ \_ _ -> return (Left (inhibitEx "Signal inhibited"))


-- | Identity signal network and signal network sequencing.

instance Monad m => Category (Wire m) where
    id = WArr id
    (.) = flip (wcompose 0)


-- | Map over the output of a signal network.

instance Monad m => Functor (Wire m a) where
    fmap f = (>>> arr f)


-- | The state of the wire.

data WireState :: (* -> *) -> * where
    ImpureState ::
        MonadIO m =>
        { wsDTime  :: Double,   -- ^ Time difference for current instant.
          wsRndGen :: MTGen,    -- ^ Random number generator.
          wsReqVar :: TVar Int  -- ^ Request counter.
        } -> WireState m

    PureState :: { wsDTime :: Double } -> WireState m


-- | Embeds the input wire (left signal) into the network with the given
-- input signal (right signal).  Each time the input wire is a 'Just',
-- the current state of the last wire is discarded and the new wire is
-- evolved instead.  New wires can be generated by an event wire and
-- catched via 'FRP.NetWire.Event.event'.  The initial wire is given by
-- the argument.
--
-- Inhibits whenever the embedded wire inhibits.  Same feedback
-- behaviour as the embedded wire.

appEvent ::
    forall a b m. Monad m
    => Wire m a b
    -> Wire m (Maybe (Wire m a b), a) b
appEvent cw' =
    mkGen $ \ws (mw, x') -> do
        let w' = maybe cw' id mw
        (mx, w) <- toGen w' ws x'
        return (mx, appEvent w)


-- | Embeds the first received input wire (left signal) into the
-- network, feeding it the right signal.  This wire respects its left
-- signal only in the first instant, after which it wraps that wire's
-- evolution.
--
-- Inhibits whenever the embedded wire inhibits.  Same feedback
-- behaviour as the embedded wire.

appFirst :: forall a b m. Monad m => Wire m (Wire m a b, a) b
appFirst =
    mkGen $ \ws (w', x') -> do
        (mx, w) <- toGen w' ws x'
        return (mx, embed w)

    where
    embed :: Wire m a b -> Wire m (Wire m a b, a) b
    embed w' =
        mkGen $ \ws (_, x') -> do
            (mx, w) <- toGen w' ws x'
            return (mx, embed w)


-- | Embeds the first instant of the input wire (left signal) into the
-- network, feeding it the right signal.  This wire respects its left
-- signal in all instances, such that the embedded wire cannot evolve.
--
-- Inhibits whenever the embedded wire inhibits.  Same feedback
-- behaviour as the embedded wire.

appFrozen :: Monad m => Wire m (Wire m a b, a) b
appFrozen = mkFix $ \ws (w, x') -> liftM fst (toGen w ws x')


-- | Clean up wire state.

cleanupWireState :: WireState m -> IO ()
cleanupWireState _ = return ()


-- | Construct an 'InhibitException' wrapped in a 'SomeException'.

inhibitEx :: String -> SomeException
inhibitEx = toException . InhibitException


-- | Initialize wire state.

initWireState :: MonadIO m => IO (WireState m)
initWireState =
    ImpureState
    <$> pure 0
    <*> getStdGen
    <*> newTVarIO 0


-- | Create a fixed wire from the given function.  This is a smart
-- constructor.  It creates a stateless wire.

mkFix :: Monad m => (WireState m -> a -> m (Output b)) -> Wire m a b
mkFix f = let w = WGen $ \ws -> liftM (, w) . f ws in w


-- | Create a generic (i.e. possibly stateful) wire from the given
-- function.  This is a smart constructor.  Please use it instead of the
-- 'WGen' constructor for creating generic wires.

mkGen :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b
mkGen = WGen


-- | Construct an 'InhibitException' wrapped in a 'SomeException' with a
-- message indicating that a certain event did not happen.

noEvent :: SomeException
noEvent = inhibitEx "No event"


-- | Extract the transition function of a wire.  Unless there is reason
-- (like optimization) to pattern-match against the 'Wire' constructors,
-- this function is the recommended way to evolve a wire.

toGen :: Monad m => Wire m a b -> WireState m -> a -> m (Output b, Wire m a b)
toGen (WGen f)    ws x = f ws x
toGen wf@(WArr f) _  x = return (Right (f x), wf)


-- | Efficient signal sharing.

wboth :: Monad m => Time -> Wire m a b -> Wire m a c -> Wire m a (b, c)
wboth t' (WGen f) wg'@(WGen g) =
    WGen $ \ws@(wsDTime -> dt) x' -> do
        let t = t' + dt
        (mx1, wf) <- t `seq` f ws x'
        case mx1 of
          Left ex -> return (Left ex, wboth t wf wg')
          Right _ -> do
              (mx2, wg) <- g ws x'
              return (liftA2 (,) mx1 mx2, wboth 0 wf wg)

wboth t' wf@(WArr f) (WGen g) =
    WGen $ \ws x' -> do
        (mx2, wg) <- g ws x'
        return (fmap (f x',) mx2, wboth t' wf wg)

wboth t' (WGen f) wg@(WArr g) =
    WGen $ \ws x' -> do
        (mx1, wf) <- f ws x'
        return (fmap (, g x') mx1, wboth t' wf wg)

wboth _ (WArr f) (WArr g) = WArr (f &&& g)


-- | Efficient forward-composition of two wires.

wcompose :: Monad m => Time -> Wire m a b -> Wire m b c -> Wire m a c
wcompose t' (WGen f) wg'@(WGen g) =
    WGen $ \ws@(wsDTime -> dt) x'' -> do
        let t = t' + dt
        (mx', wf) <- t `seq` f ws x''
        case mx' of
          Left ex  -> return (Left ex, wcompose t wf wg')
          Right x' -> do
              (mx, wg) <- g (ws { wsDTime = t }) x'
              return (mx, wcompose 0 wf wg)

wcompose t' wf@(WArr f) (WGen g) =
    WGen $ \ws x' -> do
        (mx, wg) <- g ws (f x')
        return (mx, wcompose t' wf wg)

wcompose t' (WGen f) wg@(WArr g) =
    WGen $ \ws x' -> do
        (mx, wf) <- f ws x'
        return (fmap g mx, wcompose t' wf wg)

wcompose _ (WArr f) (WArr g) = WArr (g . f)


-- | Run two signals through two signal networks.

wsidebyside :: Monad m => Time -> Wire m a c -> Wire m b d -> Wire m (a, b) (c, d)
wsidebyside t' (WGen f) wg'@(WGen g) =
    WGen $ \ws@(wsDTime -> dt) (x', y') -> do
        let t = t' + dt
        (mx, wf) <- t `seq` f ws x'
        case mx of
          Left ex -> return (Left ex, wsidebyside t wf wg')
          Right _ -> do
              (my, wg) <- g ws y'
              return (liftA2 (,) mx my, wsidebyside 0 wf wg)

wsidebyside t' wf@(WArr f) (WGen g) =
    WGen $ \ws (x', y') -> do
        (my, wg) <- g ws y'
        return (fmap (f x',) my, wsidebyside t' wf wg)

wsidebyside t' (WGen f) wg@(WArr g) =
    WGen $ \ws (x', y') -> do
        (mx, wf) <- f ws x'
        return (fmap (, g y') mx, wsidebyside t' wf wg)

wsidebyside _ (WArr f) (WArr g) = WArr (f *** g)