{-
 -      ``Data/Queue/Instances/STM''
 -      (c) 2008 Cook, J. MR  SSD, Inc.
 -}
{-# LANGUAGE
        MultiParamTypeClasses,
        FlexibleInstances
  #-}

module Data.Queue.Instances.STM
        ( STM
        
        , TChan
        , TMVar
        
        , atomically
        
        ) where

import Data.Queue.Classes

import Control.Concurrent.STM

-- TChan : full-featured FIFO in STM and IO monads; peekQueue is quite costly though
instance DefaultFifo (TChan a) STM a
instance NewFifo (TChan a) STM where
        newFifo = newTChan
instance Enqueue (TChan a) STM a where
        enqueue = writeTChan
instance Dequeue (TChan a) STM a where
        dequeue ch = fmap Just (readTChan ch) `orElse` return Nothing
instance PeekQueue (TChan a) STM a where
        peekQueue ch = do
                let     dequeueAll :: Dequeue q m a => q -> m [a]
                        dequeueAll q = do
                                item <- dequeue q
                                case item of
                                        Nothing -> return []
                                        Just h -> do
                                                t <- dequeueAll q
                                                return (h:t)
                
                xs <- dequeueAll ch
                mapM_ (enqueue ch) xs
                return xs
        
        peekQueueTaking  0    q = return []
        peekQueueTaking (n+1) q = do
            x <- dequeue q
            case x of
                Nothing -> return []
                Just x  -> do
                    xs <- peekQueueTaking n q
                    unGetTChan q x
                    return (x:xs)

instance DefaultFifo (TChan a) IO a
instance NewFifo (TChan a) IO where
        newFifo = newTChanIO
instance Enqueue (TChan a) IO a where
        enqueue ch = atomically . enqueue ch
instance Dequeue (TChan a) IO a where
        dequeue = atomically . dequeue
instance PeekQueue (TChan a) IO a where
        peekQueue = atomically . peekQueue

-- TMVar : one-item queue in STM and IO monads
instance NewFifo (TMVar a) STM where
        newFifo = newEmptyTMVar
instance Enqueue (TMVar a) STM a where
        enqueue = putTMVar
instance Dequeue (TMVar a) STM a where
        dequeue = tryTakeTMVar

instance NewFifo (TMVar a) IO where
        newFifo = newEmptyTMVarIO
instance Enqueue (TMVar a) IO a where
        enqueue ch = atomically . enqueue ch
instance Dequeue (TMVar a) IO a where
        dequeue = atomically . dequeue