{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Queue.Allison
-- Copyright   :  (c) Leon P Smith 2009-2011
-- License     :  BSD3
--
-- Maintainer  :  leon@melding-monads.com
-- Stability   :  experimental
--
-- A library implementation of corecursive queues,  see
-- /Circular Programs and Self-Referential Structures/ by Lloyd Allison,
-- /Software Practice and Experience/, 19(2), pp.99-109, Feb 1989
--
-- <http://www.csse.monash.edu.au/~lloyd/tildeFP/1989SPE/>
--
-- For an explanation of the library implementation, see
-- /Lloyd Allison's Corecursive Queues:  Why Continuations Matter/
-- by Leon P Smith,  in /The Monad Reader/, Issue 14, Jul 2009.   This library
-- corresponds to @CorecQ@ in that paper.
--
-- <http://themonadreader.files.wordpress.com/2009/07/issue142.pdf>
--
-----------------------------------------------------------------------------

module  Control.Monad.Queue.Allison
     (  Q()
     ,  LenType
     ,  runQueue
     ,  enQ
     ,  deQ
     ,  deQs
     ,  deQ_break
     ,  peekQ
     ,  peekQn
     ,  peekQs
     ,  lenQ
     ,  lenQ_
     ,  callCC
     ,  exit
     )  where

import Control.Applicative
import Control.Monad.Queue.Util
import Data.List(genericIndex, genericTake, genericSplitAt)

newtype Q e a = Q { unQ :: Cont (LenType -> [e] -> [e]) a }

instance Functor (Q e) where
  fmap f m  = Q (\k -> unQ m (k . f))

instance Applicative (Q e) where
  pure a    = Q (\k -> k a)
  f <*> v   = Q (\k -> unQ f (\g -> unQ v (k . g)))

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

callCC :: ((a -> forall b. Q e b) -> Q e a) -> Q e a
callCC f = Q (\k -> unQ (f (\a -> Q (\_ -> k a))) k)

-- | Terminates the queue computation
exit :: Q e a
exit =  Q (\_k _n _q -> [])

-- | Enqueues an element to the queue
enQ :: e -> Q e ()
enQ e = Q (\k n q -> e : (k () $! n+1) q)

-- | Dequeues an element,  returns 'Nothing' if the queue is empty.
deQ :: Q e (Maybe e)
deQ   = Q delta
  where
    delta k n q
       | n <= 0    = k Nothing n q
       | otherwise = case q of
                      [] -> error "Control.Monad.Queue.Allison.deQ: empty list"
                      (e:q') -> (k (Just e) $! n-1) q'

-- | Dequeues an element:  terminates the queue computation if the queue is empty.
deQ_break :: Q e e
deQ_break =  Q delta
  where
    delta k n q
       | n <= 0    = []
       | otherwise = case q of
                      [] -> error "Control.Monad.Queue.Allison.deQ_break: empty list"
                      (e:q') -> (k e $! n-1) q'

-- | Dequeues up to @len@ elements from the queue
deQs :: Integral len => len -> Q e [e]
deQs i = Q delta
  where
    delta k n q
       = let i' = min (fromIntegral (max 0 i)) n
             (res,q') = genericSplitAt i' q
          in (k res $! n-i') q'

-- | Examines the front element of the queue without removing it.
peekQ :: Q e (Maybe e)
peekQ = Q delta
  where
    delta k n q
       | n <= 0    = k Nothing n q
       | otherwise = case q of
                      [] -> error "Control.Monad.Queue.Allison.peekQ: empty list"
                      (e:_q') -> k (Just e) n q

-- | Examines the element currently at position @index@ in the queue, indexing starts with @0@,  like '!!'.
peekQn :: (Integral index) => index -> Q e (Maybe e)
peekQn i_ = Q delta
  where
    i = fromIntegral i_

    delta k n q
       | not (0 <= i_ && i < n) = k Nothing n q
       | otherwise = k (Just (genericIndex q i)) n q

-- | Examines up to @maxlen@ elements of the queue without removing them.
peekQs :: (Integral maxlen) => maxlen -> Q e [e]
peekQs i_ = Q delta
  where
    i = fromIntegral (max 0 i_)
    delta k n q = k (genericTake (min i n) q) n q

-- | Returns the length of the queue
lenQ_ :: Q e LenType
lenQ_ = Q (\k n q -> k n n q)

-- | Returns the length of the queue
lenQ  :: Integral len => Q e len
lenQ  = Q (\k n q -> k (fromIntegral n) n q)

-- | Returns a list of all elements enqueued during the queue computation
runQueue :: Q e a -> [e]
runQueue m = q
  where
    q = unQ m (\_ _ _ -> []) 0 q