module Data.STM.LinkedList.Internal where
import Control.Concurrent.STM
import Data.Maybe (isJust, isNothing)
import System.IO (fixIO)
newtype LinkedList a = LinkedList (Node a)
listHead :: LinkedList a -> Node a
listHead (LinkedList h) = h
data Node a
= Node
{ nodePrev :: NodePtr a
, nodeNext :: NodePtr a
, nodeValue :: Maybe a
}
type NodePtr a = TVar (Node a)
instance Eq (Node a) where
a == b = nodeNext a == nodeNext b
value :: Node a -> a
value node = case nodeValue node of
Just v -> v
Nothing -> error "LinkedList.value: list head"
null :: LinkedList a -> STM Bool
null (LinkedList list_head) = do
first <- readTVar $ nodeNext list_head
return $ isNothing $ nodeValue first
length :: LinkedList a -> STM Int
length (LinkedList list_head) = foldlHelper (\a _ -> a + 1) 0 nodeNext list_head
empty :: STM (LinkedList a)
empty = do
prev_ptr <- newTVar undefined
next_ptr <- newTVar undefined
let node = Node prev_ptr next_ptr Nothing
writeTVar prev_ptr node
writeTVar next_ptr node
return $ LinkedList node
emptyIO :: IO (LinkedList a)
emptyIO = do
node <- fixIO $ \node -> do
prev_ptr <- newTVarIO node
next_ptr <- newTVarIO node
return (Node prev_ptr next_ptr Nothing)
return $ LinkedList node
insertBetween :: a -> Node a -> Node a -> STM (Node a)
insertBetween v left right = do
prev_ptr <- newTVar left
next_ptr <- newTVar right
let node = Node prev_ptr next_ptr (Just v)
writeTVar (nodeNext left) node
writeTVar (nodePrev right) node
return node
prepend :: a -> LinkedList a -> STM (Node a)
prepend v (LinkedList list_head) = do
right <- readTVar $ nodeNext list_head
insertBetween v list_head right
append :: a -> LinkedList a -> STM (Node a)
append v (LinkedList list_head) = do
left <- readTVar $ nodePrev list_head
insertBetween v left list_head
insertBefore :: a -> Node a -> STM (Node a)
insertBefore v node = do
left <- readTVar $ nodePrev node
if left == node && isJust (nodeValue node)
then error "LinkedList.insertBefore: node removed from list"
else insertBetween v left node
insertAfter :: a -> Node a -> STM (Node a)
insertAfter v node = do
right <- readTVar $ nodeNext node
if right == node && isJust (nodeValue node)
then error "LinkedList.insertAfter: node removed from list"
else insertBetween v node right
delete :: Node a -> STM ()
delete node
| isNothing (nodeValue node) =
error "LinkedList.delete: list head"
| otherwise = do
left <- readTVar $ nodePrev node
right <- readTVar $ nodeNext node
writeTVar (nodeNext left) right
writeTVar (nodePrev right) left
writeTVar (nodePrev node) node
writeTVar (nodeNext node) node
stepHelper :: (Node a -> NodePtr a) -> Node a -> STM (Maybe (Node a))
stepHelper step node = do
node' <- readTVar $ step node
if node' == node
then return Nothing
else case nodeValue node' of
Just _ -> return $ Just node'
Nothing -> return Nothing
prev :: Node a -> STM (Maybe (Node a))
prev = stepHelper nodePrev
next :: Node a -> STM (Maybe (Node a))
next = stepHelper nodeNext
start :: LinkedList a -> STM (Maybe (Node a))
start = next . listHead
end :: LinkedList a -> STM (Maybe (Node a))
end = prev . listHead
foldlHelper :: (a -> b -> a)
-> a
-> (Node b -> NodePtr b)
-> Node b
-> STM a
foldlHelper f z nodeStep start_node =
loop z start_node
where
loop !accum node = do
node' <- readTVar $ nodeStep node
case nodeValue node' of
Nothing -> return accum
Just v -> loop (f accum v) node'
toList :: LinkedList a -> STM [a]
toList (LinkedList list_head) = foldlHelper (flip (:)) [] nodePrev list_head
toListRev :: LinkedList a -> STM [a]
toListRev (LinkedList list_head) = foldlHelper (flip (:)) [] nodeNext list_head