summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Xmobar.hs9
-rw-r--r--src/Xmobar/App/Compile.hs8
-rw-r--r--src/Xmobar/App/Opts.hs6
-rw-r--r--src/Xmobar/Plugins/Accordion.hs99
-rw-r--r--src/Xmobar/Plugins/ArchUpdates.hs41
-rw-r--r--src/Xmobar/Plugins/EWMH.hs2
-rw-r--r--src/Xmobar/Plugins/MarqueePipeReader.hs2
-rw-r--r--src/Xmobar/Plugins/Monitors/Batt/Common.hs13
-rw-r--r--src/Xmobar/Plugins/Monitors/Batt/Linux.hs2
-rw-r--r--src/Xmobar/Plugins/Monitors/Bright.hs3
-rw-r--r--src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc2
-rw-r--r--src/Xmobar/Plugins/Monitors/MPD.hs5
-rw-r--r--src/Xmobar/Plugins/Monitors/Mpris.hs10
-rw-r--r--src/Xmobar/Plugins/Monitors/Swap/FreeBSD.hsc5
-rw-r--r--src/Xmobar/Plugins/Monitors/Top.hs6
-rw-r--r--src/Xmobar/Plugins/PacmanUpdates.hs165
-rw-r--r--src/Xmobar/Run/Actions.hs7
-rw-r--r--src/Xmobar/Run/Loop.hs2
-rw-r--r--src/Xmobar/Run/Template.hs21
-rw-r--r--src/Xmobar/Run/Types.hs4
-rw-r--r--src/Xmobar/X11/Loop.hs6
-rw-r--r--src/Xmobar/X11/XRender.hsc38
22 files changed, 305 insertions, 151 deletions
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 5aa748a..5a31d80 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Xmobar
--- Copyright : (c) 2011, 2012, 2013, 2014, 2015, 2017, 2018, 2019, 2022 Jose Antonio Ortega Ruiz
+-- Copyright : (c) 2011-2015, 2017-2019, 2022, 2025 Jose Antonio Ortega Ruiz
-- (c) 2007 Andrea Rossato
-- License : BSD-style (see LICENSE)
--
@@ -19,15 +19,13 @@ module Xmobar (xmobar
, xmobarMain
, defaultConfig
, configFromArgs
- , tenthSeconds
, Runnable (..)
- , Exec (..)
, Command (..)
, SignalType (..)
+ , module Xmobar.Run.Exec
, module Xmobar.Config.Types
, module Xmobar.Config.Parse
, module Xmobar.Plugins.Accordion
- , module Xmobar.Plugins.ArchUpdates
, module Xmobar.Plugins.BufferedPipeReader
, module Xmobar.Plugins.CommandReader
, module Xmobar.Plugins.Date
@@ -45,6 +43,7 @@ module Xmobar (xmobar
#endif
, module Xmobar.Plugins.NotmuchMail
, module Xmobar.Plugins.Monitors
+ , module Xmobar.Plugins.PacmanUpdates
, module Xmobar.Plugins.PipeReader
, module Xmobar.Plugins.MarqueePipeReader
, module Xmobar.Plugins.StdinReader
@@ -56,7 +55,6 @@ import Xmobar.Run.Exec
import Xmobar.Config.Types
import Xmobar.Config.Parse
import Xmobar.Plugins.Accordion
-import Xmobar.Plugins.ArchUpdates
import Xmobar.Plugins.Command
import Xmobar.Plugins.BufferedPipeReader
import Xmobar.Plugins.CommandReader
@@ -74,6 +72,7 @@ import Xmobar.Plugins.Mail
import Xmobar.Plugins.MBox
#endif
import Xmobar.Plugins.Monitors
+import Xmobar.Plugins.PacmanUpdates
import Xmobar.Plugins.PipeReader
import Xmobar.Plugins.StdinReader
import Xmobar.Plugins.MarqueePipeReader
diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs
index 5d1f48d..e5b08b7 100644
--- a/src/Xmobar/App/Compile.hs
+++ b/src/Xmobar/App/Compile.hs
@@ -3,7 +3,7 @@
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Compile
--- Copyright: (c) 2018 Jose Antonio Ortega Ruiz
+-- Copyright: (c) 2018, 2026 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
@@ -20,8 +20,8 @@
module Xmobar.App.Compile(recompile, trace, xmessage) where
import Control.Monad.IO.Class
-import Control.Exception.Extensible (bracket, SomeException(..))
-import qualified Control.Exception.Extensible as E
+import Control.Exception (SomeException(..))
+import qualified Control.Exception as E
import Control.Monad (filterM, when)
import Data.List ((\\))
import System.FilePath((</>), takeExtension)
@@ -141,7 +141,7 @@ recompile confDir dataDir execName force verb = liftIO $ do
else shouldRecompile verb src bin lib
if sc
then do
- status <- bracket (openFile err WriteMode) hClose $
+ status <- withFile err WriteMode $
\errHandle ->
waitForProcess =<<
if useScript
diff --git a/src/Xmobar/App/Opts.hs b/src/Xmobar/App/Opts.hs
index 36da745..5196b3c 100644
--- a/src/Xmobar/App/Opts.hs
+++ b/src/Xmobar/App/Opts.hs
@@ -1,7 +1,7 @@
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.Opts
--- Copyright: (c) 2018, 2019, 2020, 2022, 2023, 2024 Jose Antonio Ortega Ruiz
+-- Copyright: (c) 2018, 2019, 2020, 2022, 2023-2026 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
@@ -61,7 +61,7 @@ options =
, Option "v" ["verbose"] (NoArg Verbose) "Emit verbose debugging messages"
, Option "r" ["recompile"] (NoArg Recompile) "Force recompilation"
, Option "V" ["version"] (NoArg Version) "Show version information"
- , Option "T" ["text"] (OptArg TextOutput "color")
+ , Option "T" ["text"] (OptArg TextOutput "format")
"Write text-only output to stdout. Plain/Ansi/Pango/Swaybar"
, Option "f" ["font"] (ReqArg Font "font name") "Font name"
, Option "N" ["add-font"] (ReqArg AddFont "font name")
@@ -116,7 +116,7 @@ usage = usageInfo header options ++ footer
info :: String
info = "xmobar " ++ showVersion version
- ++ "\n (C) 2010 - 2024 Jose A Ortega Ruiz"
+ ++ "\n (C) 2010 - 2026 Jose A Ortega Ruiz"
++ "\n (C) 2007 - 2010 Andrea Rossato\n "
++ mail ++ "\n" ++ license ++ "\n"
diff --git a/src/Xmobar/Plugins/Accordion.hs b/src/Xmobar/Plugins/Accordion.hs
index 6377928..ce15cee 100644
--- a/src/Xmobar/Plugins/Accordion.hs
+++ b/src/Xmobar/Plugins/Accordion.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections, FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
@@ -15,18 +16,19 @@
--
-----------------------------------------------------------------------------
-module Xmobar.Plugins.Accordion (defaultTuning, makeAccordion, Tuning(..)) where
+module Xmobar.Plugins.Accordion (defaultTuning, makeAccordion, makeAccordion', Tuning(..)) where
-import Control.Concurrent.Async (withAsync)
+import Control.Concurrent.Async (concurrently_, mapConcurrently_)
import Control.Exception (finally)
-import Control.Monad (forever, join, when)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Reader (runReaderT, ask)
-import Control.Monad.State.Strict (evalStateT, get, modify')
-import Data.IORef (atomicModifyIORef', newIORef, readIORef)
-import Data.Maybe (isJust)
+import Control.Monad.Extra (whenM)
+import Control.Monad (forever, join)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Control.Monad.Reader (MonadReader, runReaderT, ask)
+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.Exit (ExitCode(..))
+import System.IO (IOMode(ReadMode), hGetContents')
import System.Process (readProcessWithExitCode)
import Xmobar.Run.Exec (Exec(..), tenthSeconds)
@@ -38,10 +40,14 @@ import Xmobar.Run.Exec (Exec(..), tenthSeconds)
data Accordion a = Accordion {
tuning :: Tuning
, plugins :: [a]
+ , shortPlugins :: [a]
} deriving (Show, Read)
makeAccordion :: Exec a => Tuning -> [a] -> Accordion a
-makeAccordion t rs = Accordion { tuning = t, plugins = rs }
+makeAccordion t rs = Accordion { tuning = t, plugins = rs, shortPlugins = [] }
+
+makeAccordion' :: Exec a => Tuning -> [a] -> [a] -> Accordion a
+makeAccordion' t rs rs' = Accordion { tuning = t, plugins = rs, shortPlugins = rs' }
data Tuning = Tuning {
alias' :: String
@@ -58,40 +64,49 @@ defaultTuning = Tuning {
, shrink = "><"
}
-instance (Exec a, Read a, Show a) => Exec (Accordion a) where
- alias (Accordion Tuning { alias' = name } _) = name
- start (Accordion Tuning { initial = initial'
- , expand = expand'
- , shrink = shrink' }
- runnables)
- cb = do
- clicked <- newIORef Nothing
+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] ""
- withAsync (forever $ do (ret, _, _) <- readProcessWithExitCode "cat" [pipe] ""
- case ret of
- ExitSuccess -> atomicModifyIORef' clicked (const (Just (), ()))
- ExitFailure _ -> error "how is this possible?")
- (const $ do
- srefs <- mapM (newIORef . const "") runnables
- foldr (\(runnable, sref) acc -> withAsync (start runnable (writeToRef sref)) (const acc))
- (forever (do liftIO (tenthSeconds 1)
- clicked' <- liftIO $ readIORef clicked
- when (isJust clicked')
- (do liftIO $ clear clicked
- modify' not)
- b <- get
- if b then loop pipe else liftIO $ cb (click pipe expand'))
- `runReaderT` srefs `evalStateT` initial')
- (zip runnables srefs))
+ 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
- click file icon = "<action=`echo 1 > " ++ file ++ "`>" ++ icon ++ "</action>"
- clear = (`atomicModifyIORef'` const (Nothing, ()))
- removeLinebreak = init
- writeToRef strRef = atomicModifyIORef' strRef . const . (,())
- loop p = do
- srefs <- ask
- text <- join <$> mapM (liftIO . readIORef) srefs
- liftIO $ cb $ text ++ click p shrink'
+ loop :: (MonadIO m,
+ MonadState Bool m,
+ MonadReader ([IORef String], [IORef String]) m)
+ => String -> Bool -> m ()
+ loop pipe bool = do
+ (strRefs, strRefs') <- ask
+ text <- join <$> mapM (liftIO . readIORef) (if bool then strRefs else strRefs')
+ liftIO $ cb $ text ++ attachClick pipe (if bool then shrink else expand)
+ parallel_ = mapConcurrently_ id
+
+writeToRef :: IORef a -> a -> IO ()
+writeToRef strRef = atomicModifyIORef' strRef . const . (,())
+
+clear :: IORef Bool -> IO ()
+clear = (`atomicModifyIORef'` const (False, ()))
+
+removeLinebreak :: [a] -> [a]
+removeLinebreak = init
+
+attachClick :: String -> String -> String
+attachClick file icon = "<action=`echo -n > " ++ file ++ "`>" ++ icon ++ "</action>"
diff --git a/src/Xmobar/Plugins/ArchUpdates.hs b/src/Xmobar/Plugins/ArchUpdates.hs
deleted file mode 100644
index f803d0f..0000000
--- a/src/Xmobar/Plugins/ArchUpdates.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Plugins.Monitors.ArchUpdates
--- Copyright : (c) 2024 Enrico Maria De Angelis
--- License : BSD-style (see LICENSE)
---
--- Maintainer : Enrico Maria De Angelis <enricomaria.dean6elis@gmail.com>
--- Stability : unstable
--- Portability : unportable
---
--- An ArchLinux updates availablility plugin for Xmobar
---
------------------------------------------------------------------------------
-
-module Xmobar.Plugins.ArchUpdates (ArchUpdates(..)) where
-
-import System.Exit (ExitCode(..))
-import System.Process (readProcessWithExitCode)
-import Xmobar.Run.Exec
-import Xmobar.Plugins.Command (Rate)
-
-data ArchUpdates = ArchUpdates (String, String, String) Rate
- deriving (Read, Show)
-
-instance Exec ArchUpdates where
- alias (ArchUpdates _ _) = "arch"
- rate (ArchUpdates _ r) = r
- run (ArchUpdates (z, o, m) _) = do
- (exit, stdout, _) <- readProcessWithExitCode "checkupdates" [] ""
- return $ case exit of
- ExitFailure 2 -> z--ero updates
- ExitFailure 1 -> "pacman: Unknown cause of failure."
- ExitSuccess -> case length $ lines stdout of
- 0 -> impossible
- 1 -> o
- n -> m >>= \c -> if c == '?' then show n else pure c
- _ -> impossible
- where
- impossible = error "This is impossible based on pacman manpage"
diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs
index 78f1cc0..9b583ea 100644
--- a/src/Xmobar/Plugins/EWMH.hs
+++ b/src/Xmobar/Plugins/EWMH.hs
@@ -232,7 +232,7 @@ updateClientList _ = do
where
unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0
listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask
- update w = mapM_ (($ w) . snd) clientHandlers
+ update w = mapM_ (`snd` w) clientHandlers
modifyClient :: Window -> (Client -> Client) -> M ()
modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s })
diff --git a/src/Xmobar/Plugins/MarqueePipeReader.hs b/src/Xmobar/Plugins/MarqueePipeReader.hs
index 075503c..a6d590e 100644
--- a/src/Xmobar/Plugins/MarqueePipeReader.hs
+++ b/src/Xmobar/Plugins/MarqueePipeReader.hs
@@ -60,7 +60,7 @@ writer txt sep len rate chan cb = do
Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb
toInfTxt :: String -> String -> String
-toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ")
+toInfTxt line sep = cycle (line ++ " " ++ sep ++ " ")
checkPipe :: FilePath -> IO ()
checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do
diff --git a/src/Xmobar/Plugins/Monitors/Batt/Common.hs b/src/Xmobar/Plugins/Monitors/Batt/Common.hs
index ddb2b8c..31caabc 100644
--- a/src/Xmobar/Plugins/Monitors/Batt/Common.hs
+++ b/src/Xmobar/Plugins/Monitors/Batt/Common.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeApplications #-}
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.Batt.Common
@@ -18,7 +19,8 @@ module Xmobar.Plugins.Monitors.Batt.Common (BattOpts(..)
, Status(..)
, maybeAlert) where
-import System.Process (spawnCommand, waitForProcess)
+import System.Environment
+import System.Process (waitForProcess, withCreateProcess, shell, CreateProcess(env))
import Control.Monad (unless, void)
import Xmobar.Plugins.Monitors.Common
@@ -54,4 +56,11 @@ maybeAlert opts left =
case onLowAction opts of
Nothing -> return ()
Just x -> unless (isNaN left || actionThreshold opts < 100 * left)
- $ void $ spawnCommand (x ++ " &") >>= waitForProcess
+ $ runCmd =<< mkShellCmd x
+ where
+ mkShellCmd command = do
+ selfEnv <- getEnvironment
+ pure (shell command) { env = Just $ ("XMOBAR_BATT_LEFT", show @Int $ round $ 100 * left) : selfEnv
+ }
+ runCmd c = withCreateProcess c $ \_ _ _ ph ->
+ void $ waitForProcess ph
diff --git a/src/Xmobar/Plugins/Monitors/Batt/Linux.hs b/src/Xmobar/Plugins/Monitors/Batt/Linux.hs
index 5389be0..d95b902 100644
--- a/src/Xmobar/Plugins/Monitors/Batt/Linux.hs
+++ b/src/Xmobar/Plugins/Monitors/Batt/Linux.hs
@@ -199,5 +199,5 @@ readBatteries opts bfs =
| time == 0 = Idle
| ac = Charging
| otherwise = Discharging
- unless ac (maybeAlert opts left)
+ unless (racst == Charging || racst == Idle) $ maybeAlert opts left
return $ if isNaN left then NA else Result left watts time racst
diff --git a/src/Xmobar/Plugins/Monitors/Bright.hs b/src/Xmobar/Plugins/Monitors/Bright.hs
index 12790e1..9c61fb2 100644
--- a/src/Xmobar/Plugins/Monitors/Bright.hs
+++ b/src/Xmobar/Plugins/Monitors/Bright.hs
@@ -54,11 +54,12 @@ data Files = Files { fCurr :: String
, fMax :: String
}
| NoFiles
+ deriving Show
brightFiles :: BrightOpts -> IO Files
brightFiles opts = do
is_curr <- fileExist $ fCurr files
- is_max <- fileExist $ fCurr files
+ is_max <- fileExist $ fMax files
return (if is_curr && is_max then files else NoFiles)
where prefix = sysDir </> subDir opts
files = Files { fCurr = prefix </> currBright opts
diff --git a/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc b/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc
index 296ba6c..b5530f1 100644
--- a/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc
+++ b/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc
@@ -39,7 +39,7 @@ import Xmobar.Plugins.Monitors.Disk.Common (
, Path
)
-import qualified Control.Exception.Extensible as E
+import qualified Control.Exception as E
import qualified Data.List as DL
import qualified Data.Map as DM
import qualified Data.Set as DS
diff --git a/src/Xmobar/Plugins/Monitors/MPD.hs b/src/Xmobar/Plugins/Monitors/MPD.hs
index 7ecbc0c..b091147 100644
--- a/src/Xmobar/Plugins/Monitors/MPD.hs
+++ b/src/Xmobar/Plugins/Monitors/MPD.hs
@@ -109,8 +109,9 @@ parseMPD (Right st) song opts = do
si = stateGlyph s opts
vol = int2str $ fromMaybe 0 (M.stVolume st)
(p, t) = fromMaybe (0, 0) (M.stTime st)
- [lap, len, remain] = map showTime
- [floor p, floor t, max 0 (floor t - floor p)]
+ lap = showTime $ floor p
+ len = showTime $ floor t
+ remain = showTime $ max 0 (floor t - floor p)
b = if t > 0 then realToFrac $ p / t else 0
plen = int2str $ M.stPlaylistLength st
ppos = maybe "" (int2str . (+1)) $ M.stSongPos st
diff --git a/src/Xmobar/Plugins/Monitors/Mpris.hs b/src/Xmobar/Plugins/Monitors/Mpris.hs
index ee30ad3..eb9595b 100644
--- a/src/Xmobar/Plugins/Monitors/Mpris.hs
+++ b/src/Xmobar/Plugins/Monitors/Mpris.hs
@@ -28,7 +28,7 @@ import qualified DBus.Client as DC
import Control.Arrow ((***))
import Data.Maybe ( fromJust )
import Data.Int ( Int32, Int64 )
-import Data.Word ( Word32 )
+import Data.Word ( Word32, Word64 )
import System.IO.Unsafe ( unsafePerformIO )
import Control.Exception (try)
@@ -136,17 +136,17 @@ makeList version md = map getStr (fieldsList version) where
"xesam:trackNumber" -> printf "%02d" num
_ -> (show::Int32 -> String) num
pw32 v = printf "%02d" (fromVar v::Word32)
- plen str v = let num = fromVar v in
- case str of
+ plen str num = case str of
"mpris:length" -> formatTime (num `div` 1000000)
- _ -> (show::Int64 -> String) num
+ _ -> show num
getStr str = case lookup str md of
Nothing -> ""
Just v -> case variantType v of
TypeString -> fromVar v
TypeInt32 -> pInt str v
TypeWord32 -> pw32 v
- TypeInt64 -> plen str v
+ TypeWord64 -> plen str (fromVar v :: Word64)
+ TypeInt64 -> plen str (fromVar v :: Int64)
TypeArray TypeString ->
let x = arrayItems (fromVar v) in
if null x then "" else fromVar (head x)
diff --git a/src/Xmobar/Plugins/Monitors/Swap/FreeBSD.hsc b/src/Xmobar/Plugins/Monitors/Swap/FreeBSD.hsc
index 9c74e36..90c58c1 100644
--- a/src/Xmobar/Plugins/Monitors/Swap/FreeBSD.hsc
+++ b/src/Xmobar/Plugins/Monitors/Swap/FreeBSD.hsc
@@ -71,11 +71,10 @@ instance Storable SwapData where
poke _ _ = pure ()
-
isEnabled :: IO Bool
isEnabled = do
- enabled <- sysctlReadUInt "vm.swap_enabled"
- return $ enabled == 1
+ nswapdev <- sysctlReadUInt "vm.nswapdev"
+ return $ nswapdev > 0
parseMEM' :: Bool -> IO [Float]
parseMEM' False = return []
diff --git a/src/Xmobar/Plugins/Monitors/Top.hs b/src/Xmobar/Plugins/Monitors/Top.hs
index 3bfe6fd..b2e573b 100644
--- a/src/Xmobar/Plugins/Monitors/Top.hs
+++ b/src/Xmobar/Plugins/Monitors/Top.hs
@@ -3,7 +3,7 @@
-----------------------------------------------------------------------------
-- |
-- Module : Plugins.Monitors.Top
--- Copyright : (c) 2010, 2011, 2012, 2013, 2014, 2018, 2022 Jose A Ortega Ruiz
+-- Copyright : (c) 2010-2014, 2018, 2022, 2025 Jose A Ortega Ruiz
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org>
@@ -20,7 +20,7 @@ import Xmobar.Plugins.Monitors.Common
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.List (sortBy)
-import Data.Ord (comparing)
+import Data.Ord (comparing, Down (..))
import Data.Time.Clock (getCurrentTime, diffUTCTime)
import Xmobar.Plugins.Monitors.Top.Common (
@@ -66,7 +66,7 @@ showInfo nm sms mms = do
sortTop :: [(String, Float)] -> [(String, Float)]
-sortTop = sortBy (flip (comparing snd))
+sortTop = sortBy (comparing (Down . snd))
showMemInfo :: Float -> MemInfo -> Monitor [String]
showMemInfo scale (nm, rss) =
diff --git a/src/Xmobar/Plugins/PacmanUpdates.hs b/src/Xmobar/Plugins/PacmanUpdates.hs
new file mode 100644
index 0000000..ea14454
--- /dev/null
+++ b/src/Xmobar/Plugins/PacmanUpdates.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
+{- |
+Module : Plugins.Monitors.PacmanUpdates
+Copyright : (c) 2024, 2026 Enrico Maria De Angelis
+ , (c) 2025 Alexander Pankoff
+ , (c) 2026 Enrico Maria De Angelis
+License : BSD-style (see LICENSE)
+
+Maintainer : Enrico Maria De Angelis <enricomaria.dean6elis@gmail.com>
+Stability : unstable
+Portability : unportable
+
+A Pacman updates availablility plugin for Xmobar. It also informs whether a kernel update is
+available (provided the name of the kernel package), and whether the running kernel is older
+than the installed one.
+-}
+module Xmobar.Plugins.PacmanUpdates (
+#if __GLASGOW_HASKELL__ >= 908
+ {-# DEPRECATED "This ctor is DEPRECATED; please use `PacmanUpdates` type and `PacmanUpdatesK`, `PacmanUpdatesPredicateK` and `PacmanUpdatesNoK` constructors instead." #-}
+#endif
+ pattern PacmanUpdates
+ , PacmanUpdates ()
+ , PacmanUpdatesKernelCheck (..)
+ , pattern PacmanUpdatesK
+ , pattern PacmanUpdatesPredicateK
+ , pattern PacmanUpdatesNoK) where
+
+import System.Exit (ExitCode (..))
+import System.Process (readProcessWithExitCode)
+import Xmobar.Plugins.Command (Rate)
+import Xmobar.Run.Exec
+import Data.Tuple.Extra (fst3)
+import Data.Kind (Type)
+import Data.Functor ((<&>))
+import Data.Void (Void)
+import Control.Arrow ((&&&))
+import qualified Data.Vector as V
+
+-- | Deprecated plugin ctor (will be deleted in 2027).
+-- Use `PacmanUpdatesK`, `PacmanUpdatesPredicateK`, or `PacmanUpdatesNoK` instead.
+pattern PacmanUpdates :: (String, String, String, String) -- ^ `String`s to be shown for 0, 1, ≥ 2 updates,
+ -- and for error respectively (in the 3rd string, for
+ -- ≥ 2 updates, any occurrence of the '?' character
+ -- is a placeholder for the number of available updates).
+ -> Rate -- ^ `Rate` of update (see [Xmobar doc](https://codeberg.org/xmobar/xmobar/src/commit/39fd70308c3aef5402abe7152ade76ff7bb331bb/src/Xmobar/Plugins/Command.hs#L34)).
+ -> PacmanUpdates NoKernelCheck
+pattern PacmanUpdates irrelevant <- (error "PacmanUpdates: PacmanUpdates is a build-only pattern synonym (a ctor synonym)." -> irrelevant)
+ where PacmanUpdates zome r
+ = let (z, o, m, e) = zome
+ printer = const
+ $ (++ deprecationNote)
+ . \case Left _ -> e
+ Right 0 -> z
+ Right 1 -> o
+ Right n -> m >>= \c -> if c == '?'
+ then show n
+ else pure c
+ deprecationNote = " <fc=#ff0000>(<action=`xdg-open https://codeberg.org/xmobar/xmobar/pulls/765`>"
+ ++ "deprecated plugin, click here</action>)</fc>"
+ in PacmanUpdatesNoK r printer
+
+
+-- | Different types of kernel checks.
+data PacmanUpdatesKernelCheck = NoKernelCheck | PredicateKernelCheck
+
+-- | PacmanUpdates plugin parametrized over the `PacmanUpdatesKernelCheck` kind.
+data PacmanUpdates (b :: PacmanUpdatesKernelCheck)
+ = Make -- ^ Constructor.
+ Rate -- ^ `Rate` of update (see [Xmobar doc](https://codeberg.org/xmobar/xmobar/src/commit/39fd70308c3aef5402abe7152ade76ff7bb331bb/src/Xmobar/Plugins/Command.hs#L34)).
+ (Arg b) -- ^ Optional further argument. See instances of `Updates`.
+ (Printer b) -- ^ Printer. See instances of `Updates` for its signature.
+
+instance Show (PacmanUpdates b) where
+ show = error "PacmanUpdates: Show instance is stub"
+
+instance Read (PacmanUpdates b) where
+ readsPrec = error "PacmanUpdates: Read instance is stub"
+
+instance Updates b => Exec (PacmanUpdates (b :: PacmanUpdatesKernelCheck)) where
+ alias = const "pacman"
+ rate (Make r _ _) = r
+ run = Xmobar.Plugins.PacmanUpdates.run'
+
+class Updates (b :: PacmanUpdatesKernelCheck) where
+ -- | See `Updates`'s instances.
+ type Arg b = (a :: Type) | a -> b
+ -- | See `Updates`'s instances.
+ type Printer b = (p :: Type) | p -> b
+ -- | This is the implementation of `Xmobar.Run.Exec.run`.
+ run' :: PacmanUpdates b -> IO String
+
+-- | No additional argument required for constructing the plugin;
+-- the user-provided printer is fed with a `Bool` telling whether
+-- the system is running an outdated kernel, and an `Int` telling
+-- the number of available updates (or `Left` if an error occurred
+-- when calling `checkupdates`).
+instance Updates NoKernelCheck where
+ type Arg NoKernelCheck = Void
+ type Printer NoKernelCheck = Bool -> Either String Int -> String
+ run' (Make _ _ printer)
+ = printer
+ <$> kernIsOld
+ <*> (fmap V.length <$> checkUpdates)
+
+-- | Constructing the plugin requires an additional `String -> Bool` predicate
+-- that receives each available package name and returns `True` for kernel
+-- packages; the user-provided printer is fed with a `Bool` telling whether the
+-- system is running an outdated kernel, and an `(Int, Bool)` pair telling the
+-- number of available updates and whether one of these is a kernel update (or
+-- `Left` if an error occurred when calling `checkupdates`).
+instance Updates PredicateKernelCheck where
+ type Arg PredicateKernelCheck = String -> Bool
+ type Printer PredicateKernelCheck = Bool -> Either String (Int, Bool) -> String
+ run' (Make _ checkKern printer)
+ = printer
+ <$> kernIsOld
+ <*> (fmap (V.length &&& V.any checkKern) <$> checkUpdates)
+
+-- | Pattern synonym to construct a `PacmanUpdates PredicateKernelCheck` that
+-- detects updates for packages matched by the given @(String -> Bool)@
+-- predicate. This can be used to detect kernel updates for distributions
+-- with versioned kernel package names (e.g. Manjaro's @linux618@)
+pattern PacmanUpdatesPredicateK :: Rate -> Arg PredicateKernelCheck -> Printer PredicateKernelCheck -> PacmanUpdates PredicateKernelCheck
+pattern PacmanUpdatesPredicateK r a p = Make r a p
+
+-- | A convenience wrapper around PacmanUpdatesPredicateK with the predicate @(== kernName)@
+-- Construction only: the kernel name cannot be recovered when matching.
+pattern PacmanUpdatesK :: Rate -> String -> Printer PredicateKernelCheck -> PacmanUpdates PredicateKernelCheck
+pattern PacmanUpdatesK r kernName p <-
+ (error "PacmanUpdatesK: build-only pattern synonym (a ctor synonym)." -> (r, kernName, p))
+ where PacmanUpdatesK r kernName p = PacmanUpdatesPredicateK r (== kernName) p
+
+-- | Pattern synonym used to construct a `PacmanUpdates NoKernelCheck`.
+pattern PacmanUpdatesNoK :: Rate -> Printer NoKernelCheck -> PacmanUpdates NoKernelCheck
+pattern PacmanUpdatesNoK r p <- Make r _ p
+ where PacmanUpdatesNoK r p = Make r undefined p
+
+checkUpdates :: IO (Either String (V.Vector String))
+checkUpdates = readProcessWithExitCode "checkupdates" [] ""
+ <&> \case (ExitFailure 2, "", "") -> Right V.empty
+ (ExitSuccess, stdout, "")
+ -> let pkgName = takeWhile (/= ' ')
+ pkgs = V.fromList $ fmap pkgName $ lines stdout
+ in case V.length pkgs of
+ 0 -> impossible
+ _ -> Right pkgs
+ (ExitFailure 1, _, _) -> Left "checkupdates: unknown cause of failure."
+ _ -> impossible
+
+kernIsOld :: IO Bool
+kernIsOld = (/= ExitSuccess) . exitCode <$> readProcessWithExitCode "modinfo" ["-n", "i915"] ""
+ where exitCode = fst3
+
+impossible :: a
+impossible = error "This is impossible, according to my knowledge."
diff --git a/src/Xmobar/Run/Actions.hs b/src/Xmobar/Run/Actions.hs
index cbc10c5..a9afed9 100644
--- a/src/Xmobar/Run/Actions.hs
+++ b/src/Xmobar/Run/Actions.hs
@@ -16,7 +16,7 @@ module Xmobar.Run.Actions ( Button
, runAction'
, stripActions) where
-import System.Process (spawnCommand, waitForProcess)
+import System.Process (shell, withCreateProcess, waitForProcess)
import Control.Monad (void)
import Text.Regex (Regex, subRegex, mkRegex, matchRegex)
import Data.Word (Word32)
@@ -26,11 +26,12 @@ type Button = Word32
data Action = Spawn [Button] String deriving (Eq, Read, Show)
runAction :: Action -> IO ()
-runAction (Spawn _ s) = void $ spawnCommand (s ++ " &") >>= waitForProcess
+runAction (Spawn _ s) = withCreateProcess (shell s) $ \_ _ _ ph ->
+ void $ waitForProcess ph
-- | Run action with stdout redirected to stderr
runAction' :: Action -> IO ()
-runAction' (Spawn _ s) = void $ spawnCommand (s ++ " 1>&2 &") >>= waitForProcess
+runAction' (Spawn btn s) = runAction (Spawn btn (s ++ " 1>&2"))
stripActions :: String -> String
stripActions s = case matchRegex actionRegex s of
diff --git a/src/Xmobar/Run/Loop.hs b/src/Xmobar/Run/Loop.hs
index bda41ff..6775961 100644
--- a/src/Xmobar/Run/Loop.hs
+++ b/src/Xmobar/Run/Loop.hs
@@ -57,7 +57,7 @@ type LoopFunction = TMVar SignalType -> TVar [String] -> IO ()
loop :: Config -> LoopFunction -> IO ()
loop conf looper = withDeferSignals $ do
- cls <- mapM (parseTemplate (commands conf) (sepChar conf))
+ let cls = map (parseTemplate (commands conf) (sepChar conf))
(splitTemplate (alignSep conf) (template conf))
let confSig = unSignalChan (signal conf)
sig <- maybe newEmptyTMVarIO pure confSig
diff --git a/src/Xmobar/Run/Template.hs b/src/Xmobar/Run/Template.hs
index 68feacb..0e066dc 100644
--- a/src/Xmobar/Run/Template.hs
+++ b/src/Xmobar/Run/Template.hs
@@ -50,21 +50,20 @@ templateParser s = many $ templateStringParser s
-- | Actually runs the template parsers over a (segment of) a template
-- string, returning a list of runnables with their prefix and suffix.
-parseTemplate :: [Runnable] -> String -> String -> IO [(Runnable,String,String)]
+parseTemplate :: [Runnable] -> String -> String -> [(Runnable,String,String)]
parseTemplate c sepChar s =
- do str <- case parse (templateParser sepChar) "" s of
- Left _ -> return [("", s, "")]
- Right x -> return x
- let cl = map alias c
- m = Map.fromList $ zip cl c
- return $ combine c m str
+ let str = case parse (templateParser sepChar) "" s of
+ Left _ -> [("", s, "")]
+ Right x -> x
+ cl = map alias c
+ m = Map.fromList $ zip cl c
+ in combine m str
-- | Given a finite "Map" and a parsed template produce the resulting
-- output string.
-combine :: [Runnable] -> Map.Map String Runnable -> [(String, String, String)]
- -> [(Runnable,String,String)]
-combine _ _ [] = []
-combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs
+combine :: Map.Map String Runnable -> [(String, String, String)] -> [(Runnable,String,String)]
+combine _ [] = []
+combine m ((ts,s,ss):xs) = (com, s, ss) : combine m xs
where com = Map.findWithDefault dflt ts m
dflt = Run $ Com ts [] [] 10
diff --git a/src/Xmobar/Run/Types.hs b/src/Xmobar/Run/Types.hs
index bb573c8..8b9caa4 100644
--- a/src/Xmobar/Run/Types.hs
+++ b/src/Xmobar/Run/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE TypeOperators, CPP #-}
+{-# LANGUAGE DataKinds #-}
------------------------------------------------------------------------------
-- |
-- Module: Xmobar.Run.Types
@@ -19,7 +20,7 @@
module Xmobar.Run.Types(runnableTypes) where
import {-# SOURCE #-} Xmobar.Run.Runnable()
-import Xmobar.Plugins.ArchUpdates
+import Xmobar.Plugins.PacmanUpdates
import Xmobar.Plugins.Command
import Xmobar.Plugins.Monitors
import Xmobar.Plugins.Date
@@ -60,7 +61,6 @@ infixr :*:
runnableTypes :: Command :*: Monitors :*: Date :*: PipeReader :*:
BufferedPipeReader :*: CommandReader :*: StdinReader :*:
XMonadLog :*: EWMH :*: Kbd :*: Locks :*: NotmuchMail :*:
- ArchUpdates :*:
#ifdef INOTIFY
Mail :*: MBox :*:
#endif
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index 2dfb34d..0425cff 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -170,7 +170,7 @@ updateConfigPosition disp cfg =
runActions :: D.Actions -> A.Button -> X11.Position -> IO ()
runActions actions button pos =
mapM_ A.runAction $
- filter (\(A.Spawn b _) -> button `elem` b) $
- concatMap (\(a,_,_) -> a) $
- filter (\(_, from, to) -> pos' >= from && pos' <= to) actions
+ concatMap
+ (filter (\ (A.Spawn b _) -> button `elem` b) . (\ (a, _, _) -> a))
+ (filter (\ (_, from, to) -> pos' >= from && pos' <= to) actions)
where pos' = fromIntegral pos
diff --git a/src/Xmobar/X11/XRender.hsc b/src/Xmobar/X11/XRender.hsc
index 5ad0391..4e4d448 100644
--- a/src/Xmobar/X11/XRender.hsc
+++ b/src/Xmobar/X11/XRender.hsc
@@ -91,22 +91,28 @@ drawBackground d p bgc alpha (Rectangle x y wid ht) = do
withRenderFill d
(XRenderColor 0 0 0 (257 * alpha))
(render pictOpSrc bgfill pic)
- -- Handle transparency
- internAtom d "_XROOTPMAP_ID" False >>= \xid ->
- let xroot = defaultRootWindow d in
- alloca $ \x1 ->
- alloca $ \x2 ->
- alloca $ \x3 ->
- alloca $ \x4 ->
- alloca $ \pprop -> do
- xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop
- prop <- peek pprop
- when (prop /= nullPtr) $ do
- rootbg <- peek (castPtr prop) :: IO Pixmap
- xFree prop
- withRenderPicture d rootbg $ \bgpic ->
- withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))
- (render pictOpAdd bgpic pic)
+ -- Handle pseudo-transparency by compositing the root pixmap.
+ -- Skip entirely when alpha == 255 (fully opaque) since the blend
+ -- factor would be zero, making this a no-op. More importantly,
+ -- the root pixmap (_XROOTPMAP_ID) can be freed at any time by
+ -- wallpaper setters like feh (via XKillClient), causing a
+ -- BadDrawable crash in XRenderCreatePicture if we touch it.
+ when (alpha < 255) $
+ internAtom d "_XROOTPMAP_ID" False >>= \xid ->
+ let xroot = defaultRootWindow d in
+ alloca $ \x1 ->
+ alloca $ \x2 ->
+ alloca $ \x3 ->
+ alloca $ \x4 ->
+ alloca $ \pprop -> do
+ xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop
+ prop <- peek pprop
+ when (prop /= nullPtr) $ do
+ rootbg <- peek (castPtr prop) :: IO Pixmap
+ xFree prop
+ withRenderPicture d rootbg $ \bgpic ->
+ withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))
+ (render pictOpAdd bgpic pic)
-- | Parses color into XRender color (allocation not necessary!)
parseRenderColor :: Display -> String -> IO XRenderColor
generated by cgit v1.2.3 (git 2.46.0) at 2026-07-23 01:36:55 +0000