-- |
-- 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
      Event,
      InhibitException,
      Output,
      SF,
      Time,

      -- * Utilities
      cleanupWireState,
      inhibitEx,
      initWireState,
      mkGen,
      toGen
    )
    where

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Concurrent.STM
import Control.Exception (Exception(..), SomeException)
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


-- | The output of a wire.  When the wire inhibits, then this will be a
-- 'Left' value with an exception.

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


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


instance Monad m => Applicative (Wire m a) where
    pure = WConst

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


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

    first (WGen f) =
        WGen $ \ws (x', y) -> do
            (mx, w) <- f ws x'
            return (fmap (,y) mx, first w)
    first (WArr f) = WArr (first f)
    first (WConst c) = WArr (first (const c))
    first WId = WId

    second (WGen f) =
        WGen $ \ws (x, y') -> do
            (my, w) <- f ws y'
            return (fmap (x,) my, second w)
    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
            (mx, wf) <- toGen wf' ws x'
            (my, wg) <- toGen wg' ws y'
            return (liftA2 (,) mx my, wf *** wg)

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


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

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

    wf' +++ wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x' -> do
                  (mx, wf) <- toGen wf' ws x'
                  return (fmap Left mx, wf +++ wg')
              Right x' -> do
                  (mx, wg) <- toGen wg' ws x'
                  return (fmap Right mx, wf' +++ wg)

    wf' ||| wg' =
        WGen $ \ws mx' ->
            case mx' of
              Left x' -> do
                  (mx, wf) <- toGen wf' ws x'
                  return (mx, wf ||| wg')
              Right x' -> do
                  (mx, wg) <- toGen wg' ws x'
                  return (mx, wf' ||| wg)


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


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


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


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


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