diff options
| -rw-r--r-- | Control/Concurrent/STM/StatusCache.hs | 50 |
1 files changed, 25 insertions, 25 deletions
diff --git a/Control/Concurrent/STM/StatusCache.hs b/Control/Concurrent/STM/StatusCache.hs index e08be33c..db77429f 100644 --- a/Control/Concurrent/STM/StatusCache.hs +++ b/Control/Concurrent/STM/StatusCache.hs | |||
| @@ -19,11 +19,11 @@ | |||
| 19 | -- | 19 | -- |
| 20 | -- In the folowing example, our chunk type is Char and complete messages are | 20 | -- In the folowing example, our chunk type is Char and complete messages are |
| 21 | -- delimited by the characters '(' and ')'. We process the input stream | 21 | -- delimited by the characters '(' and ')'. We process the input stream |
| 22 | -- \"(aaaa)(bb)(ccccc)\" first with a delayed processor and then again with an | 22 | -- \"(aaa(a))(bb)(cc(c)cc)\" first with a delayed processor and then again with |
| 23 | -- efficient dedicated thread. The result follows: | 23 | -- an efficient dedicated thread. The result follows: |
| 24 | -- | 24 | -- |
| 25 | -- > Backlogged consumer: (ccccc) | 25 | -- > Backlogged consumer: (cc(c)cc) |
| 26 | -- > Fast consumer: (aaaa)(bb)(ccccc) | 26 | -- > Fast consumer: (aaa(a))(bb)(cc(c)cc) |
| 27 | -- | 27 | -- |
| 28 | -- The complete source code: | 28 | -- The complete source code: |
| 29 | -- | 29 | -- |
| @@ -33,28 +33,28 @@ | |||
| 33 | -- > import System.IO (hFlush, stdout) | 33 | -- > import System.IO (hFlush, stdout) |
| 34 | -- > import qualified Control.Concurrent.STM.StatusCache as Cache | 34 | -- > import qualified Control.Concurrent.STM.StatusCache as Cache |
| 35 | -- > | 35 | -- > |
| 36 | -- > while pred body = | 36 | -- > main = do q <- atomically $ Cache.new (== '(') (==')') |
| 37 | -- > pred >>= flip when (body >> while pred body) | 37 | -- > backlog q "(aaa(a))(bb)(cc(c)cc)" |
| 38 | -- > fast q "(aaa(a))(bb)(cc(c)cc)" | ||
| 39 | -- > | ||
| 40 | -- > while pred body = pred >>= flip when (body >> while pred body) | ||
| 38 | -- > | 41 | -- > |
| 39 | -- > main = do | 42 | -- > backlog q xs = do putStr $ "Backlogged consumer: " |
| 40 | -- > q <- atomically $ Cache.new (== '(') (==')') | 43 | -- > mapM_ (atomically . Cache.push q) xs |
| 44 | -- > while (atomically $ fmap not $ Cache.isEmpty q) $ do | ||
| 45 | -- > c <- atomically $ Cache.pull q | ||
| 46 | -- > putChar c | ||
| 47 | -- > putStrLn "" | ||
| 48 | -- > hFlush stdout | ||
| 41 | -- > | 49 | -- > |
| 42 | -- > putStr $ "Backlogged consumer: " | 50 | -- > fast q xs = do putStr "Fast consumer: " |
| 43 | -- > mapM_ (atomically . Cache.push q) "(aaaa)(bb)(ccccc)" | 51 | -- > forkIO $ forever $ do |
| 44 | -- > while (atomically $ fmap not $ Cache.isEmpty q) $ do | 52 | -- > c <- atomically $ Cache.pull q |
| 45 | -- > c <- atomically $ Cache.pull q | 53 | -- > putChar c |
| 46 | -- > putChar c | 54 | -- > hFlush stdout |
| 47 | -- > putStrLn "" | 55 | -- > mapM_ (atomically . Cache.push q >=> const (threadDelay 10000)) |
| 48 | -- > hFlush stdout | 56 | -- > xs |
| 49 | -- > | 57 | -- > putStrLn "" |
| 50 | -- > putStr "Fast consumer: " | ||
| 51 | -- > forkIO $ forever $ do | ||
| 52 | -- > c <- atomically $ Cache.pull q | ||
| 53 | -- > putChar c | ||
| 54 | -- > hFlush stdout | ||
| 55 | -- > mapM_ (atomically . Cache.push q >=> const (threadDelay 10000)) | ||
| 56 | -- > "(aaaa)(bb)(ccccc)" | ||
| 57 | -- > putStrLn "" | ||
| 58 | -- | 58 | -- |
| 59 | -- As shown above, it is intended that this module be imported qualified. | 59 | -- As shown above, it is intended that this module be imported qualified. |
| 60 | -- | 60 | -- |