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)

newtype Q e a = Q
  { unQ :: Word -> [e] -> Result e a }

instance Functor (Q e)  where
  fmap f m = Q $ \ len q -> f <$> unQ m len q
  
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

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

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

lenQ :: Q e Word
lenQ = Q $ \ !len q -> Result len len q id