ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH use rio proc for xmobar startup

This commit is contained in:
Nathan Dwarshuis 2022-12-27 22:09:23 -05:00
parent 6526f5e309
commit 780c600d47
1 changed files with 22 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
bin/xmonad.hs
View File

@ -21,6 +21,7 @@ import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import RIO (async) import RIO (async)
import RIO.Process
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory import System.Directory
@ -29,7 +30,10 @@ import System.IO hiding
( hPutStrLn ( hPutStrLn
) )
import System.IO.Error import System.IO.Error
import System.Process import System.Process hiding
( createPipe
, proc
)
import XMonad import XMonad
import XMonad.Actions.CopyWindow import XMonad.Actions.CopyWindow
@ -53,7 +57,7 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Removable import XMonad.Internal.DBus.Removable
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import XMonad.Internal.Process import XMonad.Internal.Process (killHandle)
import XMonad.Internal.Shell import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT import qualified XMonad.Internal.Theme as XT
import XMonad.Layout.MultiToggle import XMonad.Layout.MultiToggle
@ -152,7 +156,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
let fs = features cl let fs = features cl
tt <- evalAlways $ fsTabbedTheme fs tt <- evalAlways $ fsTabbedTheme fs
startDBusInterfaces fs startDBusInterfaces fs
(xmobarHandle, ts) <- startChildDaemons fs ts <- startChildDaemons fs
startRemovableMon fs startRemovableMon fs
startPowerMon fs startPowerMon fs
dws <- startDynWorkspaces fs dws <- startDynWorkspaces fs
@ -170,7 +174,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
, handleEventHook = myEventHook ha , handleEventHook = myEventHook ha
, startupHook = myStartupHook , startupHook = myStartupHook
, workspaces = myWorkspaces , workspaces = myWorkspaces
, logHook = maybe logViewports myLoghook xmobarHandle , logHook = maybe logViewports myLoghook $ tsXmobar ts
, clickJustFocuses = False , clickJustFocuses = False
, focusFollowsMouse = False , focusFollowsMouse = False
, normalBorderColor = T.unpack XT.bordersColor , normalBorderColor = T.unpack XT.bordersColor
@ -181,12 +185,14 @@ evalConf db@DBusState { dbSysClient = cl } = do
startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
$ fsDBusExporters fs $ fsDBusExporters fs
startChildDaemons fs = do startChildDaemons fs = do
(h, _, _, p) <- io $ createProcess $ (shell "xmobar") { std_in = CreatePipe } p <- proc "xmobar" [] (startProcess . setStdin createPipe)
io $ case h of -- (h, _, _, p) <- io $ createProcess $ (shell "xmobar") { std_in = CreatePipe }
Just h' -> hSetBuffering h' LineBuffering io $ hSetBuffering (getStdin p) LineBuffering
Nothing -> return () -- io $ case h of
-- Just h' -> hSetBuffering h' LineBuffering
-- Nothing -> return ()
ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
return (h, ThreadState (p:ps) $ maybeToList h) return $ ThreadState ps $ Just p
startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
$ dbSysClient db $ dbSysClient db
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
@ -215,7 +221,7 @@ allFeatures db = do
let others = [runRemovableMon $ dbSysClient db, runPowermon] let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus ++ others, Left runScreenLock:bfs, allDWs') return (dbus ++ others, Left runScreenLock:bfs, allDWs')
where where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] } ts = ThreadState { tsChildPIDs = [], tsXmobar = Nothing }
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage = putStrLn $ intercalate "\n"
@ -227,8 +233,8 @@ usage = putStrLn $ intercalate "\n"
-- | Concurrency configuration -- | Concurrency configuration
data ThreadState = ThreadState data ThreadState = ThreadState
{ tsChildPIDs :: [ProcessHandle] { tsChildPIDs :: [ProcessHandle]
, tsChildHandles :: [Handle] , tsXmobar :: Maybe (Process Handle () ())
} }
-- TODO shouldn't this be run by a signal handler? -- TODO shouldn't this be run by a signal handler?
@ -395,7 +401,7 @@ runHide = sendMessage $ Toggle HIDE
-- | Loghook configuration -- | Loghook configuration
-- --
myLoghook :: Handle -> X () myLoghook :: Process Handle () () -> X ()
myLoghook h = do myLoghook h = do
logXinerama h logXinerama h
logViewports logViewports
@ -452,9 +458,9 @@ whenChanged v action = do
-- screen. The "<>" is the workspace that currently has focus. N is the number -- screen. The "<>" is the workspace that currently has focus. N is the number
-- of windows on the current workspace. -- of windows on the current workspace.
logXinerama :: Handle -> X () logXinerama :: Process Handle () () -> X ()
logXinerama h = withWindowSet $ \ws -> io logXinerama p = withWindowSet $ \ws -> io
$ hPutStrLn h $ hPutStrLn (getStdin p)
$ T.unwords $ T.unwords
$ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] $ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
where where