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`.

2 files changed, 36 insertions, 23 deletions

diff --git a/doc/plugins.org b/doc/plugins.org
index ecc9507..73753b5 100644
--- a/doc/plugins.org
+++ b/doc/plugins.org
@@ -1469,6 +1469,10 @@
 
   - Aliases to =alias' tuning=, being =tuning= of type =Tuning=, so one can use multiple such "accordions"
   - **Disclaimer**: This only works for Haskell =xmobar.hs=
+  - The final executable must be compiled with GHC's threaded runtime by
+    passing =-threaded=.  Without it, the blocking FIFO used for click events
+    would prevent the wrapped plugins from starting; =Accordion= instead
+    displays a warning and writes it to standard error.
   - =Tuning=: the "settings", for which a default value is provided,
     #+begin_src haskell
       defaultTuning = Tuning {
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 . (,())