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.

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

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

      -- * Utilities
      cleanupWireState,
      inhibitEx,
      initWireState,
      mkGen,
      noEvent,
      toGen
    )
    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


-- | Signal routing.  Unused routes are frozen, until they are put back
-- into use.

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'.

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.

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 = mkGen $ \_ _ -> return (Left (inhibitEx "Signal inhibited"), zeroArrow)


-- | Identity signal network and signal network sequencing.

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


-- | Map over the result 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


-- | 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 generic wire from the given function.  This is a smart
-- constructor.  Please use it instead of the 'WGen' constructor.

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.

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)