module Events.RefQueue(
RefQueue,
newRefQueue,
pushRefQueue,
searchRefQueue,
) where
import Data.IORef
import Util.Computation(done)
import Events.Cells
type ListPtr a = IORef (Maybe (ListItem a))
data ListItem a = ListItem ! (Cell a) ! (ListPtr a)
data RefQueue a = RefQueue {
front :: ! (ListPtr a),
backRef :: ! (IORef (ListPtr a)),
sinceClean :: ! Int
}
newRefQueue :: IO (RefQueue a)
newRefQueue =
do
ioRef <- newIORef Nothing
backRef <- newIORef ioRef
return (RefQueue {front = ioRef,backRef = backRef,sinceClean = 0})
pushRefQueue :: RefQueue a -> a -> IO (RefQueue a,IO ())
pushRefQueue (refQueue@RefQueue {backRef = backRef,sinceClean = sinceClean})
val =
do
cell <- newCell val
newBack <- newIORef Nothing
oldBack <- readIORef backRef
writeIORef oldBack (Just (ListItem cell newBack))
writeIORef backRef newBack
let
refQueue2 = refQueue {sinceClean = sinceClean+1}
refQueue3 <- if sinceClean >= 10
then
do
(cleanedQueue,_) <- cleanRefQueue refQueue2
return cleanedQueue
else
return refQueue2
return (refQueue3,emptyCell cell)
searchRefQueue :: RefQueue a -> (a -> Bool)
-> IO (Maybe (a,IO (RefQueue a)),RefQueue a)
searchRefQueue (refQueue :: RefQueue a) (filter :: a -> Bool) =
do
(refQueue2,listItem') <- cleanRefQueue refQueue
case listItem' of
Nothing -> return (Nothing,refQueue2)
Just listItem ->
do
valFound' <- searchPtr (front refQueue2) listItem
let
valAndAct' = fmap
(\ (b,act) -> (b,(act >> return refQueue2)))
valFound'
return (valAndAct',refQueue2)
where
switchBack :: ListPtr a -> ListPtr a -> IO ()
switchBack oldPtr newPtr =
do
oldBack <- readIORef (backRef refQueue)
if (oldBack == oldPtr)
then
writeIORef (backRef refQueue) newPtr
else
done
searchPtr :: ListPtr a -> ListItem a
-> IO (Maybe (a,IO ()))
searchPtr ptr (listItem0 @ (ListItem cell next)) =
do
cellContents <- inspectCell cell
case cellContents of
Nothing ->
do
listItem' <- readIORef next
writeIORef ptr listItem'
switchBack next ptr
case listItem' of
Nothing -> return Nothing
Just listItem -> searchPtr next listItem
Just a ->
do
if filter a
then
do
listItem' <- readIORef next
writeIORef ptr listItem'
switchBack next ptr
let
relink =
do
switchBack ptr next
writeIORef ptr (Just listItem0)
return (Just(a,relink))
else
do
listItem' <- readIORef next
case listItem' of
Nothing -> return Nothing
Just listItem -> searchPtr next listItem
cleanRefQueue :: RefQueue a -> IO (RefQueue a,Maybe (ListItem a))
cleanRefQueue refQueue =
do
(newFront,listItem') <- cleanQueue (front refQueue)
return (refQueue {front = newFront,sinceClean=0},listItem')
where
cleanQueue :: ListPtr a -> IO (ListPtr a,Maybe (ListItem a))
cleanQueue ptr =
do
contents <- readIORef ptr
case contents of
Nothing -> return (ptr,Nothing)
Just (listItem @ (ListItem cell next)) ->
do
cellContents <- inspectCell cell
case cellContents of
Nothing -> cleanQueue next
Just _ -> return (ptr,Just listItem)