{-# LANGUAGE ScopedTypeVariables #-}

-- | RefQueue are standard non-functional
-- queues using pointers (aka IORefs).  Events can be deleted asynchronously,
-- but this is done only by nulling the cell they are contained in, otherwise
-- we would need to double-link.   Other operations, IE the push and pop
-- function must not occur on the same queue concurrently.
--
-- Although the queues are impure, we return the new queue to be used
-- in future after push and search operations.
--
-- RefQueue are intended for use for queues of guarded strings,
-- hence the specialised implementation.
module Events.RefQueue(
   RefQueue,
   newRefQueue, -- :: IO (RefQueue a)
   pushRefQueue, -- :: RefQueue a -> a -> IO (RefQueue a,IO ())
      -- place an item on the queue.  The action argument deletes tje
      -- item.
   searchRefQueue, -- :: RefQueue a -> (a -> Bool) ->
      -- IO (Maybe (a,IO (RefQueue a)),RefQueue a)
      -- searchRefQueue searchs a queue from the front
      -- for an item matching the given condition.  If returns (second
      -- argument) the new queue with (if the item was found) the item
      -- deleted.  The first argument then contains a and a RefQueue
      -- which puts a back in the queue where it was PROVIDED THAT
      -- no operations were done on the queue inbetween except
      -- for pushRefQueue, action arguments returned from it, and
      -- searchRefQueue with the same function as the one provided.
   ) 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 {
   RefQueue a -> ListPtr a
front :: ! (ListPtr a),
   RefQueue a -> IORef (ListPtr a)
backRef :: ! (IORef (ListPtr a)),
   RefQueue a -> Int
sinceClean :: ! Int
   }

newRefQueue :: IO (RefQueue a)
newRefQueue :: IO (RefQueue a)
newRefQueue =
   do
      IORef (Maybe (ListItem a))
ioRef <- Maybe (ListItem a) -> IO (IORef (Maybe (ListItem a)))
forall a. a -> IO (IORef a)
newIORef Maybe (ListItem a)
forall a. Maybe a
Nothing
      IORef (IORef (Maybe (ListItem a)))
backRef <- IORef (Maybe (ListItem a))
-> IO (IORef (IORef (Maybe (ListItem a))))
forall a. a -> IO (IORef a)
newIORef IORef (Maybe (ListItem a))
ioRef
      RefQueue a -> IO (RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RefQueue :: forall a. ListPtr a -> IORef (ListPtr a) -> Int -> RefQueue a
RefQueue {front :: IORef (Maybe (ListItem a))
front = IORef (Maybe (ListItem a))
ioRef,backRef :: IORef (IORef (Maybe (ListItem a)))
backRef = IORef (IORef (Maybe (ListItem a)))
backRef,sinceClean :: Int
sinceClean = Int
0})

pushRefQueue :: RefQueue a -> a -> IO (RefQueue a,IO ())
pushRefQueue :: RefQueue a -> a -> IO (RefQueue a, IO ())
pushRefQueue (refQueue :: RefQueue a
refQueue@RefQueue {backRef :: forall a. RefQueue a -> IORef (ListPtr a)
backRef = IORef (ListPtr a)
backRef,sinceClean :: forall a. RefQueue a -> Int
sinceClean = Int
sinceClean})
      a
val =
   do
      Cell a
cell <- a -> IO (Cell a)
forall a. a -> IO (Cell a)
newCell a
val
      ListPtr a
newBack <- Maybe (ListItem a) -> IO (ListPtr a)
forall a. a -> IO (IORef a)
newIORef Maybe (ListItem a)
forall a. Maybe a
Nothing
      ListPtr a
oldBack <- IORef (ListPtr a) -> IO (ListPtr a)
forall a. IORef a -> IO a
readIORef IORef (ListPtr a)
backRef
      ListPtr a -> Maybe (ListItem a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef ListPtr a
oldBack (ListItem a -> Maybe (ListItem a)
forall a. a -> Maybe a
Just (Cell a -> ListPtr a -> ListItem a
forall a. Cell a -> ListPtr a -> ListItem a
ListItem Cell a
cell ListPtr a
newBack))
      IORef (ListPtr a) -> ListPtr a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (ListPtr a)
backRef ListPtr a
newBack
      let
         refQueue2 :: RefQueue a
refQueue2 = RefQueue a
refQueue {sinceClean :: Int
sinceClean = Int
sinceCleanInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1}
      RefQueue a
refQueue3 <- if Int
sinceClean Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10
         then
            do
               (RefQueue a
cleanedQueue,Maybe (ListItem a)
_) <- RefQueue a -> IO (RefQueue a, Maybe (ListItem a))
forall a. RefQueue a -> IO (RefQueue a, Maybe (ListItem a))
cleanRefQueue RefQueue a
refQueue2
               RefQueue a -> IO (RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return RefQueue a
cleanedQueue
         else
            RefQueue a -> IO (RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return RefQueue a
refQueue2
      (RefQueue a, IO ()) -> IO (RefQueue a, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (RefQueue a
refQueue3,Cell a -> IO ()
forall a. Cell a -> IO ()
emptyCell Cell a
cell)
{-# INLINE pushRefQueue #-}

searchRefQueue :: RefQueue a -> (a -> Bool)
   -> IO (Maybe (a,IO (RefQueue a)),RefQueue a)
searchRefQueue :: RefQueue a
-> (a -> Bool) -> IO (Maybe (a, IO (RefQueue a)), RefQueue a)
searchRefQueue (RefQueue a
refQueue :: RefQueue a) (a -> Bool
filter :: a -> Bool) =
   do
      (RefQueue a
refQueue2,Maybe (ListItem a)
listItem') <- RefQueue a -> IO (RefQueue a, Maybe (ListItem a))
forall a. RefQueue a -> IO (RefQueue a, Maybe (ListItem a))
cleanRefQueue RefQueue a
refQueue
      case Maybe (ListItem a)
listItem' of
         Maybe (ListItem a)
Nothing -> (Maybe (a, IO (RefQueue a)), RefQueue a)
-> IO (Maybe (a, IO (RefQueue a)), RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (a, IO (RefQueue a))
forall a. Maybe a
Nothing,RefQueue a
refQueue2)
         Just ListItem a
listItem ->
            do
               Maybe (a, IO ())
valFound' <- ListPtr a -> ListItem a -> IO (Maybe (a, IO ()))
searchPtr (RefQueue a -> ListPtr a
forall a. RefQueue a -> ListPtr a
front RefQueue a
refQueue2) ListItem a
listItem
               let
                  valAndAct' :: Maybe (a, IO (RefQueue a))
valAndAct' = ((a, IO ()) -> (a, IO (RefQueue a)))
-> Maybe (a, IO ()) -> Maybe (a, IO (RefQueue a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                     (\ (a
b,IO ()
act) -> (a
b,(IO ()
act IO () -> IO (RefQueue a) -> IO (RefQueue a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefQueue a -> IO (RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return RefQueue a
refQueue2)))
                     Maybe (a, IO ())
valFound'
               (Maybe (a, IO (RefQueue a)), RefQueue a)
-> IO (Maybe (a, IO (RefQueue a)), RefQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (a, IO (RefQueue a))
valAndAct',RefQueue a
refQueue2)
   where
      switchBack :: ListPtr a -> ListPtr a -> IO ()
      -- switchBack oldPtr newPtr indicates that a cell has
      -- just moved from oldPtr to newPtr, and updates backRef
      -- if necessary
      switchBack :: ListPtr a -> ListPtr a -> IO ()
switchBack ListPtr a
oldPtr ListPtr a
newPtr =
         do
            ListPtr a
oldBack <- IORef (ListPtr a) -> IO (ListPtr a)
forall a. IORef a -> IO a
readIORef (RefQueue a -> IORef (ListPtr a)
forall a. RefQueue a -> IORef (ListPtr a)
backRef RefQueue a
refQueue)
            if (ListPtr a
oldBack ListPtr a -> ListPtr a -> Bool
forall a. Eq a => a -> a -> Bool
== ListPtr a
oldPtr)
               then
                  IORef (ListPtr a) -> ListPtr a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (RefQueue a -> IORef (ListPtr a)
forall a. RefQueue a -> IORef (ListPtr a)
backRef RefQueue a
refQueue) ListPtr a
newPtr
               else
                  IO ()
forall (m :: * -> *). Monad m => m ()
done

      searchPtr :: ListPtr a -> ListItem a
         -> IO (Maybe (a,IO ()))
      -- The second argument is (Just ptr) to make ptr the new
      -- backref.
      searchPtr :: ListPtr a -> ListItem a -> IO (Maybe (a, IO ()))
searchPtr ListPtr a
ptr (listItem0 :: ListItem a
listItem0 @ (ListItem Cell a
cell ListPtr a
next))  =
         do
            Maybe a
cellContents <- Cell a -> IO (Maybe a)
forall a. Cell a -> IO (Maybe a)
inspectCell Cell a
cell
            case Maybe a
cellContents of
               Maybe a
Nothing ->
                  do
                     -- Unlink this item from the list
                     Maybe (ListItem a)
listItem' <- ListPtr a -> IO (Maybe (ListItem a))
forall a. IORef a -> IO a
readIORef ListPtr a
next
                     ListPtr a -> Maybe (ListItem a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef ListPtr a
ptr Maybe (ListItem a)
listItem'
                     ListPtr a -> ListPtr a -> IO ()
switchBack ListPtr a
next ListPtr a
ptr
                     case Maybe (ListItem a)
listItem' of
                        Maybe (ListItem a)
Nothing -> Maybe (a, IO ()) -> IO (Maybe (a, IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, IO ())
forall a. Maybe a
Nothing
                        Just ListItem a
listItem -> ListPtr a -> ListItem a -> IO (Maybe (a, IO ()))
searchPtr ListPtr a
next ListItem a
listItem
               Just a
a ->
                  do
                     if a -> Bool
filter a
a
                        then
                           do
                              -- Unlink this item from the list
                              Maybe (ListItem a)
listItem' <- ListPtr a -> IO (Maybe (ListItem a))
forall a. IORef a -> IO a
readIORef ListPtr a
next
                              ListPtr a -> Maybe (ListItem a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef ListPtr a
ptr Maybe (ListItem a)
listItem'
                              ListPtr a -> ListPtr a -> IO ()
switchBack ListPtr a
next ListPtr a
ptr
                              let
                                 relink :: IO ()
relink =
                                    do
                                       ListPtr a -> ListPtr a -> IO ()
switchBack ListPtr a
ptr ListPtr a
next
                                       ListPtr a -> Maybe (ListItem a) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef ListPtr a
ptr (ListItem a -> Maybe (ListItem a)
forall a. a -> Maybe a
Just ListItem a
listItem0)
                              Maybe (a, IO ()) -> IO (Maybe (a, IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, IO ()) -> Maybe (a, IO ())
forall a. a -> Maybe a
Just(a
a,IO ()
relink))
                        else
                           do
                              Maybe (ListItem a)
listItem' <- ListPtr a -> IO (Maybe (ListItem a))
forall a. IORef a -> IO a
readIORef ListPtr a
next
                              case Maybe (ListItem a)
listItem' of
                                 Maybe (ListItem a)
Nothing -> Maybe (a, IO ()) -> IO (Maybe (a, IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, IO ())
forall a. Maybe a
Nothing
                                 Just ListItem a
listItem -> ListPtr a -> ListItem a -> IO (Maybe (a, IO ()))
searchPtr ListPtr a
next ListItem a
listItem
{-# INLINE searchRefQueue #-}

cleanRefQueue :: RefQueue a -> IO (RefQueue a,Maybe (ListItem a))
-- cleanRefQueue cleans items from the front of the queue, and returns
-- the front list element, if any.
cleanRefQueue :: RefQueue a -> IO (RefQueue a, Maybe (ListItem a))
cleanRefQueue RefQueue a
refQueue =
   do
      (ListPtr a
newFront,Maybe (ListItem a)
listItem') <- ListPtr a -> IO (ListPtr a, Maybe (ListItem a))
forall a. ListPtr a -> IO (ListPtr a, Maybe (ListItem a))
cleanQueue (RefQueue a -> ListPtr a
forall a. RefQueue a -> ListPtr a
front RefQueue a
refQueue)
      (RefQueue a, Maybe (ListItem a))
-> IO (RefQueue a, Maybe (ListItem a))
forall (m :: * -> *) a. Monad m => a -> m a
return (RefQueue a
refQueue {front :: ListPtr a
front = ListPtr a
newFront,sinceClean :: Int
sinceClean=Int
0},Maybe (ListItem a)
listItem')
   where
      cleanQueue :: ListPtr a -> IO (ListPtr a,Maybe (ListItem a))
      cleanQueue :: ListPtr a -> IO (ListPtr a, Maybe (ListItem a))
cleanQueue ListPtr a
ptr =
         do
            Maybe (ListItem a)
contents <- ListPtr a -> IO (Maybe (ListItem a))
forall a. IORef a -> IO a
readIORef ListPtr a
ptr
            case Maybe (ListItem a)
contents of
               Maybe (ListItem a)
Nothing -> (ListPtr a, Maybe (ListItem a))
-> IO (ListPtr a, Maybe (ListItem a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ListPtr a
ptr,Maybe (ListItem a)
forall a. Maybe a
Nothing)
               Just (listItem :: ListItem a
listItem @ (ListItem Cell a
cell ListPtr a
next)) ->
                  do
                     Maybe a
cellContents <- Cell a -> IO (Maybe a)
forall a. Cell a -> IO (Maybe a)
inspectCell Cell a
cell
                     case Maybe a
cellContents of
                        Maybe a
Nothing -> ListPtr a -> IO (ListPtr a, Maybe (ListItem a))
forall a. ListPtr a -> IO (ListPtr a, Maybe (ListItem a))
cleanQueue ListPtr a
next
                        Just a
_ -> (ListPtr a, Maybe (ListItem a))
-> IO (ListPtr a, Maybe (ListItem a))
forall (m :: * -> *) a. Monad m => a -> m a
return (ListPtr a
ptr,ListItem a -> Maybe (ListItem a)
forall a. a -> Maybe a
Just ListItem a
listItem)