{-
Copyright (C) 2009-2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>

All rights reserved.

For license and copyright information, see the file COPYRIGHT
-}

--------------------------------------------------------------------------
--------------------------------------------------------------------------

-- | @'TChanL' = 'TChan' + 'TVar' 'ChanLoad'@
--
-- @'TChanB' = 'TChanL' + 'TVar' 'ChanCapacity'@
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

-- | The \"elastic-\" prefix stands for the opportunity to regulate
-- with option 'PermitToBlock'
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

-- | Wrapper around 'elasticWriteTChanB':
-- @writeTChanB tchb a = return () << elasticWriteTChanB True tchb a@
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)

-- | @freeSpace = 'chanCapacity' - 'chanLoad'@
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

-- | Wrapper around 'elasticWriteTChanB':
-- @tryWriteTChanB = elasticWriteTChanB False@
tryWriteTChanB :: TChanB a -> a -> STM Bool
tryWriteTChanB = elasticWriteTChanB False

-- | Take everything from channel, and leave it empty.
getTChanBContents :: TChanB a -> STM [a]
getTChanBContents = getTChanLContents . tcbChanL

-- | This procedure is highly uneffective and is dangerous,
-- when @'PermitToBlock'@ is on.
-- Since it won't complete unless there is enough free space in the channnel.
-- Even the part of input that fits won't commit to get into the channel.
-- If capacity isn't enough, it won't ever commit,
-- unless the capacity is made bigger.
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

-- | Just filter out elements. Is abstracted over implementation,
-- so doesn't suffer from possible inconsistency between capacity
-- and load (when capacity < load).
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)