module Control.Concurrent.STM.TChan.TChanB_ where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan.TChanL hiding (chanLoad)
import qualified Control.Concurrent.STM.TChan.TChanL as TCHL (chanLoad)
import Data.List
import Data.MyHelpers
data TChanB a =
TChanB {
tcbChanL :: TChanL a
, tcbCapacity :: TVar ChanCapacity
}
chanCapacity :: TChanB a -> STM ChanCapacity
chanCapacity tchb = readTVar $ tcbCapacity tchb
changeChanCapacity :: ChanCapacity -> TChanB a -> STM ()
changeChanCapacity cap tchb = writeTVar (tcbCapacity tchb) cap
chanLoad :: TChanB a -> STM ChanCapacity
chanLoad tchb = TCHL.chanLoad $ tcbChanL tchb
newTChanB :: ChanCapacity -> STM (TChanB a)
newTChanB cap = do
tch <- newTChanL
tv <- newTVar cap
return TChanB {
tcbChanL = tch
, tcbCapacity = tv
}
newTChanB_IO :: ChanCapacity -> IO (TChanB a)
newTChanB_IO cap = atomically $ newTChanB cap
elasticWriteTChanB :: PermitToBlock -> TChanB a -> a -> STM WriteSucceeded
elasticWriteTChanB block_dowe tchb a = do
load <- chanLoad tchb
cap <- chanCapacity tchb
case load < cap of
True -> return True << writeTChanL (tcbChanL tchb) a
False -> case block_dowe of
True -> retry
False -> return False
writeTChanB :: TChanB a -> a -> STM ()
writeTChanB tchb a = return () << elasticWriteTChanB True tchb a
readTChanB :: TChanB a -> STM a
readTChanB tchb = readTChanL (tcbChanL tchb)
isEmptyTChanB :: TChanB a -> STM Bool
isEmptyTChanB tchb = isEmptyTChanL (tcbChanL tchb)
freeSpaceInTChanB :: TChanB a -> STM ChanContentAmountMeasure
freeSpaceInTChanB tchb = do
load <- chanLoad tchb
cap <- chanCapacity tchb
return (cap load)
tryReadTChanB :: TChanB a -> STM (Maybe a)
tryReadTChanB tchb = tryReadTChanL $ tcbChanL tchb
tryWriteTChanB :: TChanB a -> a -> STM Bool
tryWriteTChanB = elasticWriteTChanB False
getTChanBContents :: TChanB a -> STM [a]
getTChanBContents = getTChanLContents . tcbChanL
elacticWriteList2TChanB :: PermitToBlock -> TChanB a -> [a] -> STM [a]
elacticWriteList2TChanB block_dowe tchb l = do
available_space <- freeSpaceInTChanB tchb
let (to_load, rest) = splitAt available_space l
case block_dowe of
False -> do
writeList2TChanL (tcbChanL tchb) to_load
return rest
True ->
case rest of
[] -> do
writeList2TChanL (tcbChanL tchb) to_load
return []
_ -> retry
filterOutTChanBElements :: (a -> TakeElementOutShouldWe) -> TChanB a -> STM [a]
filterOutTChanBElements p tchb = do
l <- getTChanBContents tchb
let (takeout, stay) = partition p l
didnt_fit_back <- writeList2TChanL (tcbChanL tchb) stay
return takeout
viewChanBContent :: TChanB a -> STM [a]
viewChanBContent tchb = viewChanLContent (tcbChanL tchb)