diff options
Diffstat (limited to 'testsuite/tests/concurrent/prog003/IOList.lhs')
-rw-r--r-- | testsuite/tests/concurrent/prog003/IOList.lhs | 138 |
1 files changed, 138 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/prog003/IOList.lhs b/testsuite/tests/concurrent/prog003/IOList.lhs new file mode 100644 index 0000000000..72aa1dee46 --- /dev/null +++ b/testsuite/tests/concurrent/prog003/IOList.lhs @@ -0,0 +1,138 @@ +> {-# LANGUAGE BangPatterns,CPP #-} +> module IOList where + +-- #define USE_UNPACK +-- #define USE_STRICT + +#if defined(USE_UNPACK) +#define UNPACK(p) {-# UNPACK #-} !(p) +#elif defined(USE_STRICT) +#define UNPACK(p) !(p) +#else +#define UNPACK(p) p +#endif + +> import Data.IORef + + +> data List a = Node { val :: a, next :: UNPACK(IORef (List a))} +> | Null +> | Head {next :: UNPACK(IORef (List a)) } + +> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))), +> tailList :: UNPACK(IORef (IORef (List a))) } + +> atomically = \x -> x + + +> -- we create a new list +> newList :: IO (ListHandle a) +> newList = +> do null <- newIORef Null +> hd <- newIORef (Head {next = null }) +> hdPtr <- newIORef hd +> tailPtr <- newIORef null +> return (ListHandle {headList = hdPtr, tailList = tailPtr}) + +> find :: Eq a => ListHandle a -> a -> IO Bool +> find (ListHandle {headList = ptrPtr}) i = do +> ptr <- readIORef ptrPtr +> Head {next = startptr} <- readIORef ptr +> find2 startptr i +> where +> find2 :: Eq a => IORef (List a) -> a -> IO Bool +> find2 curNodePtr i = do +> { curNode <- readIORef curNodePtr +> ; case curNode of +> Null -> return False -- we've reached the end of the list +> -- element not found +> Node {val = curval, next = curnext} -> +> if (curval == i) then return True -- element found +> else find2 curnext i -- keep searching +> } + + +> -- we add a new node, by overwriting the null tail node +> -- we only need to adjust tailList but not headList because +> -- of the static Head +> -- we return the location of the newly added node +> addToTail :: ListHandle a -> a -> IO (IORef (List a)) +> addToTail (ListHandle {tailList = tailPtrPtr}) x = +> do tPtr <- atomically ( +> do null <- newIORef Null +> tailPtr <- readIORef tailPtrPtr +> writeIORef tailPtr (Node {val = x, next = null}) +> writeIORef tailPtrPtr null +> return tailPtr +> ) +> return tPtr + + +> delete :: Eq a => ListHandle a -> a -> IO Bool +> delete (ListHandle {headList = ptrPtr}) i = +> atomically ( +> do startptr <- readIORef ptrPtr +> delete2 startptr i) +> where +> delete2 :: Eq a => IORef (List a) -> a -> IO Bool +> delete2 prevPtr i = +> do +> { prevNode <- readIORef prevPtr +> ; let curNodePtr = next prevNode -- head/node have both next +> ; curNode <- readIORef curNodePtr +> ; case curNode of +> Null -> return False -- we've reached the end of the list +> -- element not found +> Node {val = curval, next = nextNode} -> +> if (curval /= i) +> then delete2 curNodePtr i -- keep searching +> else +> -- delete element (ie delink node) +> do { case prevNode of +> Head {} -> do writeIORef prevPtr (Head {next = nextNode}) +> return True +> Node {} -> do writeIORef prevPtr +> (Node {val = val prevNode, next = nextNode}) +> return True +> } +> } + + +printing and counting + +> printList :: Show a => ListHandle a -> IO () +> printList (ListHandle {headList = ptrPtr}) = +> do startptr <- ( +> do ptr <- readIORef ptrPtr +> Head {next = startptr} <- readIORef ptr +> return startptr) +> printListHelp startptr + + +> printListHelp :: Show a => IORef (List a) -> IO () +> printListHelp curNodePtr = +> do { curNode <- readIORef curNodePtr +> ; case curNode of +> Null -> putStr "Nil" +> Node {val = curval, next = curnext} -> +> do { putStr (show curval ++ " -> ") +> ; printListHelp curnext } +> } + +> cntList :: Show a => ListHandle a -> IO Int +> cntList (ListHandle {headList = ptrPtr}) = +> do startptr <- ( +> do ptr <- readIORef ptrPtr +> Head {next = startptr} <- readIORef ptr +> return startptr) +> cntListHelp startptr 0 + + +> cntListHelp :: Show a => IORef (List a) -> Int -> IO Int +> cntListHelp curNodePtr i = +> do { curNode <- readIORef curNodePtr +> ; case curNode of +> Null -> return i +> Node {val = curval, next = curnext} -> +> cntListHelp curnext (i+1) +> } |