Doubly-linked list in Haskell, using IORefs

DLList.hs

{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

import           Data.IORef

type ItemPtr a = IORef (Maybe (Item a))

data Item a = Item{value :: a, prev, next :: !(ItemPtr a)}

newtype DLList a = DLList (IORef (Maybe (Item a, Item a)))

newItem :: a -> IO (Item a)
newItem value = do
    prev <- newIORef Nothing
    next <- newIORef Nothing
    pure Item{..}

newDLList :: IO (DLList a)
newDLList = do
    ends <- newIORef Nothing
    pure $ DLList ends

toList :: DLList a -> IO [a]
toList (DLList ends) = do
    endItemsMaybe <- readIORef ends
    case endItemsMaybe of
        Nothing                     -> pure []
        Just (_, Item{value, prev}) -> go [value] prev
  where
    go :: [a] -> ItemPtr a -> IO [a]
    go values itemPtr = do
        itemMaybe <- readIORef itemPtr
        case itemMaybe of
            Nothing                -> pure values
            Just Item{value, prev} -> go (value : values) prev

insertFront :: a -> DLList a -> IO ()
insertFront value (DLList ends) = do
    endItemsMaybe <- readIORef ends
    item <- newItem value
    case endItemsMaybe of
        Nothing ->
            writeIORef ends $ Just (item, item)
        Just (front, back) -> do
            writeIORef (next item)  $ Just front
            writeIORef (prev front) $ Just item
            writeIORef ends $ Just (item, back)

insertBack :: a -> DLList a -> IO ()
insertBack value (DLList ends) = do
    endItemsMaybe <- readIORef ends
    item <- newItem value
    case endItemsMaybe of
        Nothing ->
            writeIORef ends $ Just (item, item)
        Just (front, back) -> do
            writeIORef (prev item) $ Just back
            writeIORef (next back) $ Just item
            writeIORef ends $ Just (front, item)

popFront :: DLList a -> IO (Maybe a)
popFront (DLList ends) = do
    endItemsMaybe <- readIORef ends
    case endItemsMaybe of
        Nothing -> pure Nothing
        Just (Item{value, next}, back) -> do
            nextItemMaybe <- readIORef next
            endItems' <- case nextItemMaybe of
                Nothing ->
                    pure Nothing
                Just nextItem -> do
                    writeIORef (prev nextItem) Nothing
                    pure $ Just (nextItem, back)
            writeIORef ends endItems'
            pure $ Just value

popBack :: DLList a -> IO (Maybe a)
popBack (DLList ends) = do
    endItemsMaybe <- readIORef ends
    case endItemsMaybe of
        Nothing -> pure Nothing
        Just (front, Item{value, prev}) -> do
            prevItemMaybe <- readIORef prev
            endItems' <- case prevItemMaybe of
                Nothing ->
                    pure Nothing
                Just prevItem -> do
                    writeIORef (next prevItem) Nothing
                    pure $ Just (front, prevItem)
            writeIORef ends endItems'
            pure $ Just value

main :: IO ()
main = do
    alist <- newDLList
    print =<< toList (alist :: DLList Int)

    let testI insert x = do
            () <- insert x alist
            xs <- toList alist
            putStrLn $ unwords [show x, "->", show xs]

    let testP pop = do
            x <- pop alist
            xs <- toList alist
            putStrLn $ unwords [show x, "<-", show xs]

    testI insertFront 1
    testI insertBack 2
    testI insertFront 3
    testI insertBack 4

    testP popFront
    testP popBack
    testP popFront
    testP popBack
    testP popFront
    testP popBack