diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Xmobar/Plugins/Accordion.hs | 55 |
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 . (,()) |