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 {
TSem -> ObjectID
oId :: ObjectID,
TSem -> IO String
label :: IO String
}
newtype ThreadInfo = ThreadInfo [TSem]
threadInfoDict :: ThreadDict ThreadInfo
threadInfoDict :: ThreadDict ThreadInfo
threadInfoDict = IO (ThreadDict ThreadInfo) -> ThreadDict ThreadInfo
forall a. IO a -> a
unsafePerformIO IO (ThreadDict ThreadInfo)
forall a. IO (ThreadDict a)
newThreadDict
{-# NOINLINE threadInfoDict #-}
newTSem :: IO String -> IO TSem
newTSem :: IO String -> IO TSem
newTSem IO String
label =
do
ObjectID
oId <- IO ObjectID
newObject
TSem -> IO TSem
forall (m :: * -> *) a. Monad m => a -> m a
return (TSem :: ObjectID -> IO String -> TSem
TSem {oId :: ObjectID
oId = ObjectID
oId,label :: IO String
label = IO String
label})
synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)
synchronizeTSem :: TSem -> IO a -> IO (Either [String] a)
synchronizeTSem TSem
tSem IO a
act =
do
Maybe [IO String]
strActsOpt <- TSem -> IO (Maybe [IO String])
tryAcquire TSem
tSem
case Maybe [IO String]
strActsOpt of
Maybe [IO String]
Nothing -> IO (Either [String] a) -> IO () -> IO (Either [String] a)
forall a b. IO a -> IO b -> IO a
finally
(do
a
a <- IO a
act
Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either [String] a
forall a b. b -> Either a b
Right a
a)
)
(TSem -> IO ()
release TSem
tSem)
Just [IO String]
strActs ->
do
[String]
strs <- (IO String -> IO String) -> [IO String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM IO String -> IO String
forall a. a -> a
id [IO String]
strActs
Either [String] a -> IO (Either [String] a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Either [String] a
forall a b. a -> Either a b
Left [String]
strs)
tryAcquire :: TSem -> IO (Maybe [IO String])
tryAcquire :: TSem -> IO (Maybe [IO String])
tryAcquire TSem
tSem =
ThreadDict ThreadInfo
-> (Maybe ThreadInfo -> IO (Maybe ThreadInfo, Maybe [IO String]))
-> IO (Maybe [IO String])
forall a b. ThreadDict a -> (Maybe a -> IO (Maybe a, b)) -> IO b
modifyThreadDict ThreadDict ThreadInfo
threadInfoDict
(\ Maybe ThreadInfo
threadInfoOpt ->
(Maybe ThreadInfo, Maybe [IO String])
-> IO (Maybe ThreadInfo, Maybe [IO String])
forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe ThreadInfo
threadInfoOpt of
Maybe ThreadInfo
Nothing -> (ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo [TSem
tSem]),Maybe [IO String]
forall a. Maybe a
Nothing)
Just (ThreadInfo [TSem]
tSems) ->
case (TSem -> Bool) -> [TSem] -> Maybe ([TSem], [TSem])
forall a. (a -> Bool) -> [a] -> Maybe ([a], [a])
splitToElem (\ TSem
tSem2 -> TSem -> ObjectID
oId TSem
tSem2 ObjectID -> ObjectID -> Bool
forall a. Eq a => a -> a -> Bool
== TSem -> ObjectID
oId TSem
tSem) [TSem]
tSems
of
Maybe ([TSem], [TSem])
Nothing ->
(ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo (TSem
tSem TSem -> [TSem] -> [TSem]
forall a. a -> [a] -> [a]
: [TSem]
tSems)),Maybe [IO String]
forall a. Maybe a
Nothing)
Just ([TSem]
tSems,[TSem]
_) ->
(Maybe ThreadInfo
threadInfoOpt,[IO String] -> Maybe [IO String]
forall a. a -> Maybe a
Just ((TSem -> IO String) -> [TSem] -> [IO String]
forall a b. (a -> b) -> [a] -> [b]
map TSem -> IO String
label (TSem
tSem TSem -> [TSem] -> [TSem]
forall a. a -> [a] -> [a]
: [TSem] -> [TSem]
forall a. [a] -> [a]
reverse [TSem]
tSems)))
)
)
release :: TSem -> IO ()
release :: TSem -> IO ()
release TSem
tSem =
ThreadDict ThreadInfo
-> (Maybe ThreadInfo -> IO (Maybe ThreadInfo, ())) -> IO ()
forall a b. ThreadDict a -> (Maybe a -> IO (Maybe a, b)) -> IO b
modifyThreadDict ThreadDict ThreadInfo
threadInfoDict
(\ Maybe ThreadInfo
threadInfoOpt ->
case Maybe ThreadInfo
threadInfoOpt of
(Just (ThreadInfo (TSem
tSem2 : [TSem]
tSems)))
| TSem -> ObjectID
oId TSem
tSem2 ObjectID -> ObjectID -> Bool
forall a. Eq a => a -> a -> Bool
== TSem -> ObjectID
oId TSem
tSem
->
(Maybe ThreadInfo, ()) -> IO (Maybe ThreadInfo, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (
case [TSem]
tSems of
[] -> Maybe ThreadInfo
forall a. Maybe a
Nothing
[TSem]
_ -> ThreadInfo -> Maybe ThreadInfo
forall a. a -> Maybe a
Just ([TSem] -> ThreadInfo
ThreadInfo [TSem]
tSems)
, ())
Maybe ThreadInfo
_ -> String -> IO (Maybe ThreadInfo, ())
forall a. HasCallStack => String -> a
error String
"TSem -- improperly nested release"
)