From f3d7fb5461c114c187dbd7213edf26802ab49bd1 Mon Sep 17 00:00:00 2001
From: Alexander 'ccntrq' Pankoff <ccntrq@screenri.de>
Date: Tue, 21 Jul 2026 08:25:11 +0200
Subject: 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`.
---
 src/Xmobar/Plugins/Accordion.hs | 55 ++++++++++++++++++++++++-----------------
 1 file changed, 32 insertions(+), 23 deletions(-)

(limited to 'src')

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 . (,())
 
-- 
cgit v1.2.3