Skip to content

Instantly share code, notes, and snippets.

@treeowl
Last active August 30, 2016 06:44
Show Gist options
  • Save treeowl/5c14a43869cf14a823473ec075788a74 to your computer and use it in GitHub Desktop.
Save treeowl/5c14a43869cf14a823473ec075788a74 to your computer and use it in GitHub Desktop.
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment