-- | Delayers handle delaying of actions; the main purpose is to delay
-- graph redrawing actions during complex updates.
module Util.Delayer(
   -- Client side
   Delayer,
   newDelayer, -- :: IO Delayer
   HasDelayer(..),
      -- :: Class of things which have a delayer.
      -- Delayer itself is an instance.
   delay, -- :: HasDelayer object => object -> IO a -> IO a
      -- carry out the given action preventing the Delayer from doing anything.

   -- Producer side
   DelayedAction,
   newDelayedAction, -- :: IO () -> IO DelayedAction
   delayedAct, -- :: Delayer -> DelayedAction -> IO ()
      -- If no delay is taking place, perform the DelayedAction action
      -- immediately.  Otherwise remember to do it when are no longer inside
      -- a delay.
      -- If the same DelayedAction is queued multiple times when a Delayer
      -- is delay'd, we nevertheless only do it once.
   cancelDelayedAct, -- :: Delayer -> DelayedAction -> IO ()
      -- If this DelayedAction is queued, remove it from the queue.

   HasAddDelayer(..),
   -- Instances of HasAddDelayer are event sources to which you can attach
   --    a delayer, to indicate you are currently not interested in events.

   HasAddDelayerIO(..),
   -- Like HasAddDelayer, but allows an IO action.
   ) where

import Control.Concurrent.MVar
import Control.Exception

import qualified Data.Set as Set

import Util.Object
import Util.Computation(done)

-- ------------------------------------------------------------------------
-- Data types
-- ------------------------------------------------------------------------

data DelayedAction = DelayedAction {
   DelayedAction -> ObjectID
oId :: ObjectID,
   DelayedAction -> IO ()
action :: IO ()
   }

data DelayerState = DelayerState {
   DelayerState -> Int
delayCount ::  ! Int, -- ^ 0 when not delay'd.
   DelayerState -> Set DelayedAction
delayedActions :: Set.Set DelayedAction
   }

data Delayer = Delayer (MVar DelayerState)

-- ------------------------------------------------------------------------
-- HasAddDelayer
-- ------------------------------------------------------------------------

-- | Instances of HasAddDelayer are event sources to which you can attach
--   a delayer, to indicate you are currently not interested in events.
class HasAddDelayer eventSource where
   addDelayer :: Delayer -> eventSource -> eventSource

-- | Like HasAddDelayer, but allows an IO action.
class HasAddDelayerIO eventSource where
   addDelayerIO :: Delayer -> eventSource -> IO eventSource

-- ------------------------------------------------------------------------
-- HasDelayer
-- ------------------------------------------------------------------------

class HasDelayer object where
   toDelayer :: object -> Delayer

-- ------------------------------------------------------------------------
-- Instances
-- ------------------------------------------------------------------------

instance Eq DelayedAction where
   == :: DelayedAction -> DelayedAction -> Bool
(==) DelayedAction
act1 DelayedAction
act2 = ObjectID -> ObjectID -> Bool
forall a. Eq a => a -> a -> Bool
(==) (DelayedAction -> ObjectID
oId DelayedAction
act1) (DelayedAction -> ObjectID
oId DelayedAction
act2)

instance Ord DelayedAction where
   compare :: DelayedAction -> DelayedAction -> Ordering
compare DelayedAction
act1 DelayedAction
act2 = ObjectID -> ObjectID -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DelayedAction -> ObjectID
oId DelayedAction
act1) (DelayedAction -> ObjectID
oId DelayedAction
act2)

instance HasDelayer Delayer where
   toDelayer :: Delayer -> Delayer
toDelayer Delayer
delayer = Delayer
delayer

-- ------------------------------------------------------------------------
-- Client Side
-- ------------------------------------------------------------------------

newDelayer :: IO Delayer
newDelayer :: IO Delayer
newDelayer =
   do
      MVar DelayerState
mVar <- DelayerState -> IO (MVar DelayerState)
forall a. a -> IO (MVar a)
newMVar DelayerState
emptyDelayerState
      Delayer -> IO Delayer
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar DelayerState -> Delayer
Delayer MVar DelayerState
mVar)

-- | carry out the given action preventing the Delayer from doing anything.
delay :: HasDelayer object => object -> IO a -> IO a
delay :: object -> IO a -> IO a
delay object
object IO a
action =
   do
      let
         delayer :: Delayer
delayer = object -> Delayer
forall object. HasDelayer object => object -> Delayer
toDelayer object
object
      Delayer -> IO ()
beginDelay Delayer
delayer
      IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
finally IO a
action (Delayer -> IO ()
endDelay Delayer
delayer)

beginDelay :: Delayer -> IO ()
beginDelay :: Delayer -> IO ()
beginDelay (Delayer MVar DelayerState
mVar) =
   MVar DelayerState -> (DelayerState -> IO DelayerState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar DelayerState
mVar (\ DelayerState
delayerState0 ->
      do
         let
            delayCount1 :: Int
delayCount1 = DelayerState -> Int
delayCount DelayerState
delayerState0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

            delayerState1 :: DelayerState
delayerState1 = DelayerState
delayerState0 {delayCount :: Int
delayCount = Int
delayCount1}

         DelayerState -> IO DelayerState -> IO DelayerState
seq DelayerState
delayerState1 (DelayerState -> IO DelayerState
forall (m :: * -> *) a. Monad m => a -> m a
return DelayerState
delayerState1)
      )

endDelay :: Delayer -> IO ()
endDelay :: Delayer -> IO ()
endDelay (Delayer MVar DelayerState
mVar) =
   do
      -- to reduce the danger of deadlocks, we don't perform the actions while
      -- the MVar is empty.
      IO ()
afterAct <- MVar DelayerState
-> (DelayerState -> IO (DelayerState, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar DelayerState
mVar (\ DelayerState
delayerState0 ->
         do
            let
               delayCount1 :: Int
delayCount1 = DelayerState -> Int
delayCount DelayerState
delayerState0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
            (DelayerState, IO ()) -> IO (DelayerState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
delayCount1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
               then
                  (DelayerState
delayerState0 {delayCount :: Int
delayCount = Int
delayCount1},IO ()
forall (m :: * -> *). Monad m => m ()
done)
               else
                  let
                     afterAct :: IO ()
afterAct = (DelayedAction -> IO ()) -> [DelayedAction] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
                        (\ DelayedAction
delayedAction -> DelayedAction -> IO ()
action DelayedAction
delayedAction)
                        (Set DelayedAction -> [DelayedAction]
forall a. Set a -> [a]
Set.toList (DelayerState -> Set DelayedAction
delayedActions DelayerState
delayerState0))
                  in
                     (DelayerState
emptyDelayerState,IO ()
afterAct)
               )
         )
      IO ()
afterAct


emptyDelayerState :: DelayerState
emptyDelayerState :: DelayerState
emptyDelayerState = DelayerState :: Int -> Set DelayedAction -> DelayerState
DelayerState {
   delayCount :: Int
delayCount = Int
0,
   delayedActions :: Set DelayedAction
delayedActions = Set DelayedAction
forall a. Set a
Set.empty
   }


-- ------------------------------------------------------------------------
-- Producer side
-- ------------------------------------------------------------------------

newDelayedAction :: IO () -> IO DelayedAction
newDelayedAction :: IO () -> IO DelayedAction
newDelayedAction IO ()
action =
   do
      ObjectID
oId <- IO ObjectID
newObject
      let
         delayedAction :: DelayedAction
delayedAction = DelayedAction :: ObjectID -> IO () -> DelayedAction
DelayedAction {
            oId :: ObjectID
oId = ObjectID
oId,
            action :: IO ()
action = IO ()
action
            }

      DelayedAction -> IO DelayedAction
forall (m :: * -> *) a. Monad m => a -> m a
return DelayedAction
delayedAction

-- } If no delay is taking place, perform the DelayedAction action
-- immediately.  Otherwise remember to do it when are no longer inside
-- a delay.
-- If the same DelayedAction is queued multiple times when a Delayer
-- is delay'd, we nevertheless only do it once.
delayedAct :: Delayer -> DelayedAction -> IO ()
delayedAct :: Delayer -> DelayedAction -> IO ()
delayedAct (Delayer MVar DelayerState
mVar) DelayedAction
delayedAct =
   do
      IO ()
afterAct <- MVar DelayerState
-> (DelayerState -> IO (DelayerState, IO ())) -> IO (IO ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar DelayerState
mVar (\ DelayerState
delayerState0 ->
         (DelayerState, IO ()) -> IO (DelayerState, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (
            if DelayerState -> Int
delayCount DelayerState
delayerState0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
               then
                  (DelayerState
delayerState0,DelayedAction -> IO ()
action DelayedAction
delayedAct)
               else
                  let
                     delayedActions1 :: Set DelayedAction
delayedActions1 = DelayedAction -> Set DelayedAction -> Set DelayedAction
forall a. Ord a => a -> Set a -> Set a
Set.insert DelayedAction
delayedAct
                        (DelayerState -> Set DelayedAction
delayedActions DelayerState
delayerState0)

                     delayerState1 :: DelayerState
delayerState1 = DelayerState
delayerState0 {
                        delayedActions :: Set DelayedAction
delayedActions = Set DelayedAction
delayedActions1
                        }
                  in
                     (DelayerState
delayerState1,IO ()
forall (m :: * -> *). Monad m => m ()
done)
            )
         )
      IO ()
afterAct

-- | If this DelayedAction is queued, remove it from the queue.
cancelDelayedAct :: Delayer -> DelayedAction -> IO ()
cancelDelayedAct :: Delayer -> DelayedAction -> IO ()
cancelDelayedAct (Delayer MVar DelayerState
mVar) DelayedAction
delayedAction =
   MVar DelayerState -> (DelayerState -> IO DelayerState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar DelayerState
mVar (\ DelayerState
delayerState0 ->
      let
         delayedActions1 :: Set DelayedAction
delayedActions1
            = DelayedAction -> Set DelayedAction -> Set DelayedAction
forall a. Ord a => a -> Set a -> Set a
Set.delete DelayedAction
delayedAction (DelayerState -> Set DelayedAction
delayedActions DelayerState
delayerState0)

         delayerState1 :: DelayerState
delayerState1 = DelayerState
delayerState0 {delayedActions :: Set DelayedAction
delayedActions = Set DelayedAction
delayedActions1}
      in
         DelayerState -> IO DelayerState
forall (m :: * -> *) a. Monad m => a -> m a
return DelayerState
delayerState1
      )