Add warning when Accordion runs without the threaded RTS

The Accordion plugin open the click event FIFO before starting its
plugins. With the non threaded RTS this blocking open blocks the only
execution thread, leading to the plugin permanently displaying
`Updating...`.

With this commit the Accordion plugin wil check for the presence of a
threaded RTS using `rtsSupportsBoundThreads`. When the threaded RTS is
not available a warning is displayed instead, prompting the user to
recompile with `-threaded`.

1 files changed, 32 insertions, 23 deletions

diff --git a/src/Xmobar/Plugins/Accordion.hs b/src/Xmobar/Plugins/Accordion.hs
index ce15cee..f067200 100644
--- a/src/Xmobar/Plugins/Accordion.hs
+++ b/src/Xmobar/Plugins/Accordion.hs
@@ -18,6 +18,7 @@
 
 module Xmobar.Plugins.Accordion (defaultTuning, makeAccordion, makeAccordion', Tuning(..)) where
 
+import Control.Concurrent (rtsSupportsBoundThreads)
 import Control.Concurrent.Async (concurrently_, mapConcurrently_)
 import Control.Exception (finally)
 import Control.Monad.Extra (whenM)
@@ -28,7 +29,7 @@ import Control.Monad.State.Strict (MonadState, evalStateT, get, modify')
 import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)
 import GHC.IO.Handle.FD (withFileBlocking)
 import System.Directory (removeFile)
-import System.IO (IOMode(ReadMode), hGetContents')
+import System.IO (IOMode(ReadMode), hGetContents', hPutStrLn, stderr)
 import System.Process (readProcessWithExitCode)
 import Xmobar.Run.Exec (Exec(..), tenthSeconds)
 
@@ -66,28 +67,32 @@ defaultTuning = Tuning {
 
 instance Exec a => Exec (Accordion a) where
   alias (Accordion Tuning{..} _ _) = alias'
-  start (Accordion Tuning{..} runnables shortRunnables) cb = do
-    clicked <- newIORef False
-    (_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
-    let pipe = "/tmp/accordion-" ++ removeLinebreak n
-    (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
-    concurrently_ (forever $ do "" <- withFileBlocking pipe ReadMode hGetContents'
-                                atomicModifyIORef' clicked (const (True, ())))
-                  (do
-                      strRefs <- mapM (newIORef . const "") runnables
-                      strRefs' <- mapM (newIORef . const "") shortRunnables
-                      let processClick = forever (do liftIO (tenthSeconds 1)
-                                                     whenM (liftIO $ readIORef clicked)
-                                                           (do liftIO $ clear clicked
-                                                               modify' not)
-                                                     get >>= loop pipe)
-                                           `runReaderT` (strRefs, strRefs')
-                                           `evalStateT` initial
-                      let startRunnables = zipWith start
-                                                   (runnables ++ shortRunnables)
-                                                   (map writeToRef $ strRefs ++ strRefs')
-                      parallel_ $ processClick:startRunnables)
-      `finally` removeFile pipe
+  start (Accordion Tuning{..} runnables shortRunnables) cb
+    | not rtsSupportsBoundThreads = do
+        hPutStrLn stderr threadedRuntimeWarning
+        cb threadedRuntimeWarning
+    | otherwise = do
+        clicked <- newIORef False
+        (_, n, _) <- readProcessWithExitCode "uuidgen" [] ""
+        let pipe = "/tmp/accordion-" ++ removeLinebreak n
+        (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""
+        concurrently_ (forever $ do "" <- withFileBlocking pipe ReadMode hGetContents'
+                                    atomicModifyIORef' clicked (const (True, ())))
+                      (do
+                          strRefs <- mapM (newIORef . const "") runnables
+                          strRefs' <- mapM (newIORef . const "") shortRunnables
+                          let processClick = forever (do liftIO (tenthSeconds 1)
+                                                         whenM (liftIO $ readIORef clicked)
+                                                               (do liftIO $ clear clicked
+                                                                   modify' not)
+                                                         get >>= loop pipe)
+                                               `runReaderT` (strRefs, strRefs')
+                                               `evalStateT` initial
+                          let startRunnables = zipWith start
+                                                       (runnables ++ shortRunnables)
+                                                       (map writeToRef $ strRefs ++ strRefs')
+                          parallel_ $ processClick:startRunnables)
+          `finally` removeFile pipe
     where
       loop :: (MonadIO m,
                MonadState Bool m,
@@ -99,6 +104,10 @@ instance Exec a => Exec (Accordion a) where
         liftIO $ cb $ text ++ attachClick pipe (if bool then shrink else expand)
       parallel_ = mapConcurrently_ id
 
+threadedRuntimeWarning :: String
+threadedRuntimeWarning =
+  "xmobar: warning: Accordion requires the threaded RTS; rebuild with -threaded"
+
 writeToRef :: IORef a -> a -> IO ()
 writeToRef strRef = atomicModifyIORef' strRef . const . (,())