treeowl · August 30, 2016 06:44 · Aug 30, 2016 · Apr 13, 2016 · Apr 13, 2016 · Apr 13, 2016
diff --git a/LazyMonadicQueue.hs b/LazyMonadicQueue.hs
@@ -62,14 +62,21 @@ runQValue = ultimateVal . runQ
 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
diff --git a/LazyMonadicQueue.hs b/LazyMonadicQueue.hs
@@ -20,9 +20,7 @@ data Result e a = Result
 -- queue.
 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
+    deriving (Functor)
 
 instance Applicative (Q e) where
   pure a = Q (\ len q -> Result a len q id)

diff --git a/LazyMonadicQueue.hs b/LazyMonadicQueue.hs
@@ -11,6 +11,13 @@ data Result e a = Result
   , 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 }
 

diff --git a/LazyMonadicQueue.hs b/LazyMonadicQueue.hs
@@ -0,0 +1,70 @@
+{-# 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