Concurrent logging

concurrent-logging.hs

@@ -0,0 +1,61 @@
+import Control.Applicative (liftA2)
+import Control.Monad (unless, replicateM_)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.Async (concurrently_, forConcurrently_)
+import Control.Monad.STM (atomically)
+import Data.Foldable (for_)
+import System.Environment (lookupEnv)
+import System.Random (randomRIO)
+import Text.Read (readMaybe)
+import System.IO
+
+import qualified Control.Concurrent.STM.TQueue as TQ
+import qualified Control.Concurrent.STM.TVar as TV
+
+randomDelay =
+  do
+    i <- randomRIO (1, 1000)
+    threadDelay i
+
+-- Here we have a concurrent program that is parameterized on how to write log messages.
+choir log =
+    -- Run three concurrent threads, each singing a different tune.
+    forConcurrently_ ["Do Re Mi", "Fa Sol", "La Ti Do"] $ \tune ->
+        replicateM_ 3 $ -- Each member of the choir sings its tune 3 times.
+          do
+            randomDelay -- ... with some random delays between each repetition.
+            log tune
+
+-- Our demonstration program runs the "choir" two different ways:
+main =
+  do
+    -- The first way has a serious flaw, which we shall see in the output.
+    withFile "log1.txt" WriteMode $ \h ->
+      do
+        hSetBuffering h NoBuffering
+        choir (hPutStrLn h)
+
+    -- The second way uses a queue to orchestrate the printing.
+    withFile "log2.txt" WriteMode $ \h ->
+      do
+        hSetBuffering h NoBuffering
+        withConcurrentLog (hPutStrLn h) choir
+
+withConcurrentLog print go = do
+    queue <- TQ.newTQueueIO
+    stopVar <- TV.newTVarIO False
+
+    let
+      logToQueue msg = atomically (TQ.writeTQueue queue msg)
+
+      loop = do
+        randomDelay
+        stop <- atomically (liftA2 (&&) (TQ.isEmptyTQueue queue) (TV.readTVar stopVar))
+        unless stop $ do
+          msg <- atomically (TQ.readTQueue queue)
+          print msg
+          loop
+
+    let stop = atomically (TV.writeTVar stopVar True)
+
+    concurrently_ loop (go logToQueue *> stop)

docs/thanks.md

@@ -13,4 +13,4 @@ Thanks to the following people who have [contributed](https://typeclasses.github
 - [Florian Beeres](https://fbrs.io/) -- [Records with optics](https://github.com/typeclasses/haskell-phrasebook/pull/34)
 - [Yuras Shumovich](https://twitter.com/shumovichy) -- assistance with exception handling in `monitoring.hs` ([1](https://twitter.com/shumovichy/status/1207093768182288386), [2](https://twitter.com/shumovichy/status/1207637508412059648))
 - [gutierrezje](https://github.com/gutierrezje) -- [Folding lists](https://github.com/typeclasses/haskell-phrasebook/pull/20)
-- [Daniel Brice](https://github.com/friedbrice) -- [Logging](https://github.com/typeclasses/haskell-phrasebook/pull/39)
+- [Daniel Brice](https://github.com/friedbrice) -- [Logging](https://github.com/typeclasses/haskell-phrasebook/pull/39) and [Concurrent logging](https://github.com/typeclasses/haskell-phrasebook/pull/40)

outputs/concurrent-logging.txt

@@ -0,0 +1,21 @@
+--- log1.txt ---
+Fa Sol
+La Ti Do
+Do Re Mi
+La Ti Do
+Do Re Mi
+Fa Sol
+La Ti Do
+Fa Sol
+Do Re Mi
+
+--- log2.txt ---
+Do Re Mi
+La Ti Do
+Fa Sol
+La Ti Do
+Fa Sol
+Do Re Mi
+La Ti Do
+Do Re Mi
+Fa Sol

tools/outputs.nix

@@ -7,6 +7,7 @@ examples = [
     { name = "bounded-queues"; file = ../bounded-queues.hs; sed = "s!^(finish:.*|start: (6|7|8|9|10))$!...!"; }
     { name = "branching"; file = ../branching.hs; sed = "s!^It's .* noon$!It's ... noon!"; }
     { name = "common-types"; file = ../common-types.hs; }
+    { name = "concurrent-logging"; file = ../concurrent-logging.hs; after = ["echo '--- log1.txt ---' >> $out" "cat log1.txt >> $out" "echo '\n--- log2.txt ---' >> $out" "cat log2.txt >> $out"]; }
     { name = "crypto-hashing"; file = ../crypto-hashing.hs; }
     { name = "dynamic"; file = ../dynamic.hs; }
     { name = "enum-ranges"; file = ../enum-ranges.hs; }