{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, 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.State.Lazy
import Control.Monad.Queue.Class
import Control.Monad.RWS.Class
import Control.Monad.Fix
import Control.Monad.Trans(MonadIO, MonadTrans(..))
import Control.Monad.ST.Class(MonadST)
import Control.Monad(Monad)
import Control.Monad.Trans.Operations
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, MonadST s, 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)

-- | Unwraps a queue transformer, initializing it with an empty queue.
runQueueT :: (Monad m, Queuelike q e) => 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 e) => QueueT q m a -> [e] -> 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 e => 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 e => QueueM q a -> [e] -> 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 e) => MonadQueue e (QueueT q m) where
	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue e (PQueueT e m) #-}
	{-# SPECIALIZE instance (Ord e, Monad m) => MonadQueue e (FibQueueT e m) #-}
	queueInsert x = QueueT $ modify (insert x)
	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 e => MonadQueue e (QueueM q) where
	{-# SPECIALIZE instance Ord e => MonadQueue e (PQueueM e) #-}
	{-# SPECIALIZE instance Ord e => MonadQueue e (FibQueueM e) #-}
	queueInsert x = QueueM $ modify (insert x)
	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