-- | A toggle is a switch initially True, which can only be made false
-- (when some action is performed, say).  This module implements
-- toggles, allowing atomic switching to false of 1 toggle, or
-- 2 toggles together.  To avoid deadlock we use a supply of unique
-- integers.
module Events.Toggle(
   Toggle, -- toggle type
   newToggle, -- create a new toggle
   toggle1, -- set the toggle to false, and return the original value.
   toggle2, -- if toggles are both true, change them to false, otherwise
   -- leave the toggle settings unchanged and return them.
   ifToggle, -- :: Toggle -> IO () -> IO ()
   -- If the toggle is true, change it to false and execute action.
   peekToggle, -- :: Toggle -> IO Bool
   -- peek at the contents of a toggle, without changing it.

   SimpleToggle, -- A simple toggle.  We can only flip these one at a time.
   newSimpleToggle, -- create a new simple toggle
   simpleToggle, -- set this toggle to false, and return the original value.
   ifSimpleToggle, -- like ifToggle
   ) where

import Control.Concurrent

import Util.Computation
import Util.Object

-- ----------------------------------------------------------------------
-- Simple Toggles
-- ----------------------------------------------------------------------

newtype SimpleToggle = SimpleToggle (MVar Bool)

newSimpleToggle :: IO SimpleToggle
newSimpleToggle :: IO SimpleToggle
newSimpleToggle =
   do
      MVar Bool
mVar <- Bool -> IO (MVar Bool)
forall a. a -> IO (MVar a)
newMVar Bool
True
      SimpleToggle -> IO SimpleToggle
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar Bool -> SimpleToggle
SimpleToggle MVar Bool
mVar)

simpleToggle :: SimpleToggle -> IO Bool
simpleToggle :: SimpleToggle -> IO Bool
simpleToggle (SimpleToggle MVar Bool
mVar) =
   do
      Bool
oldVal <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
mVar
      MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mVar Bool
False
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
oldVal

ifSimpleToggle :: SimpleToggle -> IO () -> IO ()
ifSimpleToggle :: SimpleToggle -> IO () -> IO ()
ifSimpleToggle SimpleToggle
sToggle IO ()
action =
   do
      Bool
goAhead <- SimpleToggle -> IO Bool
simpleToggle SimpleToggle
sToggle
      if Bool
goAhead then IO ()
action else IO ()
forall (m :: * -> *). Monad m => m ()
done

-- simpleToggle2 is not safe from deadlocks
simpleToggle2 :: SimpleToggle -> SimpleToggle -> IO (Maybe (Bool,Bool))
simpleToggle2 :: SimpleToggle -> SimpleToggle -> IO (Maybe (Bool, Bool))
simpleToggle2 (SimpleToggle MVar Bool
mVar1) (SimpleToggle MVar Bool
mVar2) =
   do
      Bool
oldVal1 <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
mVar1
      Bool
oldVal2 <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
mVar2
      if (Bool
oldVal1 Bool -> Bool -> Bool
&& Bool
oldVal2)
         then
            do
               MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mVar2 Bool
False
               MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mVar1 Bool
False
               Maybe (Bool, Bool) -> IO (Maybe (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Bool, Bool)
forall a. Maybe a
Nothing
         else
            do
               MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mVar2 Bool
oldVal2
               MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mVar1 Bool
oldVal1
               Maybe (Bool, Bool) -> IO (Maybe (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Bool) -> Maybe (Bool, Bool)
forall a. a -> Maybe a
Just (Bool
oldVal1,Bool
oldVal2))


-- peekSimpleToggle is used by toggle2
peekSimpleToggle :: SimpleToggle -> IO Bool
peekSimpleToggle :: SimpleToggle -> IO Bool
peekSimpleToggle (SimpleToggle MVar Bool
mVar) = MVar Bool -> IO Bool
forall a. MVar a -> IO a
readMVar MVar Bool
mVar

-- ----------------------------------------------------------------------
-- Toggles
-- ----------------------------------------------------------------------

data Toggle = Toggle !ObjectID !SimpleToggle

newToggle :: IO Toggle
newToggle :: IO Toggle
newToggle =
   do
      ObjectID
uniqVal <- IO ObjectID
newObject
      SimpleToggle
stoggle <- IO SimpleToggle
newSimpleToggle
      Toggle -> IO Toggle
forall (m :: * -> *) a. Monad m => a -> m a
return (ObjectID -> SimpleToggle -> Toggle
Toggle ObjectID
uniqVal SimpleToggle
stoggle)

toggle1 :: Toggle -> IO Bool
-- switch bool to false, returning original value.
toggle1 :: Toggle -> IO Bool
toggle1 (Toggle ObjectID
_ SimpleToggle
stoggle) = SimpleToggle -> IO Bool
simpleToggle SimpleToggle
stoggle

ifToggle :: Toggle -> IO () -> IO ()
ifToggle :: Toggle -> IO () -> IO ()
ifToggle Toggle
toggle IO ()
action =
   do
      Bool
goAhead <- Toggle -> IO Bool
toggle1 Toggle
toggle
      if Bool
goAhead then IO ()
action else IO ()
forall (m :: * -> *). Monad m => m ()
done

toggle2 :: Toggle -> Toggle -> IO(Maybe(Bool,Bool))
-- Switch both toggles to from True to False, atomically, if possible.
-- If we can't do this, return Just (the current status of the toggles).
toggle2 :: Toggle -> Toggle -> IO (Maybe (Bool, Bool))
toggle2 (Toggle ObjectID
unique1 SimpleToggle
stoggle1) (Toggle ObjectID
unique2 SimpleToggle
stoggle2) =
   case ObjectID -> ObjectID -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ObjectID
unique1 ObjectID
unique2 of
      Ordering
LT -> SimpleToggle -> SimpleToggle -> IO (Maybe (Bool, Bool))
simpleToggle2 SimpleToggle
stoggle1 SimpleToggle
stoggle2
      Ordering
GT ->
         do
            Maybe (Bool, Bool)
result <- SimpleToggle -> SimpleToggle -> IO (Maybe (Bool, Bool))
simpleToggle2 SimpleToggle
stoggle2 SimpleToggle
stoggle1
            case Maybe (Bool, Bool)
result of
               Maybe (Bool, Bool)
Nothing -> Maybe (Bool, Bool) -> IO (Maybe (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Bool, Bool)
forall a. Maybe a
Nothing
               Just (Bool
r1,Bool
r2) -> Maybe (Bool, Bool) -> IO (Maybe (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Bool) -> Maybe (Bool, Bool)
forall a. a -> Maybe a
Just (Bool
r2,Bool
r1))
      Ordering
EQ ->
         do
            Bool
r <- SimpleToggle -> IO Bool
peekSimpleToggle SimpleToggle
stoggle1
            Maybe (Bool, Bool) -> IO (Maybe (Bool, Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Bool) -> Maybe (Bool, Bool)
forall a. a -> Maybe a
Just (Bool
r,Bool
r))

-- peekToggle is used in Channels.hs to avoid a memory leak.
peekToggle :: Toggle -> IO Bool
peekToggle :: Toggle -> IO Bool
peekToggle (Toggle ObjectID
_ SimpleToggle
sToggle) = SimpleToggle -> IO Bool
peekSimpleToggle SimpleToggle
sToggle


-- ----------------------------------------------------------------------
-- Optimisations
-- ----------------------------------------------------------------------


{-# INLINE newToggle #-}
{-# INLINE toggle1 #-}
{-# INLINE toggle2 #-}
{-# INLINE peekToggle #-}
{-# INLINE newSimpleToggle #-}
{-# INLINE simpleToggle #-}
{-# INLINE simpleToggle2 #-}