From 343fc3782d69b5b82bc683d29399671584f4c03d Mon Sep 17 00:00:00 2001
From: Yuanle Song <sylecn@gmail.com>
Date: Wed, 21 Dec 2016 17:02:30 +0800
Subject: [PATCH] add failed try6.hs

master thread doesn't wait for forked threads
---
 queue-base-threading.cabal | 11 ++++++++
 try6.hs                    | 56 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 67 insertions(+)
 create mode 100644 try6.hs

diff --git a/queue-base-threading.cabal b/queue-base-threading.cabal
index 4212745..be52be8 100644
--- a/queue-base-threading.cabal
+++ b/queue-base-threading.cabal
@@ -65,6 +65,17 @@ executable try5
                      , random
   default-language:    Haskell2010
 
+executable try6
+  main-is:             try6.hs
+  other-modules:       WorkGroup
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base >= 4.6.0.0
+                     , random
+                     , stm
+                     , stm-chans
+  default-language:    Haskell2010
+  default-extensions:  BangPatterns
+
 source-repository head
   type:     git
   location: https://github.com/sylecn/queue-base-threading
diff --git a/try6.hs b/try6.hs
new file mode 100644
index 0000000..1973662
--- /dev/null
+++ b/try6.hs
@@ -0,0 +1,56 @@
+import Control.Monad
+import System.Random
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMQueue
+import Data.Monoid ((<>))
+
+fuzzDelay = True
+
+fuzz :: IO ()
+fuzz = when fuzzDelay $ do
+         seconds <- getStdRandom random :: IO Double
+         threadDelay $ round (realToFrac (1000000 * seconds))
+
+printManager :: TMQueue [String] -> IO ()
+printManager inputs = loop
+  where
+    loop = do
+        mbThingToShow <- atomically (readTMQueue inputs)
+        fuzz
+        case mbThingToShow of
+            Nothing -> pure ()
+            Just thing -> do
+                mapM_ putStrLn thing
+                fuzz
+                loop
+
+counterManager :: TMQueue [String] -> TMQueue Int -> IO ()
+counterManager printQueue inputs = loop 0
+  where
+    loop !i = do -- requires BangPatterns language extension
+        mint <- atomically (readTMQueue inputs)
+        case mint of
+             Nothing -> pure ()
+             Just int -> do
+                 fuzz
+                 let newCount = int + i
+                 fuzz
+                 atomically (writeTMQueue printQueue ["The count is now " <> show newCount, "---------------"])
+                 fuzz
+                 loop newCount
+
+main :: IO ()
+main = do
+  printQueue <- atomically newTMQueue
+  counterQueue <- atomically newTMQueue
+  forkIO $ counterManager printQueue counterQueue
+  forkIO $ printManager printQueue
+  fuzz
+  atomically $ writeTMQueue printQueue ["Starting up"]
+  fuzz
+  replicateM_ 10 $ do
+         atomically $ writeTMQueue counterQueue 1
+         fuzz
+  atomically $ writeTMQueue printQueue ["Finishing up"]
-- 
GitLab