-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Queue.ST
-- Copyright   :  (c) Leon P Smith 2009
-- License     :  BSD3
--
-- Maintainer  :  leon at melding-monads dot com
-- Stability   :  experimental
-- Portability :  portable
--
-----------------------------------------------------------------------------

{-# LANGUAGE RankNTypes #-}

module Control.Monad.Queue.ST
     ( Q()
     , enQ
     , deQ
     , lenQ_
     , runResult
     ) where

import qualified Control.Monad.Queue.Class
import Control.Monad.Queue.Util
import Control.Monad.ST.Strict
import Data.STRef.Strict

type  ListPtr st a = STRef st (List st a)
data  List st a
   =  Null
   |  Cons a {-# UNPACK #-} !(ListPtr st a)

type  QSt st res elt = LenType -> ListPtr st elt -> ListPtr st elt -> ST st res
newtype Q elt a
      = Q { unQ :: forall res st. ((a -> QSt st res elt) -> QSt st res elt) }

instance Monad (Q st) where
    return a = Q (\k -> k a)
    m >>= f  = Q (\k -> unQ m (\a -> unQ (f a) k))

enQ :: e -> Q e ()
enQ e  = Q $ \k n a z -> do
                 z' <- newSTRef Null
                 writeSTRef z (Cons e z')
                 (k () $! n+1) a z'

deQ :: Q e (Maybe e)
deQ    = Q $ \k n a z -> do
                 list <- readSTRef a
                 case list of
                   Null
                     -> (k Nothing  $! n-1) a  z
                   (Cons e a')
                     -> (k (Just e) $! n-1) a' z

lenQ_ :: Q e LenType
lenQ_ = Q (\k n a z -> k n n a z)

runResult m = runST $ do
  ref <- newSTRef Null
  unQ m (\a n front back -> return a) 0 ref ref