Request.hs

-- |
-- Module:     FRP.NetWire.Request
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Object managers, unique identifiers and context-sensitive wires.

module FRP.NetWire.Request
    ( -- * Containers
      MgrMsg(..),
      manager,

      -- * Context-sensitive mutation
      context,
      contextInt,
      contextLimited,
      contextLimitedInt,
      -- ** Simple variants
      context_,
      contextInt_,
      contextLimited_,
      contextLimitedInt_,

      -- * Identifiers.
      identifier
    )
    where

import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Traversable as T
import Control.Arrow
import Control.Monad.IO.Class
import Control.Concurrent.STM
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Monoid
import FRP.NetWire.Wire


-- | Messages to wire managers (see the 'manager' wire).

data MgrMsg k m a b
    -- | Do nothing.  Send this, if the wire shouldn't be changed in an
    -- instant.
    = MgrNop

    -- | Perform two operations in an instant.
    | MgrMulti (MgrMsg k m a b) (MgrMsg k m a b)

    -- | Add the given wire with the given key.  If the manager already
    -- has a wire with this key, it is overwritten.
    | MgrAdd k (Wire m a b)

    -- | Delete the wire with the given key, if it exists.
    | MgrDel k

-- | The monoid instance can be used to combine multiple manager
-- operations.  They are performed from left to right.  This instance
-- tries hard to optimize operations away without sacrificing
-- performance.

instance Eq k => Monoid (MgrMsg k m a b) where
    mempty = MgrNop

    mappend MgrNop y = y
    mappend x MgrNop = x
    mappend (MgrAdd k1 _) y@(MgrAdd k2 _) | k1 == k2 = y
    mappend (MgrDel k1)   y@(MgrAdd k2 _) | k1 == k2 = y
    mappend (MgrAdd k1 _)   (MgrDel k2)   | k1 == k2 = MgrNop
    mappend (MgrDel k1)   y@(MgrDel k2)   | k1 == k2 = y
    mappend x y = MgrMulti x y


-- | Make the given wire context-sensitive.  The left input signal is a
-- context and the argument wire will mutate individually for each such
-- context.
--
-- Inherits inhibition and feedback behaviour from the current context's
-- wire.

context :: forall a b ctx m. (Ord ctx, Monad m) => Wire m (ctx, a) b -> Wire m (ctx, a) b
context w0 = context' M.empty 0
    where
    context' :: Map ctx (Time, Wire m (ctx, a) b) -> Time -> Wire m (ctx, a) b
    context' tm' t' =
        mkGen $ \ws@(wsDTime -> dt') inp@(ctx, _) -> do
            let t = t' + dt'
            let (dt, w') = case M.lookup ctx tm' of
                             Nothing       -> (0, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) inp
            let tm = M.insert ctx (t, w) tm'
            return (mx, context' tm t)


-- | Simplified variant of 'context'.  Takes a context signal only.

context_ :: (Ord ctx, Monad m) => Wire m ctx b -> Wire m ctx b
context_ w0 = arr (, ()) >>> context (arr fst >>> w0)


-- | Specialized version of 'context'.  Use this one, if your contexts
-- are 'Int's and you have a lot of them.
--
-- Inherits inhibition and feedback behaviour from the current context's
-- wire.

contextInt :: forall a b m. Monad m => Wire m (Int, a) b -> Wire m (Int, a) b
contextInt w0 = context' IM.empty 0
    where
    context' :: IntMap (Time, Wire m (Int, a) b) -> Time -> Wire m (Int, a) b
    context' tm' t' =
        mkGen $ \ws@(wsDTime -> dt') inp@(ctx, _) -> do
            let t = t' + dt'
            let (dt, w') = case IM.lookup ctx tm' of
                             Nothing       -> (0, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) inp
            let tm = IM.insert ctx (t, w) tm'
            return (mx, context' tm t)


-- | Simplified variant of 'contextInt'.  Takes a context signal only.

contextInt_ :: Monad m => Wire m Int b -> Wire m Int b
contextInt_ w0 = arr (, ()) >>> contextInt (arr fst >>> w0)


-- | Same as 'context', but with a time limit.  The first signal
-- specifies a threshold and the second signal specifies a maximum age.
-- If the current number of contexts exceeds the threshold, then all
-- contexts exceeding the maximum age are deleted.
--
-- Inherits inhibition and feedback behaviour from the current context's
-- wire.

contextLimited :: forall a b ctx m. (Ord ctx, Monad m) => Wire m (ctx, a) b -> Wire m (Int, Time, ctx, a) b
contextLimited w0 = context' M.empty 0
    where
    context' :: Map ctx (Time, Wire m (ctx, a) b) -> Time -> Wire m (Int, Time, ctx, a) b
    context' tm'' t' =
        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx, x') -> do
            let t = t' + dt'
            let (dt, w') = case M.lookup ctx tm'' of
                             Nothing       -> (0, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) (ctx, x')
            let tm' = M.insert ctx (t, w) tm''
                tm = if M.size tm' <= limit
                       then tm'
                       else M.filter (\(ct, _) -> t - ct <= maxAge) tm'

            return (mx, context' tm t)


-- | Simplified variant of 'contextLimited'.  Takes a context signal
-- only.

contextLimited_ :: (Ord ctx, Monad m) => Wire m ctx b -> Wire m (Int, Time, ctx) b
contextLimited_ w0 =
    arr (\(thr, maxAge, ctx) -> (thr, maxAge, ctx, ())) >>>
    contextLimited (arr fst >>> w0)


-- | Specialized version of 'contextLimited'.  Use this one, if your
-- contexts are 'Int's and you have a lot of them.
--
-- Inherits inhibition and feedback behaviour from the current context's
-- wire.

contextLimitedInt :: forall a b m. Monad m => Wire m (Int, a) b -> Wire m (Int, Time, Int, a) b
contextLimitedInt w0 = context' IM.empty 0
    where
    context' :: IntMap (Time, Wire m (Int, a) b) -> Time -> Wire m (Int, Time, Int, a) b
    context' tm'' t' =
        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx, x') -> do
            let t = t' + dt'
            let (dt, w') = case IM.lookup ctx tm'' of
                             Nothing       -> (0, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) (ctx, x')
            let tm' = IM.insert ctx (t, w) tm''
                tm = if IM.size tm' <= limit
                       then tm'
                       else IM.filter (\(ct, _) -> t - ct <= maxAge) tm'

            return (mx, context' tm t)


-- | Simplified variant of 'contextLimitedInt'.  Takes a context signal
-- only.

contextLimitedInt_ :: Monad m => Wire m Int b -> Wire m (Int, Time, Int) b
contextLimitedInt_ w0 =
    arr (\(thr, maxAge, ctx) -> (thr, maxAge, ctx, ())) >>>
    contextLimitedInt (arr fst >>> w0)


-- | Choose a new unique identifier at every instant.
--
-- Never inhibits.  Feedback by delay.

identifier :: MonadIO m => Wire m a Int
identifier =
    mkGen $ \ws _ -> do
        let reqVar = wsReqVar ws
        req <- liftIO . atomically $ do
                   req' <- readTVar reqVar
                   let req = succ req'
                   req `seq` writeTVar reqVar (succ req')
                   return req'
        return (Right req, identifier)


-- | Wire manager, which can be manipulated during the session.  This is
-- a convenient alternative to parallel switches.
--
-- This wire manages a set of subwires, each indexed by a key.  Through
-- messages new subwires can be added and existing ones can be deleted.
--
-- Inhibits, whenever one of the managed wires inhibits.  Inherits
-- feedback behaviour from the worst managed wire.

manager :: forall a b k m. (Monad m, Ord k) => Wire m (a, MgrMsg k m a b) (Map k b)
manager = mgr M.empty
    where
    mgr :: Map k (Wire m a b) -> Wire m (a, MgrMsg k m a b) (Map k b)
    mgr wires'' =
        mkGen $ \ws (x', msg) -> do
            let wires' = processMsg msg wires''
            wires <- T.mapM (\w -> toGen w ws x') wires'
            return (T.sequenceA (fmap fst wires), mgr (fmap snd wires))

    processMsg :: MgrMsg k m a b -> Map k (Wire m a b) -> Map k (Wire m a b)
    processMsg MgrNop = id
    processMsg (MgrMulti m1 m2) = processMsg m2 . processMsg m1
    processMsg (MgrAdd k w) = M.insert k w
    processMsg (MgrDel k) = M.delete k