{-# LANGUAGE ScopedTypeVariables #-}

-- | Blockers are used to implement variable set sources which can be
-- turned on and off.  They are indexed by a BlockID.
module Util.VariableSetBlocker(
   Blocker,
   BlockID,
   newBlocker, -- :: HasKey a key => VariableSetSource a -> IO (Blocker a)
   newBlockID, -- :: IO BlockID

   openBlocker, -- :: HasKey a key => Blocker a -> BlockID -> IO ()
   closeBlocker, -- :: HasKey a key => Blocker a -> BlockID -> IO ()
   blockVariableSet,
      -- :: HasKey a key => Blocker a -> BlockID -> VariableSetSource a


   newBlockerWithPreAction
      -- :: HasKey a key => VariableSetSource a -> ([a] -> IO ())
      -- -> IO (Blocker a)
      --
      -- newBlockerWithPreAction creates a blocker that additionally permits
      -- an action that is performed the very first time the blocker is
      -- opened.
      -- The arguments to the action are the contents of the variable set
      -- at about the time of the opening.
   ) where

import System.IO.Unsafe
import Control.Concurrent

import Util.Object
import Util.Registry
import Util.Sink
import Util.Sources
import Util.VariableSet


-- --------------------------------------------------------------------
-- The types
-- --------------------------------------------------------------------

data Blocker a = Blocker {
   Blocker a -> Registry BlockID (VariableSetSource a, Bool -> IO ())
registry :: Registry BlockID (VariableSetSource a,Bool -> IO ()),
      -- For each blockID, the corresponding VariableSetSource and an
      -- action which blocks it, with True meaning "blocked".
   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)

-- --------------------------------------------------------------------
-- The functions
-- --------------------------------------------------------------------

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

-- --------------------------------------------------------------------
-- The primitive functions
-- --------------------------------------------------------------------

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)
         )

-- | (setSource2,block) \<- blockableVariableSet setSource1
-- returns a setSource2 which is in one of two states.  In one state it is
-- blocked, and empty.  In the other, it is unblocked, and its contents are
-- the same as those of setSource1.  Initially it is blocked.  To switch
-- from one to the other the block function is used.  \"block True\" blocks
-- the set source; \"block False\" unblocks it.   Blocking if we are already
-- blocked, or unblocking if we are already unblocked, is harmless and does
-- nothing.
--
-- This somewhat baroque function is required for arc sets from folders.
-- I have wasted a couple of days trying to think of a more elegant way of
-- doing this ...
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
         -- If we are not blocked, contains the terminator action.
      VariableSet a
set2 <- IO (VariableSet a)
forall x key. HasKey x key => IO (VariableSet x)
newEmptyVariableSet -- contains the contents of setSource2
      ParallelExec
parallelX <- IO ParallelExec
newParallelExec
         -- used to execute updates to set2.  This helps make sure they
         -- happen in the right order.
      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) -> -- block
                     do
                        ParallelExec -> IO () -> IO ()
parallelExec ParallelExec
parallelX (
                           do
                              IO ()
terminator -- stop any more updates.
                              VariableSet a -> [a] -> IO ()
forall x key. HasKey x key => VariableSet x -> [x] -> IO ()
setVariableSet VariableSet a
set2 [] -- empty this set.
                           )
                        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) -> -- unblock
                     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)