Don't use manual locking

3 files changed, 34 insertions, 39 deletions

diff --git a/package.yaml b/package.yaml
index 8e5eb44..a9e8ddf 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
 name: trivmix
-version: 4.0.2
+version: 4.0.3
 license: PublicDomain
 license-file: LICENSE
 author: Gregor Kleen <aethoago@141.li>
@@ -40,6 +40,7 @@ executables:
       - heredoc >=0.2.0.0 && <1
       - refined >=0.1.2.1 && <1
       - scientific >=0.3.5.3 && <1
+      - concurrent-output >=1.10.5 && <2
       - trivmix
   adjmix:
     ghc-options: -threaded -O2
diff --git a/trivmix.nix b/trivmix.nix
index 8aa59cc..690e184 100644
--- a/trivmix.nix
+++ b/trivmix.nix
@@ -1,11 +1,11 @@
-{ mkDerivation, base, case-insensitive, data-default, directory
-, explicit-exception, filelock, filepath, heredoc, hinotify, hpack
-, jack, optparse-applicative, process, refined, scientific, stdenv
-, systemd, th-lift, transformers, unix
+{ mkDerivation, base, case-insensitive, concurrent-output
+, data-default, directory, explicit-exception, filelock, filepath
+, heredoc, hinotify, hpack, jack, optparse-applicative, process
+, refined, scientific, stdenv, systemd, th-lift, transformers, unix
 }:
 mkDerivation {
   pname = "trivmix";
-  version = "4.0.2";
+  version = "4.0.3";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
@@ -14,9 +14,9 @@ mkDerivation {
   ];
   libraryToolDepends = [ hpack ];
   executableHaskellDepends = [
-    base directory explicit-exception filelock filepath heredoc
-    hinotify jack optparse-applicative process refined scientific
-    systemd transformers unix
+    base concurrent-output directory explicit-exception filelock
+    filepath heredoc hinotify jack optparse-applicative process refined
+    scientific systemd transformers unix
   ];
   preConfigure = "hpack";
   license = stdenv.lib.licenses.publicDomain;
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index b9474f2..db3246a 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -31,6 +31,7 @@ import Control.Exception
 import System.IO.Error
 import System.IO
 import System.Exit
+import System.Console.Concurrent
 
 import System.FileLock
 import System.INotify
@@ -159,7 +160,7 @@ defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes
                                                      , otherExecuteMode
                                                      ]
 main :: IO ()
-main = execParser opts >>= trivmix
+main = withConcurrentOutput $ execParser opts >>= trivmix
   where
     opts = info (helper <*> optionParser)
            ( fullDesc
@@ -172,7 +173,6 @@ trivmix Options{..} = do
   level <- newMVar initialLevel
   balance <- newMVar initialBalance
   level' <- newMVar 0
-  stderrLock <- newEmptyMVar
   let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
                               ++ map (\f -> onStateFile f (show initialBalance ++ "\n")) balanceFiles
   withFiles $ withINotify $ \inotify -> do
@@ -185,7 +185,7 @@ trivmix Options{..} = do
       Audio.withProcessMono client' input' (mix level') output' $
         Jack.withActivation client' . Trans.lift $ do
           forM_ run $ \script ->
-            (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> hPutStrLn stderr $ script ++ " failed: " ++ show (code :: ExitCode))
+            (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> errorConcurrent $ script ++ " failed: " ++ show (code :: ExitCode))
           forkIO . forever $ do -- Smooth out discontinuity
             let
               frames = interval * fps
@@ -199,24 +199,24 @@ trivmix Options{..} = do
               EQ -> threadDelay . round $ interval * 1e6
               _  -> do
                 mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0)
-                withMVarLock stderrLock . hPutStrLn stderr $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’."
+                errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’."
           notifyReady
           forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog
 
 mix :: MVar CFloat -> CFloat -> IO CFloat
 mix level input = (input *) <$> readMVar level
 
-handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> MVar () -> [FilePath] -> IO ()
-handleFiles inotify level stderrLock files = do
+handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO ()
+handleFiles inotify level files = do
   initLevel <- readMVar level
   levelChanges <- newChan
   let 
-    handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
+    handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file)
   mapM_ handleFile files
   forkIO $ forever $ do -- Broadcast level changes and update all files
     levelState <- readChan levelChanges
     swapMVar level levelState
-    mapM_ (\f -> writeLevel f stderrLock levelState) files
+    mapM_ (\f -> writeLevel f levelState) files
     return ()
   return ()
 
@@ -229,20 +229,20 @@ onStateFile file initial action = do
   setFileCreationMask nullFileMode
   let acquireFile = case exists of
         True -> return ()
-        False -> withMVarLock stderrLock $ do
-          hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)"
+        False -> do
+          errorConcurrent $ "Creating ‘" ++ file ++ "’ (file)"
           createFile file defFileMode >>= closeFd >> writeFile file initial
       releaseFile = case exists of
         True -> return ()
-        False -> withMVarLock stderrLock $ do
-          hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
+        False -> do
+          errorConcurrent $ "Removing ‘" ++ file ++ "’ (file)"
           removeFile file
-      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> withMVarLock stderrLock $ do
-          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
+      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
+          errorConcurrent $ "Creating ‘" ++ directory ++ "’ (dir)"
           createDirectory directory
           setFileMode directory defDirectoryMode
-      releaseDir = (flip mapM) createDirs $ \directory -> withMVarLock stderrLock $ do
-          hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)"
+      releaseDir = (flip mapM) createDirs $ \directory -> do
+          errorConcurrent $ "Removing ‘" ++ directory ++ "’ (dir)"
           removeDirectory directory
       acquire = acquireDir >> acquireFile
       release = releaseFile >> releaseDir
@@ -259,21 +259,19 @@ takeWhileM pred (x:xs) = do
     False -> do
       return []
 
-readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> MVar () -> IO ()
-readLevel levelChan current file stderrLock = catch action handler
+readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> IO ()
+readLevel levelChan current file = catch action handler
   where
     action = do
       level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace
       oldLevel <- readMVar current
       when (oldLevel /= level) $ do
         writeChan levelChan level
-        withMVarLock stderrLock $ 
-          hPutStrLn stderr $ "Detected new level: " ++ (show level)
+        errorConcurrent $ "Detected new level: " ++ show level
     handler e = if isUserError e
                 then do
-                  withMVarLock stderrLock $ 
-                    hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
-                  readMVar current >>= writeLevel file stderrLock
+                  errorConcurrent $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
+                  readMVar current >>= writeLevel file
                 else throw e
     stripSpace = reverse . stripSpace' . reverse . stripSpace'
     stripSpace' [] = []
@@ -281,11 +279,7 @@ readLevel levelChan current file stderrLock = catch action handler
                           then stripSpace' xs
                           else l
 
-writeLevel :: Show l => FilePath -> MVar () -> l -> IO ()
-writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
-  withMVarLock stderrLock $ 
-    hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
+writeLevel :: Show l => FilePath -> l -> IO ()
+writeLevel file level = withFileLock file Exclusive $ const $ do
+  errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
   writeFile file (show level ++ "\n")
-
-withMVarLock :: MVar () -> IO a -> IO a
-withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock)