TChanL_.hs

{-
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'@
module Control.Concurrent.STM.TChan.TChanL_ where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan.ExtsCommons
import Control.Monad
import Data.Foldable
import Data.List
import Data.MyHelpers

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

data TChanL a =
        TChanL {
          tclChan :: TChan a
        , tclLoad :: TVar ChanLoad
        }

chanLoad :: TChanL a -> STM ChanLoad
chanLoad tchl = readTVar $ tclLoad tchl

newTChanL :: STM (TChanL a)
newTChanL = do
        tch <- newTChan
        tv  <- newTVar 0
        return TChanL {
                 tclChan = tch
               , tclLoad = tv
               }

newTChanL_IO :: IO (TChanL a)
newTChanL_IO = atomically newTChanL

writeTChanL :: TChanL a -> a -> STM ()
writeTChanL tchl a = do
        modifyTVar_ (tclLoad tchl) (+ 1)
        writeTChan  (tclChan tchl) a

readTChanL :: TChanL a -> STM a
readTChanL tchl = do
        modifyTVar_ (tclLoad tchl) (\ v -> v - 1)
        readTChan   (tclChan tchl)

isEmptyTChanL :: TChanL a -> STM Bool
isEmptyTChanL tchl = isEmptyTChan (tclChan tchl)

tryReadTChanL :: TChanL a -> STM (Maybe a)
tryReadTChanL tchl = do
        emp <- isEmptyTChanL tchl
        case emp of
            True  -> return Nothing
            False -> Just `liftM` readTChanL tchl

getTChanLContents :: TChanL a -> STM [a]
getTChanLContents tchl = do
        writeTVar (tclLoad tchl) 0
        reverse `liftM` whileJustM_1 (:) [] (tryReadTChan (tclChan tchl))

writeList2TChanL :: TChanL a -> [a] -> STM ()
writeList2TChanL tchl l = do
        load_add <- foldlM (\ load_accum e -> writeTChan (tclChan tchl) e >> return (load_accum + 1)) 0 l
        modifyTVar_ (tclLoad tchl) (\ v -> v + load_add)

filterOutTChanLElements :: (a -> TakeElementOutShouldWe) -> TChanL a -> STM [a]
filterOutTChanLElements p tchl = do
        l <- getTChanLContents tchl
        let (takeout, stay) = partition p l
        writeList2TChanL tchl stay
        return takeout

viewChanLContent :: TChanL a -> STM [a]
viewChanLContent tchl = do
        l <- getTChanLContents tchl
        writeList2TChanL tchl l -- I would gladly use some kind of abortChangesSTM here instead of this
        return l