|
1 | 1 | module Chan where |
2 | 2 |
|
3 | 3 | import Control.Concurrent hiding (Chan) |
| 4 | +import Control.Concurrent.STM hiding (TChan) |
4 | 5 |
|
5 | 6 | type Stream a = MVar (Item a) |
6 | 7 | data Item a = Item a (Stream a) |
@@ -35,3 +36,50 @@ dupChan (Chan _ writeVar) = do |
35 | 36 | newReadVar <- newMVar hole |
36 | 37 | return $ Chan newReadVar writeVar |
37 | 38 |
|
| 39 | +type TVarList a = TVar (TList a) |
| 40 | +data TList a = Nil |
| 41 | + | TCons a (TVarList a) |
| 42 | + |
| 43 | +data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a)) |
| 44 | + |
| 45 | +newTChan :: STM (TChan a) |
| 46 | +newTChan = do |
| 47 | + hole <- newTVar Nil |
| 48 | + read <- newTVar hole |
| 49 | + write <- newTVar hole |
| 50 | + return $ TChan read write |
| 51 | + |
| 52 | +writeTChan :: TChan a -> a -> STM () |
| 53 | +writeTChan (TChan _ write) val = do |
| 54 | + newHole <- newTVar Nil |
| 55 | + oldHole <- readTVar write |
| 56 | + writeTVar oldHole $ TCons val newHole |
| 57 | + writeTVar write newHole |
| 58 | + |
| 59 | +readTChan :: TChan a -> STM a |
| 60 | +readTChan (TChan read _) = do |
| 61 | + stream <- readTVar read |
| 62 | + head <- readTVar stream |
| 63 | + case head of |
| 64 | + Nil -> retry |
| 65 | + TCons val next -> do |
| 66 | + writeTVar read next |
| 67 | + return val |
| 68 | + |
| 69 | +unGetTChan :: TChan a -> a -> STM () |
| 70 | +unGetTChan (TChan read _) val = do |
| 71 | + head <- readTVar read |
| 72 | + newHead <- newTVar (TCons val head) |
| 73 | + writeTVar read newHead |
| 74 | + |
| 75 | +isEmptyTChan :: TChan a -> STM Bool |
| 76 | +isEmptyTChan (TChan read _) = do |
| 77 | + list <- readTVar read |
| 78 | + head <- readTVar list |
| 79 | + case head of |
| 80 | + Nil -> return True |
| 81 | + _ -> return False |
| 82 | + |
| 83 | + |
| 84 | + |
| 85 | + |
0 commit comments