LazyMonadicQueue.hs

{-# LANGUAGE DeriveFunctor, BangPatterns #-}
module Queues.LazyMonadic where
import Data.Word
import Control.Applicative
import Control.Monad

data Result e a = Result
  { rval :: a
  , rlen :: Word
  , rremains :: [e]
  , rnew :: [e] -> [e] }
    deriving (Functor)

-- @Q e a@ represents a computation producing a value of type @a@ using
-- a queue of elements, each of type @e@. It is implemented as a function
-- taking the current length of the queue and the list of all elements that
-- have been or will ever be enqueued, and producing some value, the new
-- length of the queue, the portion of the queue that it did not consume,
-- and a function for adding all the elements it needs to the end of the
-- queue.
newtype Q e a = Q
  { unQ :: Word -> [e] -> Result e a }
    deriving (Functor)
  
instance Applicative (Q e) where
  pure a = Q (\ len q -> Result a len q id)
  m <*> n = Q go
    where
      go len q = Result (mval nval) nlen nremains (mnew . nnew)
        where
          Result nval nlen nremains nnew = unQ n mlen mremains
          Result mval mlen mremains mnew = unQ m len q
          
instance Monad (Q e) where
  return = pure
  m >>= f = Q go
    where
      go len q = Result fval flen fremains (mnew . fnew)
        where
          Result fval flen fremains fnew = unQ (f mval) mlen mremains
          Result mval mlen mremains mnew = unQ m len q

data Final e a = Final
  { ultimateVal :: a  -- The computed value
  , ultimateLen :: Word  -- The length of the queue at the end of the computation
  , ultimateQueue :: [e] -- The elements remaining in the queue at the end of the computation
  , allEnqueued :: [e] } -- All elements that were enqueued during the course of the computation
  deriving (Show, Functor)

-- | Run a queue computation, producing detailed information
runQ :: Q e a -> Final e a
runQ m = Final mval mlen mremains q
  where
    Result mval mlen mremains mnew = unQ m 0 q
    q = mnew []

-- | Run a queue computation, producing only the computed value
runQValue :: Q e a -> a
runQValue = ultimateVal . runQ

-- | Run a queue computation, producing only a list of items enqueued
runQEnqueued :: Q e a -> [e]
runQEnqueued = allEnqueued . runQ

-- | Enqueue an element
enQ :: e -> Q e ()
enQ e = Q $ \ !len q -> Result () (1 + len) q (e :)

-- | Dequeue and return the first element of the qeueue
deQ :: Q e (Maybe e)
deQ = Q go
  where
    go 0 q = Result Nothing 0 q id
    go n (e : es) = Result (Just e) (n - 1) es id

-- | Get the current length of the queue
lenQ :: Q e Word
lenQ = Q $ \ !len q -> Result len len q id

-- | Peek at the first few queue elements without removing them.
peekN :: Integral n => n -> Q e [e]
peekN n = Q $ \ !len q -> Result (take (fromIntegral (min (fromIntegral n) len)) q) len q id