-- Maintain a pool of work items, each of which is a IO ()
-- behavior.  The IO's are assumed to be idempotent (pure writers)
-- This assumption allows the implementation to be efficient in the 
-- common case that a behavior being output is temporarily or 
-- permanently constant.  

-- Note that we now have TWO workpools here. The first, for addIOB, is for
-- standard behavior actions.
-- The second, addListenerPredB, should ONLY be used by toStream in BehaviorIO.hs.
-- It's for turning behaviors into events. These need to be separate, as
-- these events can then affect other behaviors...
\begin{code}
module WorkPool ( addListenerB, addIOB, addListenerPredB, addHIOB
		, runWorkPools
                , clearWorkPools
                )  where

import Monad (when, unless)
import Maybe
import Delayed
import IOExts
import List
import BaseTypes
import MutSet
import Event
import EventPrim(addWeakListener')
import FranTime
import BPrim
import Weak
import Compatibility
import ListenerOps
\end{code}

--  Here's the idea behind the implementation:

--  + One thread iteratively traverses the IOB pool.  For each IOB, (a)
--    sample and execute, and then (b) if it has gone constant (expiration
--    date equals maxTime), remove it from the pool.

--  + Whenever one of these IOBs gets invalidated, if it was not already in
--    the IOB pool, add it.  If the new current behavior is constant, it
--    will then get sampled and executed once and removed from the pool.
--    Otherwise, it will get repeatedly sampled and executed.


-- A single work item.  Work items are assumed to be in at most one work
-- pool.

\begin{code}
data WorkItem = WorkItem {
	removerRefW :: (IORef (Maybe Remover)), -- remove from workpool
	iob :: (Sampler (IO ())) -- to do
}

type WorkPool = MutSet WorkItem

newWorkPool :: IO WorkPool
newWorkPool = newMutSet
\end{code}

The workpool is traversed as often as necessary.

\begin{code}
doWork :: Time -> WorkPool -> IO ()
doWork t pool = do 
 foreachInMutSet pool (doOne t)
 return ()

doOne :: Time -> WorkItem -> IO ()
doOne t (WorkItem remv sample) = do
 mb <- readIORef remv
 case mb of
  Nothing -> return ()
  Just rm -> do (io,const) <- sample t
                io
                when const (do {rm;writeIORef remv Nothing})
\end{code}

When adding a behavior listener, we first get the listener operation passing in 
the complete remove action to end all of the item's work. We create an IO valued 
sampler. It samples the behavior and returns the action to fire the listener with 
the current behavior value. We make a workpool item, and first restore the item 
to the workpool. We also add a listener to the invalidation event. This will restore
the item to the workpool whenever a constant segment ends. When restoring an item 
we first check whether it is already in the pool. We only add it if it is not.

\begin{code}
addWorkItem :: WorkPool -> Behavior a -> Listener a -> IO Remover
addWorkItem pool b l = fixIO $ \allrm -> do
 op <- getListener' l allrm
 let sampler t = do {(v,c) <- sample b t;return (op (t,v),c)}
 removerRef <- newIORef Nothing
 let item = WorkItem removerRef sampler
 let restore = restoreWorkItem (addToMutSet pool item) removerRef
 restore
 remove <- addListener (invalidateEv b) $ mkL_ restore
 return $ do {mb <- readIORef removerRef;maybe (return ()) id mb;
              writeIORef removerRef Nothing;remove}

restoreWorkItem :: IO Remover -> IORef (Maybe Remover) -> IO ()
restoreWorkItem add removerRef = do
 mb <- readIORef removerRef
 when (not (isJust mb)) $ do
        {rm <- add;writeIORef removerRef (Just rm)}
\end{code}


------ Implicit WorkPools
\begin{code}

workpoolVar :: WorkPool
workpoolVar = unsafePerformIO $ newWorkPool
{-# NOINLINE workpoolVar #-}
 
predWorkpoolVar :: WorkPool
predWorkpoolVar = unsafePerformIO $ newWorkPool
{-# NOINLINE predWorkpoolVar #-}

\end{code}

----- Public interfaces (implicit work pools)

\begin{code}

addIOB b = addListenerB b (mkL id)

-- main workpool
addListenerB :: Behavior a -> Listener a -> IO Remover
addListenerB b l = addWorkItem workpoolVar b l

addWeakListenerB = addWeakListener' addListenerB

addHIOB b = addListenerPredB b (mkL id)

-- predicate workpool
addListenerPredB :: Behavior a -> Listener a -> IO Remover
addListenerPredB b l = addWorkItem predWorkpoolVar b l

\end{code}

Run the workpools at a given time. We first run the predicate pool 
(at the time of the last tick occurrence). Then we increment the time,
run delayed actions to update behaviors, and run the main workpool.

It returns an integer specifying the number of items remaining in the workpools
\begin{code}
runWorkPools :: Time -> IO Int
runWorkPools t = do
 t <- setFranTime t
 runDelayedActions
 doWork t predWorkpoolVar
 t <- setFranTime t
 runDelayedActions 
 doWork t workpoolVar
 sz1 <- sizeMutSet predWorkpoolVar
 sz2 <- sizeMutSet workpoolVar
 return $ maybe 0 id sz1 + maybe 0 id sz2
\end{code}

Clear up all the workpools. Useful in hugs where these things are being cached
between runs
\begin{code}
clearWorkPools :: IO ()
clearWorkPools = clearMutSet predWorkpoolVar >> clearMutSet workpoolVar
\end{code}
