{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances, FlexibleInstances #-} -- | 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.Strict 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) type IntQueueT = QueueT IntQueue type IntQueueM = QueueM IntQueue -- | 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 {-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (PQueueT e m) #-} {-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (FibQueueT e m) #-} {-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue (SkewQueueT e m) #-} {-# SPECIALIZE instance (Monad m) => MonadQueue (IntQueueT m) #-} type QKey (QueueT q m) = QueueKey q 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 {-# SPECIALIZE instance Ord e => MonadQueue (PQueueM e) #-} {-# SPECIALIZE instance Ord e => MonadQueue (FibQueueM e) #-} {-# SPECIALIZE instance Ord e => MonadQueue (SkewQueueM e) #-} {-# SPECIALIZE instance MonadQueue IntQueueM #-} type QKey (QueueM q) = QueueKey q 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