Skip to content

Instantly share code, notes, and snippets.

@fryguybob fryguybob/TLQueue.hs Secret
Created Mar 26, 2015

Embed
What would you like to do?
import Control.Concurrent.STM
import Control.Monad
data TList a = Nil | TNode a (TVar (TList a))
data TLQueue a = TLQueue
{ queueHead :: TVar (TList a)
, queueTail :: TVar (TVar (TList a))
}
newTLQueue :: STM (TLQueue a)
newTLQueue = do
h <- newTVar Nil
t <- newTVar h
return $ TLQueue h t
readTLQueue :: TLQueue a -> STM a
readTLQueue (TLQueue h t) = do
n <- readTVar h
case n of
Nil -> retry
TNode a p -> do
n' <- readTVar p
case n' of
Nil -> writeTVar h n' >> writeTVar t h
_ -> writeTVar h n'
return a
tryReadTLQueue :: TLQueue a -> STM (Maybe a)
tryReadTLQueue q = (Just `fmap` readTLQueue q) `orElse` return Nothing
peakTLQueue :: TLQueue a -> STM a
peakTLQueue (TLQueue h _) = do
n <- readTVar h
case n of
Nil -> retry
TNode a _ -> return a
-- h t --+
-- | |
-- v v
-- (x, _ -)--> (y, p -)--> Nil <--+
-- | |
-- writeTVar p... * |
-- | |
-- +-------> (a, end)
-- ^
-- |
-- writeTVar t end *
-- |
-- t
writeTLQueue :: TLQueue a -> a -> STM ()
writeTLQueue (TLQueue _ t) a = do
end <- newTVar Nil
p <- readTVar t
writeTVar p (TNode a end)
writeTVar t end
test :: IO ()
test = do
q <- atomically newTLQueue
let vs = [0..10] :: [Int]
forM_ vs $ atomically . writeTLQueue q
vs' <- forM vs $ \_ -> atomically (readTLQueue q `orElse` return (-1))
putStrLn "Expecting:"
print vs
putStrLn "Saw:"
print vs'
putStrLn "Expecting:"
print (-1)
putStrLn "Saw:"
v <- atomically (readTLQueue q `orElse` return (-1))
print v
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.