{-# LANGUAGE DeriveDataTypeable #-}

-----------------------------------------------------------------------
-- |
-- Module     : Control/Concurrent/Queue/Nonblocking.hs
-- Copyright  : (c) Ivan Tomac 2012
-- License    : BSD3
--
-- Maintainer : ivan `dot` tomac `at` google `dot` com
-- Stability  : experimental
--
-- Single writer, multiple reader queue, non-blocking.
-- Slightly more efficient than the blocking version.
--
-- A queue is represented by a single 'IORef' containing the barrier
-- flag, the value to be read and the end of the queue.
-- Writing to the 'Queue' is guarded by an 'MVar'.
-- When a 'Queue' is initialized, the barrier is set to @True@.
-- Reading from the 'Queue' queries the barrier to see if it is safe
-- to retrieve the value and the new end of the queue.
--
-- 'Queue' 's elements can safely be read multiple times from multiple
-- threads.
--
-----------------------------------------------------------------------

module Control.Concurrent.Queue.Nonblocking
  ( -- * The 'Queue' type
    Queue (..)

    -- * Operations
  , newQ
  , newQ'
  , readQ
  , unsafeWriteQ
  ) where

import Control.Applicative
import Control.Concurrent.MVar
import Data.IORef
import Data.Typeable

newtype Queue a = Q (IORef (Bool, (a, Queue a)))
    deriving (Eq, Typeable)

-- | Returns a new 'Queue' and a function to write to it.
newQ :: IO (a -> IO (), Queue a)
newQ = newQ' >>= liftA2 fmap result newMVar
    where result q v = (modifyMVar_ v . flip unsafeWriteQ, q)

-- | Returns only the 'Queue', without the writing function.
newQ' :: IO (Queue a)
newQ' = Q <$> newIORef (True, undefined)

-- | Returns the next value in the 'Queue' if one is available, along
-- with the rest of the 'Queue'.
-- If the 'Queue' is empty, it returns 'Nothing'.
readQ :: Queue a -> IO (Maybe (a, Queue a))
readQ (Q ref) = uncurry barrier <$> readIORef ref
    where barrier True  = const Nothing
          barrier False = Just

-- | Writes a value to the 'Queue'. 'unsafeWriteQ' is not thread-safe.
-- It is meant to be used for building higher level concurrency
-- primitives and is not intended to be used directly.
unsafeWriteQ :: Queue a -> a -> IO (Queue a)
unsafeWriteQ (Q ref) x = newQ' >>= liftA2 (>>) write return
    where write q = writeIORef ref (False, (x, q))