module FRP.NetWire.Request
(
context,
contextInt,
contextLimited,
contextLimitedInt,
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
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)
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)
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)
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)
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)