content: 
  module GUI.ConcurrencyControl (
      ConcurrencyControl,
      start,
      fullSpeed,
    ) where
  
  import qualified System.Glib.MainLoop as Glib
  import qualified Control.Concurrent as Concurrent
  import qualified Control.Exception  as Exception
  import Control.Concurrent.MVar
  
  
  newtype ConcurrencyControl = ConcurrencyControl (MVar (Int, Glib.HandlerId))
  
  -- | Setup cooperative thread scheduling with Gtk+.
  --
  start :: IO ConcurrencyControl
  start = do
    handlerId <- normalScheduling
    return . ConcurrencyControl =<< newMVar (0, handlerId)
  
  -- | Run an expensive action that needs to use all the available CPU power.
  --
  -- The normal cooperative GUI thread scheduling does not work so well in this
  -- case so we use an alternative technique. We can't use this one all the time
  -- however or we'd hog the CPU even when idle.
  --
  fullSpeed :: ConcurrencyControl -> IO a -> IO a
  fullSpeed (ConcurrencyControl handlerRef) =
      Exception.bracket_ begin end
    where
      -- remove the normal scheduling handler and put in the full speed one
      begin = do
        (count, handlerId) <- takeMVar handlerRef
        if count == 0
          -- nobody else is running fullSpeed
          then do Glib.timeoutRemove handlerId
                  handlerId' <- fullSpeedScheduling
                  putMVar handlerRef (1, handlerId')
          -- we're already running fullSpeed, just inc the count
          else do putMVar handlerRef (count+1, handlerId)
  
      -- reinstate the normal scheduling
      end = do
        (count, handlerId) <- takeMVar handlerRef
        if count == 1
          -- just us running fullSpeed so we clean up
          then do Glib.timeoutRemove handlerId
                  handlerId' <- normalScheduling
                  putMVar handlerRef (0, handlerId')
          -- someone else running fullSpeed, they're responsible for stopping
          else do putMVar handlerRef (count-1, handlerId)
  
  normalScheduling :: IO Glib.HandlerId
  normalScheduling =
    Glib.timeoutAddFull
      (Concurrent.yield >> return True)
      Glib.priorityDefaultIdle 50
      --50ms, ie 20 times a second.
  
  fullSpeedScheduling :: IO Glib.HandlerId
  fullSpeedScheduling =
    Glib.idleAdd
      (Concurrent.yield >> return True)
      Glib.priorityDefaultIdle
  