module FRP.NetWire.Request
(
MgrMsg(..),
manager,
context,
contextInt,
contextLimited,
contextLimitedInt,
context_,
contextInt_,
contextLimited_,
contextLimitedInt_,
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
data MgrMsg k m a b
= MgrNop
| MgrMulti (MgrMsg k m a b) (MgrMsg k m a b)
| MgrAdd k (Wire m a b)
| MgrDel k
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
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)
context_ :: (Ord ctx, Monad m) => Wire m ctx b -> Wire m ctx b
context_ w0 = arr (, ()) >>> context (arr fst >>> w0)
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)
contextInt_ :: Monad m => Wire m Int b -> Wire m Int b
contextInt_ w0 = arr (, ()) >>> contextInt (arr fst >>> w0)
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)
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)
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)
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)
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)
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