netwire-1.2.4: FRP/NetWire/Request.hs

-- |
-- Module:     FRP.NetWire.Request
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Unique identifiers.

module FRP.NetWire.Request
    ( -- * Context-sensitive time
      context,
      contextInt,
      contextLimited,
      contextLimitedInt,

      -- * Identifiers.
      identifier
    )
    where

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


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

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


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


-- | Same as 'context', but with a time limit.  The left signal
-- specifies a threshold and the middle 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 m. (Ord a, Monad m) => Wire m a b -> Wire m (Int, Time, a) b
contextLimited w0 = context' M.empty 0
    where
    context' :: Map a (Time, Wire m a b) -> Time -> Wire m (Int, Time, a) b
    context' tm'' t' =
        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx) -> do
            let t = t' + dt'
            let (dt, w') = case M.lookup ctx tm'' of
                             Nothing       -> (t, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx
            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)


-- | 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 b m. Monad m => Wire m Int b -> Wire m (Int, Time, Int) b
contextLimitedInt w0 = context' IM.empty 0
    where
    context' :: IntMap (Time, Wire m Int b) -> Time -> Wire m (Int, Time, Int) b
    context' tm'' t' =
        mkGen $ \ws@(wsDTime -> dt') (limit, maxAge, ctx) -> do
            let t = t' + dt'
            let (dt, w') = case IM.lookup ctx tm'' of
                             Nothing       -> (t, w0)
                             Just (lt, w') -> (t - lt, w')
            (mx, w) <- dt `seq` toGen w' (ws { wsDTime = dt }) ctx
            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)


-- | Choose a unique identifier when switching in and keep it.
--
-- Never inhibits.

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, constant req)