module Util.TSem(
TSem,
newTSem,
synchronizeTSem,
) where
import System.IO.Unsafe
import Control.Exception
import Util.Object
import Util.ExtendedPrelude
import Util.ThreadDict
data TSem = TSem {
oId :: ObjectID,
label :: IO String
}
newtype ThreadInfo = ThreadInfo [TSem]
threadInfoDict :: ThreadDict ThreadInfo
threadInfoDict = unsafePerformIO newThreadDict
newTSem :: IO String -> IO TSem
newTSem label =
do
oId <- newObject
return (TSem {oId = oId,label = label})
synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)
synchronizeTSem tSem act =
do
strActsOpt <- tryAcquire tSem
case strActsOpt of
Nothing -> finally
(do
a <- act
return (Right a)
)
(release tSem)
Just strActs ->
do
strs <- mapM id strActs
return (Left strs)
tryAcquire :: TSem -> IO (Maybe [IO String])
tryAcquire tSem =
modifyThreadDict threadInfoDict
(\ threadInfoOpt ->
return (case threadInfoOpt of
Nothing -> (Just (ThreadInfo [tSem]),Nothing)
Just (ThreadInfo tSems) ->
case splitToElem (\ tSem2 -> oId tSem2 == oId tSem) tSems
of
Nothing ->
(Just (ThreadInfo (tSem : tSems)),Nothing)
Just (tSems,_) ->
(threadInfoOpt,Just (map label (tSem : reverse tSems)))
)
)
release :: TSem -> IO ()
release tSem =
modifyThreadDict threadInfoDict
(\ threadInfoOpt ->
case threadInfoOpt of
(Just (ThreadInfo (tSem2 : tSems)))
| oId tSem2 == oId tSem
->
return (
case tSems of
[] -> Nothing
_ -> Just (ThreadInfo tSems)
, ())
_ -> error "TSem -- improperly nested release"
)