-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Queue.Allison
-- Copyright   :  (c) Leon P Smith 2009
-- License     :  BSD3
--
-- Maintainer  :  leon at melding-monads dot com
-- Stability   :  experimental
-- Portability :  portable
--
-- 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.   This library
-- corresponds to @CorecQ@ in that paper.
--
-----------------------------------------------------------------------------

{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE RankNTypes                 #-}

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

import qualified Control.Monad.Queue.Class as Class
import Control.Monad.Queue.Util
import Data.List(genericIndex, genericTake, genericSplitAt)

type QSt e = LenType -> [e] -> [e]

newtype Q e a = Q { unQ :: (a -> QSt e) -> QSt e }

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)

-- | 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 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
       | n < i     = 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 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

instance Class.MonadQueue e (Q e) where
  enQ     = enQ
  peekQ   = peekQ
  peekQs  = peekQs
  peekQn  = peekQn
  deQ     = deQ
  deQs    = deQs
  lenQ    = lenQ