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


-- | Events are signals, which can be absent.  They usually denote
-- discrete occurences of certain events.

--type Event = Maybe


-- | 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
    WConst :: b -> Wire m a b
    WGen   :: (WireState m -> a -> m (Output b, Wire m a b)) -> Wire m a b
    WId    :: Wire m a a


-- | 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 = WConst

    wf' <*> wx' =
        WGen $ \ws x' -> do
            (cf, wf) <- toGen wf' ws x'
            (cx, wx) <- toGen wx' ws x'
            return (cf <*> cx, wf <*> wx)


-- | 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)
    first (WConst c) = WArr (first (const c))
    first WId = WId

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

    wf *** WId = first wf
    WId *** wg = second wg
    wf' *** wg' =
        WGen $ \ws (x', y') -> do
            (cx, wf) <- toGen wf' ws x'
            (cy, wg) <- toGen wg' ws y'
            return (liftA2 (,) cx cy, wf *** wg)

    wf' &&& wg' =
        WGen $ \ws x' -> do
            (cx1, wf) <- toGen wf' ws x'
            (cx2, wg) <- toGen wg' ws x'
            return (liftA2 (,) cx1 cx2, wf &&& wg)


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

instance Monad m => ArrowChoice (Wire m) where
    left w' = wl
        where
        wl =
            WGen $ \ws mx' ->
                case mx' of
                  Left x' -> liftM (fmap Left *** left) (toGen w' ws x')
                  Right x -> return (pure (Right x), wl)

    right w' = wl
        where
        wl =
            WGen $ \ws mx' ->
                case mx' of
                  Right x' -> liftM (fmap Right *** right) (toGen w' ws x')
                  Left x   -> return (pure (Left x), wl)

    wf' +++ wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x'  -> liftM (fmap Left *** (+++ wg')) (toGen wf' ws x')
              Right x' -> liftM (fmap Right *** (wf' +++)) (toGen wg' ws x')

    wf' ||| wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x'  -> liftM (second (||| wg')) (toGen wf' ws x')
              Right x' -> liftM (second (wf' |||)) (toGen wg' ws x')


-- | Value recursion.  Warning: Recursive signal networks must never
-- inhibit.  Use '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
    WGen f <+> wg =
        WGen $ \ws x' -> do
            (mx, w1) <- f ws x'
            case mx of
              Right _ -> return (mx, w1 <+> wg)
              Left _  -> do
                  (mx2, w2) <- toGen wg ws x'
                  return (mx2, w1 <+> w2)

    wa@(WArr _)   <+> _ = wa
    wc@(WConst _) <+> _ = wc
    WId           <+> _ = WId


-- | 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 = WId

    -- Combining two general wires.
    wf@(WGen f) . WGen g =
        WGen $ \ws x'' -> do
            (mx', w1) <- g ws x''
            case mx' of
              Left ex  -> return (Left ex, wf . w1)
              Right x' -> do
                  (mx, w2) <- f ws x'
                  return (mx, w2 . w1)

    -- Combining a special wire with a general wire.
    wf@(WArr f) . WGen g =
        WGen $ \ws x' -> do
            (mx, w) <- g ws x'
            return (fmap f mx, wf . w)
    wc@(WConst c) . WGen g =
        WGen $ \ws x' -> do
            (mx, w) <- g ws x'
            return (fmap (const c) mx, wc . w)
    WGen f . wg@(WArr g) =
        WGen $ \ws x' -> do
            (mx, w) <- f ws (g x')
            return (mx, w . wg)
    WGen f . wc@(WConst c) =
        WGen $ \ws _ -> do
            (mx, w) <- f ws c
            return (mx, w . wc)

    -- Combining special wires.
    WArr f . WArr g = WArr (f . g)
    WArr f . WConst c = WArr (const (f c))

    WConst c . WArr _ = WConst c
    WConst c . WConst _ = WConst c

    WId . w2 = w2
    w1 . WId = w1


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

instance Monad m => Functor (Wire m a) where
    fmap f (WGen w') =
        WGen $ \ws x' -> do
            (x, w) <- w' ws x'
            return (fmap f x, fmap f w)
    fmap f (WArr g) = WArr (f . g)
    fmap f (WConst c) = WConst (f c)
    fmap f WId = WArr 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)
toGen wc@(WConst c) _  _ = return (Right c, wc)
toGen wi@WId        _  x = return (Right x, wi)