QueueT.hs

{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-}


-- | A monad transformer allowing a purely functional queue implementation (specifically, implementing the 'Queuelike' abstraction) to be used in a monadic, single-threaded fashion.
module Control.Monad.Queue.QueueT where

import Data.Queue
import Control.Monad.Queue.Class

import Control.Monad.Trans.Operations

import Control.Monad.State.Lazy
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad

import Data.Maybe

-- | A monad transformer granting the underlying monad @m@ access to single-threaded actions on a queue.
newtype QueueT q m a = QueueT {runQT :: StateT q m a} deriving (MonadReader r, MonadWriter w, MonadIO, MonadFix, Monad, MonadTrans)
-- | A monad controlling single-threaded access to a queue.
newtype QueueM q a = QueueM {runQM :: State q a} deriving (MonadFix, Monad)
type PQueueT e = QueueT (PQueue e)
type PQueueM e = QueueM (PQueue e)
type FibQueueT e = QueueT (FQueue e)
type FibQueueM e = QueueM (FQueue e)
type SkewQueueT e = QueueT (SkewQueue e)
type SkewQueueM e = QueueM (SkewQueue e)

-- | Unwraps a queue transformer, initializing it with an empty queue.
runQueueT :: (Monad m, Queuelike q) => QueueT q m a -> m a
runQueueT m = evalStateT (runQT m) empty

-- | Unwraps a queue transformer, initializing it with a queue with the specified contents.
runQueueTOn :: (Monad m, Queuelike q) => QueueT q m a -> [QueueKey q] -> m a
runQueueTOn m xs = evalStateT (runQT m) (fromList xs)

-- | Executes a computation in a queue monad, starting with an empty queue.
runQueueM :: Queuelike q => QueueM q a -> a
runQueueM m = evalState (runQM m) empty

-- | Executes a computation in a queue monad, starting with a queue with the specified contents.
runQueueMOn :: Queuelike q => QueueM q a -> [QueueKey q] -> a
runQueueMOn m xs = evalState (runQM m) (fromList xs)

instance MonadState s m => MonadState s (QueueT q m) where
	get = lift get
	put = lift . put

instance (Monad m, Queuelike q) => MonadQueue (QueueT q m) where
	type QKey (QueueT q m) = QueueKey q
	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (PQueueT e m) #-}
	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (FibQueueT e m) #-}
	queueInsert x = QueueT $ modify (insert x)
	queueInsertAll xs = QueueT $ modify (insertAll xs)
	queueExtract = QueueT $ statefully (\ q -> maybe (Nothing, q) (\ (x, q') -> (Just x, q')) (extract q))
	queueEmpty = QueueT $ gets isEmpty
	queueDelete  = QueueT $ modify (\ q -> fromMaybe empty (delete q))
	queuePeek = QueueT $ gets peek
	queueSize = QueueT $ gets size

instance Queuelike q => MonadQueue (QueueM q) where
	type QKey (QueueM q) = QueueKey q
	{-# SPECIALIZE instance Ord e => MonadQueue (PQueueM e) #-}
	{-# SPECIALIZE instance Ord e => MonadQueue (FibQueueM e) #-}
	queueInsert x = QueueM $ modify (insert x)
	queueInsertAll xs = QueueM $ modify (insertAll xs)
	queueExtract = QueueM $ statefully (\ q -> maybe (Nothing, q) (\ (x, q') -> (Just x, q')) (extract q))
	queueEmpty = QueueM $ gets isEmpty
	queueDelete  = QueueM $ modify (\ q -> fromMaybe empty (delete q))
	queuePeek = QueueM $ gets peek
	queueSize = QueueM $ gets size