module Util.VariableSetBlocker(
Blocker,
BlockID,
newBlocker,
newBlockID,
openBlocker,
closeBlocker,
blockVariableSet,
newBlockerWithPreAction
) where
import System.IO.Unsafe
import Control.Concurrent
import Util.Object
import Util.Registry
import Util.Sink
import Util.Sources
import Util.VariableSet
data Blocker a = Blocker {
registry :: Registry BlockID (VariableSetSource a,Bool -> IO ()),
setSource :: VariableSetSource a
}
newtype BlockID = BlockID ObjectID deriving (Eq,Ord)
newBlocker :: HasKey a key => VariableSetSource a -> IO (Blocker a)
newBlocker setSource =
do
registry <- newRegistry
let
blocker = Blocker {
registry = registry,
setSource = setSource
}
return blocker
newBlockerWithPreAction
:: HasKey a key => VariableSetSource a -> ([a] -> IO ()) -> IO (Blocker a)
newBlockerWithPreAction setSource0 preAction =
let
action =
do
list <- readContents setSource0
preAction list
setSource1 = (unsafePerformIO action) `seq` setSource0
in
newBlocker setSource1
newBlockID :: IO BlockID
newBlockID =
do
objectID <- newObject
return (BlockID objectID)
openBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()
openBlocker blocker blockID =
do
(_,blockFn) <- getBlockEntry blocker blockID
blockFn False
closeBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()
closeBlocker blocker blockID =
do
(_,blockFn) <- getBlockEntry blocker blockID
blockFn True
blockVariableSet :: HasKey a key
=> Blocker a -> BlockID -> IO (VariableSetSource a)
blockVariableSet blocker blockID =
do
(setSource,_) <- getBlockEntry blocker blockID
return setSource
getBlockEntry :: HasKey a key
=> Blocker a -> BlockID -> IO (VariableSetSource a,Bool -> IO ())
getBlockEntry blocker blockID =
transformValue (registry blocker) blockID (\ entryOpt ->
case entryOpt of
Just entry -> return (entryOpt,entry)
Nothing ->
do
entry <- blockableVariableSet (setSource blocker)
return (Just entry,entry)
)
blockableVariableSet :: HasKey a key
=> VariableSetSource a -> IO (VariableSetSource a,Bool -> IO ())
blockableVariableSet (setSource1 :: VariableSetSource a) =
do
(mVar :: MVar (Maybe (IO ()))) <- newMVar Nothing
set2 <- newEmptyVariableSet
parallelX <- newParallelExec
let
block doBlock = modifyMVar_ mVar (\ terminatorOpt ->
do
case (doBlock,terminatorOpt) of
(True,Just terminator) ->
do
parallelExec parallelX (
do
terminator
setVariableSet set2 []
)
return Nothing
(False,Nothing) ->
do
sinkID <- newSinkID
let
doContents :: [a] -> IO ()
doContents contents = setVariableSet set2 contents
doUpdate :: VariableSetUpdate a -> IO ()
doUpdate update = updateSet set2 update
addNewSinkWithInitial setSource1 doContents doUpdate
sinkID parallelX
return (Just (invalidate sinkID))
_ -> return terminatorOpt
)
return (toSource set2,block)