Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Doubly-linked list in Haskell, using MVars
{-# LANGUAGE NamedFieldPuns #-}
-- This is similar to https://gist.github.com/cblp/b427ffcce536d1a6b7e03598ec21e2ee
module Main where
import Control.Concurrent.MVar
import Control.Monad
import Data.List.NonEmpty
main :: IO ()
main = do
dl <- listToDoubleList [1 :: Int, 2, 3, 4]
newDl <- fmapDoubleList show dl
appendVal "hello" newDl
reverseDoubleList newDl
list <- doubleListToList newDl
print list
newtype DoubleList a = DoubleList (MVar (Maybe (Node a, Node a)))
data Node a = Node
{ val :: a
, prevNodeMVar :: MVar (Maybe (Node a))
, nextNodeMVar :: MVar (Maybe (Node a))
}
emptyDoubleList :: IO (DoubleList a)
emptyDoubleList = fmap DoubleList (newMVar Nothing)
singletonNode :: a -> IO (Node a)
singletonNode a = do
prev <- newMVar Nothing
next <- newMVar Nothing
pure $ Node a prev next
singletonNodes :: a -> IO (Node a, Node a)
singletonNodes a = do
prev <- newMVar Nothing
next <- newMVar Nothing
let node = Node a prev next
pure (node, node)
singletonDoubleList :: a -> IO (DoubleList a)
singletonDoubleList a = do
doubleList <- emptyDoubleList
appendVal a doubleList
return doubleList
nodesToDoubleList :: (Node a, Node a) -> IO (DoubleList a)
nodesToDoubleList nodes = DoubleList <$> newMVar (Just nodes)
linkNodes :: Node a -> Node a -> IO ()
linkNodes
nodeA@Node{nextNodeMVar=nodeANextNodeMVar}
nodeB@Node{prevNodeMVar=nodeBPrevNodeMVar} = do
void $ swapMVar nodeANextNodeMVar (Just nodeB)
void $ swapMVar nodeBPrevNodeMVar (Just nodeA)
pure ()
appendVal :: a -> DoubleList a -> IO ()
appendVal a (DoubleList mvar) = do
maybeNodes <- takeMVar mvar
case maybeNodes of
Nothing -> do
nodes <- singletonNodes a
putMVar mvar (Just nodes)
Just (startingNode, endingNode) -> do
newEndingNode <- singletonNode a
linkNodes endingNode newEndingNode
putMVar mvar $ Just (startingNode, newEndingNode)
swapNodePointers :: Node a -> IO ()
swapNodePointers Node{prevNodeMVar, nextNodeMVar} = do
maybePrevNode <- takeMVar prevNodeMVar
maybeNextNode <- takeMVar nextNodeMVar
case maybeNextNode of
Just nextNode -> swapNodePointers nextNode
Nothing -> pure ()
putMVar prevNodeMVar maybeNextNode
putMVar nextNodeMVar maybePrevNode
reverseDoubleList :: DoubleList a -> IO ()
reverseDoubleList (DoubleList mvar) = do
maybeNodes <- takeMVar mvar
case maybeNodes of
Nothing -> putMVar mvar Nothing
Just (startNode, endNode) -> do
swapNodePointers startNode
putMVar mvar $ Just (endNode, startNode)
fmapNode :: (a -> b) -> Node a -> IO (Node b, Node b)
fmapNode f Node{val=a, nextNodeMVar} = do
let b = f a
maybeNextNode <- readMVar nextNodeMVar
case maybeNextNode of
Nothing -> singletonNodes b
Just nextNode -> do
(newNextNode@Node{prevNodeMVar}, lastNode) <- fmapNode f nextNode
startingEmptyNode <- newMVar Nothing
newNextNodeMVar <- newMVar (Just newNextNode)
let newNode = Node b startingEmptyNode newNextNodeMVar
void $ swapMVar prevNodeMVar (Just newNode)
pure (newNode, lastNode)
fmapDoubleList :: (a -> b) -> DoubleList a -> IO (DoubleList b)
fmapDoubleList f (DoubleList mvar) = do
maybeNodes <- readMVar mvar
case maybeNodes of
Nothing -> emptyDoubleList
Just (startingNode, _) -> fmapNode f startingNode >>= nodesToDoubleList
nodesToList :: Node a -> IO [a]
nodesToList Node{val, nextNodeMVar} = do
maybeNextNode <- readMVar nextNodeMVar
case maybeNextNode of
Nothing -> pure [val]
Just nextNode -> do
nextNodesList <- nodesToList nextNode
pure $ val : nextNodesList
doubleListToList :: DoubleList a -> IO [a]
doubleListToList (DoubleList mvar) = do
maybeNodes <- readMVar mvar
case maybeNodes of
Nothing -> pure []
Just (startingNode, _) -> nodesToList startingNode
nodesToListRev :: Node a -> IO [a]
nodesToListRev Node{val, prevNodeMVar} = do
maybePrevNode <- readMVar prevNodeMVar
case maybePrevNode of
Nothing -> pure [val]
Just prevNode -> do
prevNodesList <- nodesToListRev prevNode
pure $ val : prevNodesList
doubleListToListRev :: DoubleList a -> IO [a]
doubleListToListRev (DoubleList mvar) = do
maybeNodes <- readMVar mvar
case maybeNodes of
Nothing -> pure []
Just (_, endingNode) -> nodesToListRev endingNode
listToNodes :: NonEmpty a -> IO (Node a, Node a)
listToNodes (a :| []) = singletonNodes a
listToNodes (a :| (tailA : tailAs)) = do
(startNode, endNode) <- listToNodes (tailA :| tailAs)
newStartNode <- singletonNode a
linkNodes newStartNode startNode
pure (newStartNode, endNode)
listToDoubleList :: [a] -> IO (DoubleList a)
listToDoubleList [] = emptyDoubleList
listToDoubleList (a:as) = listToNodes (a :| as) >>= nodesToDoubleList
@cdepillabout
Copy link
Author

cdepillabout commented Feb 9, 2018

Running this in GHCi:

> main
["hello","4","3","2","1"]

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment