SyncQueue.hs

{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}

-- | In the IO monad, provides thread-safe 'MVar'-based wrappers for 'Queuelike' and 'MQueue' instances.
module Data.MQueue.SyncQueue (SyncQ, SyncMQ) where

import Data.Queue.Class 
import qualified Data.Queue.Class as Q
import Data.MQueue.Class

-- import Data.Tuple.HT
import Control.Arrow

import Control.Concurrent.MVar
import Control.Monad.Trans

import Control.Monad
import Data.Maybe

newtype SyncQ q = SyncQ (MVar q)
newtype SyncMQ q = SyncMQ (MVar q)

instance (MonadIO m, IQueue q) => MQueue (SyncQ q) m where
	{-# SPECIALIZE instance IQueue q => MQueue (SyncQ q) IO #-}
	type MQueueKey (SyncQ q) = QueueKey q
	newQueue = liftIO $ liftM SyncQ $ newMVar empty
	push (SyncQ var) k = liftIO $ modifyMVar_ var (return . insert k)
	peek = withSyncQ Q.top
	pop (SyncQ var) = liftIO $ modifyMVar var (\ q -> return ((maybe q snd &&& fmap fst) (extract q)))
	pop_ (SyncQ var) = liftIO $ modifyMVar_ var (return . (fromMaybe `ap` delete))
-- 	getSize = withSyncQ Q.size
	isEmpty = withSyncQ Q.null

{-# INLINE withSyncQ #-}
withSyncQ :: (MonadIO m, IQueue q) => (q -> a) -> SyncQ q -> m a
withSyncQ f (SyncQ var) = liftIO $ withMVar var (return . f)

instance (MonadIO m, MQueue q IO) =>  MQueue (SyncMQ q) m where
	{-# SPECIALIZE instance MQueue q IO => MQueue (SyncMQ q) IO #-}
	type MQueueKey (SyncMQ q) = MQueueKey q
	newQueue = liftIO $ liftM SyncMQ $ newQueue >>= newMVar
	q `push` k = onSyncMQ (`push` k) q
	q `pushAll` ks = onSyncMQ (`pushAll` ks) q
	peek = onSyncMQ peek
	pop = onSyncMQ pop
	pop_ = onSyncMQ pop_
-- 	getSize = onSyncMQ getSize
	isEmpty = onSyncMQ isEmpty

{-# INLINE onSyncMQ #-}
onSyncMQ :: (MonadIO m, MQueue q IO) => (q -> IO a) -> SyncMQ q -> m a
onSyncMQ f (SyncMQ var) = liftIO $ withMVar var f

-- let ext = extract q in return (maybe q snd ext, fmap snd ext)