{-# LANGUAGE ScopedTypeVariables #-}
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 {
Blocker a -> Registry BlockID (VariableSetSource a, Bool -> IO ())
registry :: Registry BlockID (VariableSetSource a,Bool -> IO ()),
Blocker a -> VariableSetSource a
setSource :: VariableSetSource a
}
newtype BlockID = BlockID ObjectID deriving (BlockID -> BlockID -> Bool
(BlockID -> BlockID -> Bool)
-> (BlockID -> BlockID -> Bool) -> Eq BlockID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockID -> BlockID -> Bool
$c/= :: BlockID -> BlockID -> Bool
== :: BlockID -> BlockID -> Bool
$c== :: BlockID -> BlockID -> Bool
Eq,Eq BlockID
Eq BlockID
-> (BlockID -> BlockID -> Ordering)
-> (BlockID -> BlockID -> Bool)
-> (BlockID -> BlockID -> Bool)
-> (BlockID -> BlockID -> Bool)
-> (BlockID -> BlockID -> Bool)
-> (BlockID -> BlockID -> BlockID)
-> (BlockID -> BlockID -> BlockID)
-> Ord BlockID
BlockID -> BlockID -> Bool
BlockID -> BlockID -> Ordering
BlockID -> BlockID -> BlockID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockID -> BlockID -> BlockID
$cmin :: BlockID -> BlockID -> BlockID
max :: BlockID -> BlockID -> BlockID
$cmax :: BlockID -> BlockID -> BlockID
>= :: BlockID -> BlockID -> Bool
$c>= :: BlockID -> BlockID -> Bool
> :: BlockID -> BlockID -> Bool
$c> :: BlockID -> BlockID -> Bool
<= :: BlockID -> BlockID -> Bool
$c<= :: BlockID -> BlockID -> Bool
< :: BlockID -> BlockID -> Bool
$c< :: BlockID -> BlockID -> Bool
compare :: BlockID -> BlockID -> Ordering
$ccompare :: BlockID -> BlockID -> Ordering
$cp1Ord :: Eq BlockID
Ord)
newBlocker :: HasKey a key => VariableSetSource a -> IO (Blocker a)
newBlocker :: VariableSetSource a -> IO (Blocker a)
newBlocker VariableSetSource a
setSource =
do
Registry BlockID (VariableSetSource a, Bool -> IO ())
registry <- IO (Registry BlockID (VariableSetSource a, Bool -> IO ()))
forall registry. NewRegistry registry => IO registry
newRegistry
let
blocker :: Blocker a
blocker = Blocker :: forall a.
Registry BlockID (VariableSetSource a, Bool -> IO ())
-> VariableSetSource a -> Blocker a
Blocker {
registry :: Registry BlockID (VariableSetSource a, Bool -> IO ())
registry = Registry BlockID (VariableSetSource a, Bool -> IO ())
registry,
setSource :: VariableSetSource a
setSource = VariableSetSource a
setSource
}
Blocker a -> IO (Blocker a)
forall (m :: * -> *) a. Monad m => a -> m a
return Blocker a
blocker
newBlockerWithPreAction
:: HasKey a key => VariableSetSource a -> ([a] -> IO ()) -> IO (Blocker a)
newBlockerWithPreAction :: VariableSetSource a -> ([a] -> IO ()) -> IO (Blocker a)
newBlockerWithPreAction VariableSetSource a
setSource0 [a] -> IO ()
preAction =
let
action :: IO ()
action =
do
[a]
list <- VariableSetSource a -> IO [a]
forall source x d. HasSource source x d => source -> IO x
readContents VariableSetSource a
setSource0
[a] -> IO ()
preAction [a]
list
setSource1 :: VariableSetSource a
setSource1 = (IO () -> ()
forall a. IO a -> a
unsafePerformIO IO ()
action) () -> VariableSetSource a -> VariableSetSource a
`seq` VariableSetSource a
setSource0
in
VariableSetSource a -> IO (Blocker a)
forall a key. HasKey a key => VariableSetSource a -> IO (Blocker a)
newBlocker VariableSetSource a
setSource1
newBlockID :: IO BlockID
newBlockID :: IO BlockID
newBlockID =
do
ObjectID
objectID <- IO ObjectID
newObject
BlockID -> IO BlockID
forall (m :: * -> *) a. Monad m => a -> m a
return (ObjectID -> BlockID
BlockID ObjectID
objectID)
openBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()
openBlocker :: Blocker a -> BlockID -> IO ()
openBlocker Blocker a
blocker BlockID
blockID =
do
(VariableSetSource a
_,Bool -> IO ()
blockFn) <- Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
forall a key.
HasKey a key =>
Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
getBlockEntry Blocker a
blocker BlockID
blockID
Bool -> IO ()
blockFn Bool
False
closeBlocker :: HasKey a key => Blocker a -> BlockID -> IO ()
closeBlocker :: Blocker a -> BlockID -> IO ()
closeBlocker Blocker a
blocker BlockID
blockID =
do
(VariableSetSource a
_,Bool -> IO ()
blockFn) <- Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
forall a key.
HasKey a key =>
Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
getBlockEntry Blocker a
blocker BlockID
blockID
Bool -> IO ()
blockFn Bool
True
blockVariableSet :: HasKey a key
=> Blocker a -> BlockID -> IO (VariableSetSource a)
blockVariableSet :: Blocker a -> BlockID -> IO (VariableSetSource a)
blockVariableSet Blocker a
blocker BlockID
blockID =
do
(VariableSetSource a
setSource,Bool -> IO ()
_) <- Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
forall a key.
HasKey a key =>
Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
getBlockEntry Blocker a
blocker BlockID
blockID
VariableSetSource a -> IO (VariableSetSource a)
forall (m :: * -> *) a. Monad m => a -> m a
return VariableSetSource a
setSource
getBlockEntry :: HasKey a key
=> Blocker a -> BlockID -> IO (VariableSetSource a,Bool -> IO ())
getBlockEntry :: Blocker a -> BlockID -> IO (VariableSetSource a, Bool -> IO ())
getBlockEntry Blocker a
blocker BlockID
blockID =
Registry BlockID (VariableSetSource a, Bool -> IO ())
-> BlockID
-> (Maybe (VariableSetSource a, Bool -> IO ())
-> IO
(Maybe (VariableSetSource a, Bool -> IO ()),
(VariableSetSource a, Bool -> IO ())))
-> IO (VariableSetSource a, Bool -> IO ())
forall registry from to extra.
GetSetRegistry registry from to =>
registry -> from -> (Maybe to -> IO (Maybe to, extra)) -> IO extra
transformValue (Blocker a -> Registry BlockID (VariableSetSource a, Bool -> IO ())
forall a.
Blocker a -> Registry BlockID (VariableSetSource a, Bool -> IO ())
registry Blocker a
blocker) BlockID
blockID (\ Maybe (VariableSetSource a, Bool -> IO ())
entryOpt ->
case Maybe (VariableSetSource a, Bool -> IO ())
entryOpt of
Just (VariableSetSource a, Bool -> IO ())
entry -> (Maybe (VariableSetSource a, Bool -> IO ()),
(VariableSetSource a, Bool -> IO ()))
-> IO
(Maybe (VariableSetSource a, Bool -> IO ()),
(VariableSetSource a, Bool -> IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (VariableSetSource a, Bool -> IO ())
entryOpt,(VariableSetSource a, Bool -> IO ())
entry)
Maybe (VariableSetSource a, Bool -> IO ())
Nothing ->
do
(VariableSetSource a, Bool -> IO ())
entry <- VariableSetSource a -> IO (VariableSetSource a, Bool -> IO ())
forall a key.
HasKey a key =>
VariableSetSource a -> IO (VariableSetSource a, Bool -> IO ())
blockableVariableSet (Blocker a -> VariableSetSource a
forall a. Blocker a -> VariableSetSource a
setSource Blocker a
blocker)
(Maybe (VariableSetSource a, Bool -> IO ()),
(VariableSetSource a, Bool -> IO ()))
-> IO
(Maybe (VariableSetSource a, Bool -> IO ()),
(VariableSetSource a, Bool -> IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return ((VariableSetSource a, Bool -> IO ())
-> Maybe (VariableSetSource a, Bool -> IO ())
forall a. a -> Maybe a
Just (VariableSetSource a, Bool -> IO ())
entry,(VariableSetSource a, Bool -> IO ())
entry)
)
blockableVariableSet :: HasKey a key
=> VariableSetSource a -> IO (VariableSetSource a,Bool -> IO ())
blockableVariableSet :: VariableSetSource a -> IO (VariableSetSource a, Bool -> IO ())
blockableVariableSet (VariableSetSource a
setSource1 :: VariableSetSource a) =
do
(MVar (Maybe (IO ()))
mVar :: MVar (Maybe (IO ()))) <- Maybe (IO ()) -> IO (MVar (Maybe (IO ())))
forall a. a -> IO (MVar a)
newMVar Maybe (IO ())
forall a. Maybe a
Nothing
VariableSet a
set2 <- IO (VariableSet a)
forall x key. HasKey x key => IO (VariableSet x)
newEmptyVariableSet
ParallelExec
parallelX <- IO ParallelExec
newParallelExec
let
block :: Bool -> IO ()
block Bool
doBlock = MVar (Maybe (IO ()))
-> (Maybe (IO ()) -> IO (Maybe (IO ()))) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe (IO ()))
mVar (\ Maybe (IO ())
terminatorOpt ->
do
case (Bool
doBlock,Maybe (IO ())
terminatorOpt) of
(Bool
True,Just IO ()
terminator) ->
do
ParallelExec -> IO () -> IO ()
parallelExec ParallelExec
parallelX (
do
IO ()
terminator
VariableSet a -> [a] -> IO ()
forall x key. HasKey x key => VariableSet x -> [x] -> IO ()
setVariableSet VariableSet a
set2 []
)
Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
forall a. Maybe a
Nothing
(Bool
False,Maybe (IO ())
Nothing) ->
do
SinkID
sinkID <- IO SinkID
newSinkID
let
doContents :: [a] -> IO ()
doContents :: [a] -> IO ()
doContents [a]
contents = VariableSet a -> [a] -> IO ()
forall x key. HasKey x key => VariableSet x -> [x] -> IO ()
setVariableSet VariableSet a
set2 [a]
contents
doUpdate :: VariableSetUpdate a -> IO ()
doUpdate :: VariableSetUpdate a -> IO ()
doUpdate VariableSetUpdate a
update = VariableSet a -> VariableSetUpdate a -> IO ()
forall x key.
HasKey x key =>
VariableSet x -> VariableSetUpdate x -> IO ()
updateSet VariableSet a
set2 VariableSetUpdate a
update
VariableSetSource a
-> ([a] -> IO ())
-> (VariableSetUpdate a -> IO ())
-> SinkID
-> ParallelExec
-> IO ([a], Sink (VariableSetUpdate a))
forall sinkSource x delta.
CanAddSinks sinkSource x delta =>
sinkSource
-> (x -> IO ())
-> (delta -> IO ())
-> SinkID
-> ParallelExec
-> IO (x, Sink delta)
addNewSinkWithInitial VariableSetSource a
setSource1 [a] -> IO ()
doContents VariableSetUpdate a -> IO ()
doUpdate
SinkID
sinkID ParallelExec
parallelX
Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (SinkID -> IO ()
forall source. HasInvalidate source => source -> IO ()
invalidate SinkID
sinkID))
(Bool, Maybe (IO ()))
_ -> Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IO ())
terminatorOpt
)
(VariableSetSource a, Bool -> IO ())
-> IO (VariableSetSource a, Bool -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (VariableSet a -> VariableSetSource a
forall hasSource x d.
HasSource hasSource x d =>
hasSource -> Source x d
toSource VariableSet a
set2,Bool -> IO ()
block)