WIP kinda get rio process to work for all subprocesses
This commit is contained in:
parent
87394dd6a9
commit
fb9b9fa65e
124
bin/xmonad.hs
124
bin/xmonad.hs
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -21,23 +22,13 @@ import Graphics.X11.Xlib.Atom
|
|||
import Graphics.X11.Xlib.Extras
|
||||
|
||||
import RIO
|
||||
( async
|
||||
, bracket
|
||||
, handleIO
|
||||
)
|
||||
import RIO.Directory
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.IO hiding
|
||||
( hPutStrLn
|
||||
)
|
||||
import System.IO.Error
|
||||
import System.Process hiding
|
||||
( createPipe
|
||||
, proc
|
||||
)
|
||||
import System.Posix.Signals
|
||||
import System.Process (getPid)
|
||||
|
||||
import XMonad
|
||||
import XMonad.Actions.CopyWindow
|
||||
|
|
@ -61,7 +52,6 @@ import XMonad.Internal.DBus.Brightness.IntelBacklight
|
|||
import XMonad.Internal.DBus.Control
|
||||
import XMonad.Internal.DBus.Removable
|
||||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Process (killHandle)
|
||||
import XMonad.Internal.Shell
|
||||
import qualified XMonad.Internal.Theme as XT
|
||||
import XMonad.Layout.MultiToggle
|
||||
|
|
@ -103,10 +93,7 @@ run = do
|
|||
uninstallSignalHandlers
|
||||
hSetBuffering stdout LineBuffering
|
||||
withCache $ do
|
||||
bracket (io connectDBusX) (io . disconnectDBus) $ \db -> do
|
||||
-- conf <- evalConf db
|
||||
-- ds <- io getCreateDirectories
|
||||
-- io $ launch conf ds
|
||||
withDBusX $ \db -> do
|
||||
let sys = dbSysClient db
|
||||
let fs = features sys
|
||||
startDBusInterfaces db fs
|
||||
|
|
@ -136,8 +123,7 @@ run = do
|
|||
, normalBorderColor = T.unpack XT.bordersColor
|
||||
, focusedBorderColor = T.unpack XT.selectedBordersColor
|
||||
}
|
||||
dirs <- io getCreateDirectories
|
||||
io $ launch conf dirs
|
||||
io $ runXMonad conf
|
||||
where
|
||||
startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs
|
||||
$ dbSysClient db
|
||||
|
|
@ -147,6 +133,11 @@ run = do
|
|||
void $ io $ async $ runWorkspaceMon dws
|
||||
return dws
|
||||
|
||||
runXMonad :: (LayoutClass l Window, Read (l Window)) => XConfig l -> IO ()
|
||||
runXMonad conf = do
|
||||
dirs <- getCreateDirectories
|
||||
launch conf dirs
|
||||
|
||||
startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
|
||||
startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
|
||||
$ fsDBusExporters fs
|
||||
|
|
@ -159,7 +150,7 @@ getCreateDirectories = do
|
|||
where
|
||||
createIfMissing ds f = do
|
||||
let d = f ds
|
||||
r <- tryIOError $ createDirectoryIfMissing True d
|
||||
r <- tryIO $ createDirectoryIfMissing True d
|
||||
case r of
|
||||
(Left e) -> print e
|
||||
_ -> return ()
|
||||
|
|
@ -169,7 +160,7 @@ data FeatureSet = FeatureSet
|
|||
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
|
||||
, fsPowerMon :: SometimesIO
|
||||
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
||||
, fsDaemons :: [Sometimes (IO ProcessHandle)]
|
||||
, fsDaemons :: [Sometimes (FIO (Process () () ()))]
|
||||
, fsACPIHandler :: Always (String -> X ())
|
||||
, fsTabbedTheme :: Always Theme
|
||||
, fsDynWorkspaces :: [Sometimes DynWorkspace]
|
||||
|
|
@ -196,67 +187,35 @@ features cl = FeatureSet
|
|||
, fsDaemons = [runNetAppDaemon cl, runAutolock]
|
||||
}
|
||||
|
||||
-- evalConf db@DBusState { dbSysClient = cl } = do
|
||||
-- -- start DBus interfaces first since many features after this test these
|
||||
-- -- interfaces as dependencies
|
||||
-- let fs = features cl
|
||||
-- tt <- evalAlways $ fsTabbedTheme fs
|
||||
-- startDBusInterfaces fs
|
||||
-- ts <- startChildDaemons fs
|
||||
-- startRemovableMon fs
|
||||
-- startPowerMon fs
|
||||
-- dws <- startDynWorkspaces fs
|
||||
-- -- fb <- evalAlways $ fsFontBuilder features
|
||||
-- kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
|
||||
-- sk <- evalAlways $ fsShowKeys fs
|
||||
-- ha <- evalAlways $ fsACPIHandler fs
|
||||
-- return $ ewmh
|
||||
-- $ addKeymap dws sk kbs
|
||||
-- $ docks
|
||||
-- $ def { terminal = myTerm
|
||||
-- , modMask = myModMask
|
||||
-- , layoutHook = myLayouts tt
|
||||
-- , manageHook = myManageHook dws
|
||||
-- , handleEventHook = myEventHook ha
|
||||
-- , startupHook = myStartupHook
|
||||
-- , workspaces = myWorkspaces
|
||||
-- , logHook = maybe logViewports myLoghook $ tsXmobar ts
|
||||
-- , clickJustFocuses = False
|
||||
-- , focusFollowsMouse = False
|
||||
-- , normalBorderColor = T.unpack XT.bordersColor
|
||||
-- , focusedBorderColor = T.unpack XT.selectedBordersColor
|
||||
-- }
|
||||
-- where
|
||||
-- forkIO_ = void . async
|
||||
-- startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
|
||||
-- $ fsDBusExporters fs
|
||||
-- startChildDaemons fs = do
|
||||
-- p <- proc "xmobar" [] (startProcess . setStdin createPipe)
|
||||
-- io $ hSetBuffering (getStdin p) LineBuffering
|
||||
-- ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||
-- return $ ThreadState ps $ Just p
|
||||
-- startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
|
||||
-- $ dbSysClient db
|
||||
-- startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
|
||||
-- startDynWorkspaces fs = do
|
||||
-- dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
|
||||
-- io $ forkIO_ $ runWorkspaceMon dws
|
||||
-- return dws
|
||||
|
||||
startXmobar :: FIO (Process Handle () ())
|
||||
startXmobar = do
|
||||
p <- proc "xmobar" [] (startProcess . setStdin createPipe)
|
||||
io $ hSetBuffering (getStdin p) LineBuffering
|
||||
return p
|
||||
|
||||
startChildDaemons :: FeatureSet -> FIO [ProcessHandle]
|
||||
startChildDaemons :: FeatureSet -> FIO [Process () () ()]
|
||||
startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
|
||||
|
||||
withChildDaemons :: FeatureSet -> ([ProcessHandle] -> FIO a) -> FIO a
|
||||
withChildDaemons fs = bracket (startChildDaemons fs) (mapM_ (io . killHandle))
|
||||
withDBusX :: (DBusState -> FIO a) -> FIO a
|
||||
withDBusX = bracket (io connectDBusX) cleanup
|
||||
where
|
||||
cleanup db = do
|
||||
logInfo "unregistering xmonad from DBus"
|
||||
io $ disconnectDBus db
|
||||
|
||||
withChildDaemons :: FeatureSet -> ([Process () () ()] -> FIO a) -> FIO a
|
||||
withChildDaemons fs = bracket (startChildDaemons fs) cleanup
|
||||
where
|
||||
cleanup ps = do
|
||||
logInfo "stopping child processes"
|
||||
mapM_ stopProcess ps
|
||||
|
||||
withXmobar :: (Process Handle () () -> FIO a) -> FIO a
|
||||
withXmobar = bracket startXmobar stopProcess
|
||||
withXmobar = bracket startXmobar cleanup
|
||||
where
|
||||
cleanup p = do
|
||||
logInfo "stopping xmobar child process"
|
||||
stopProcess p
|
||||
|
||||
printDeps :: FIO ()
|
||||
printDeps = do
|
||||
|
|
@ -290,18 +249,23 @@ usage = putStrLn $ intercalate "\n"
|
|||
-- | Concurrency configuration
|
||||
|
||||
data ThreadState = ThreadState
|
||||
{ tsChildPIDs :: [ProcessHandle]
|
||||
{ tsChildPIDs :: [Process () () ()]
|
||||
, tsXmobar :: Maybe (Process Handle () ())
|
||||
}
|
||||
|
||||
-- TODO shouldn't this be run by a signal handler?
|
||||
runCleanup :: ThreadState -> DBusState -> X ()
|
||||
runCleanup ts db = io $ do
|
||||
mapM_ stopNoWait $ tsXmobar ts
|
||||
mapM_ killHandle $ tsChildPIDs ts
|
||||
disconnectDBusX db
|
||||
mapM_ killNoWait $ tsXmobar ts
|
||||
finally (mapM_ killNoWait $ tsChildPIDs ts) $
|
||||
disconnectDBusX db
|
||||
where
|
||||
stopNoWait p = handleIO (\_ -> return ()) $ stopProcess p
|
||||
killNoWait p = do
|
||||
let ph = unsafeProcessHandle p
|
||||
i <- getPid ph
|
||||
forM_ i $ signalProcess sigTERM
|
||||
-- terminateProcess ph
|
||||
stopNoWait p
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Startuphook configuration
|
||||
|
|
@ -777,14 +741,14 @@ externalBindings ts db =
|
|||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle ses
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
|
||||
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
||||
]
|
||||
]
|
||||
where
|
||||
ses = dbSesClient db
|
||||
sys = dbSysClient db
|
||||
brightessControls ctl getter = (ioSometimes . getter . ctl) ses
|
||||
brightessControls ctl getter = (getter . ctl) ses
|
||||
ib = Left . brightessControls intelBacklightControls
|
||||
ck = Left . brightessControls clevoKeyboardControls
|
||||
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
||||
|
|
|
|||
|
|
@ -162,8 +162,8 @@ executeAlways :: Always (IO a) -> FIO a
|
|||
executeAlways = io <=< evalAlways
|
||||
|
||||
-- | Execute a Sometimes immediately (or do nothing if failure)
|
||||
executeSometimes :: Sometimes (IO a) -> FIO (Maybe a)
|
||||
executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes a
|
||||
executeSometimes :: Sometimes (FIO a) -> FIO (Maybe a)
|
||||
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
||||
|
||||
-- | Possibly return the action of an Always/Sometimes
|
||||
evalFeature :: Feature a -> FIO (Maybe a)
|
||||
|
|
@ -228,7 +228,7 @@ type AlwaysIO = Always (IO ())
|
|||
|
||||
type SometimesX = Sometimes (X ())
|
||||
|
||||
type SometimesIO = Sometimes (IO ())
|
||||
type SometimesIO = Sometimes (FIO ())
|
||||
|
||||
type Feature a = Either (Sometimes a) (Always a)
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@ module XMonad.Internal.Command.Desktop
|
|||
, networkManagerPkgs
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Internal.DBus
|
||||
|
|
@ -49,19 +48,20 @@ import Data.Internal.Dependency
|
|||
|
||||
import DBus
|
||||
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.Posix.User
|
||||
|
||||
import XMonad (asks)
|
||||
import XMonad.Actions.Volume
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Internal.DBus.Common
|
||||
import XMonad.Internal.Notify
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Process hiding (createPipe, proc)
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Operations
|
||||
|
||||
|
|
@ -251,13 +251,13 @@ runNotificationContext =
|
|||
-- | System commands
|
||||
|
||||
-- this is required for some vpn's to work properly with network-manager
|
||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
|
||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (Process () () ()))
|
||||
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
|
||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||
where
|
||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
||||
cmd _ = spawnProcess "nm-applet" []
|
||||
cmd _ = proc "nm-applet" [] startProcess
|
||||
|
||||
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
||||
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
||||
|
|
|
|||
|
|
@ -27,8 +27,6 @@ module XMonad.Internal.Command.Power
|
|||
, promptFontDep
|
||||
) where
|
||||
|
||||
import Control.Arrow (first)
|
||||
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import Data.Either
|
||||
|
|
@ -36,13 +34,13 @@ import qualified Data.Map as M
|
|||
|
||||
import Graphics.X11.Types
|
||||
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import RIO.Process
|
||||
import qualified RIO.Text as T
|
||||
|
||||
import System.Directory
|
||||
import System.Exit
|
||||
import System.IO.Error
|
||||
import System.Process (ProcessHandle, spawnProcess)
|
||||
|
||||
import XMonad.Core
|
||||
import XMonad.Internal.Shell
|
||||
|
|
@ -90,12 +88,12 @@ runReboot = spawn "systemctl reboot"
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Autolock
|
||||
|
||||
runAutolock :: Sometimes (IO ProcessHandle)
|
||||
runAutolock :: Sometimes (FIO (Process () () ()))
|
||||
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||
where
|
||||
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
|
||||
$ Only_ $ IOSometimes_ runScreenLock
|
||||
cmd = spawnProcess "xss-lock" ["--ignore-sleep", "screenlock"]
|
||||
cmd = proc "xss-lock" ["--ignore-sleep", "screenlock"] startProcess
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Confirmation prompts
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ handleACPI fb lock tag = do
|
|||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||
-- and send ClientMessage events when it receives them
|
||||
runPowermon :: SometimesIO
|
||||
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep listenACPI
|
||||
runPowermon = sometimesIO_ "ACPI event monitor" "acpid" socketDep $ io listenACPI
|
||||
|
||||
runHandleACPI :: Always (String -> X ())
|
||||
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
||||
|
|
|
|||
|
|
@ -50,10 +50,10 @@ data BrightnessConfig a b = BrightnessConfig
|
|||
}
|
||||
|
||||
data BrightnessControls = BrightnessControls
|
||||
{ bctlMax :: SometimesIO
|
||||
, bctlMin :: SometimesIO
|
||||
, bctlInc :: SometimesIO
|
||||
, bctlDec :: SometimesIO
|
||||
{ bctlMax :: SometimesX
|
||||
, bctlMin :: SometimesX
|
||||
, bctlInc :: SometimesX
|
||||
, bctlDec :: SometimesX
|
||||
}
|
||||
|
||||
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
|
||||
|
|
@ -101,8 +101,8 @@ brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
|
|||
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
|
||||
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
|
||||
exportBrightnessControls' bc cl = do
|
||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
|
||||
exportBrightnessControls' bc cl = io $ do
|
||||
let ses = toClient cl
|
||||
maxval <- bcGetMax bc -- assume the max value will never change
|
||||
let bounds = (bcMinRaw bc, maxval)
|
||||
|
|
@ -138,7 +138,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
|||
sig = signal p i memCur
|
||||
|
||||
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
|
||||
-> MemberName -> SometimesIO
|
||||
-> MemberName -> SometimesX
|
||||
callBacklight q cl BrightnessConfig { bcPath = p
|
||||
, bcInterface = i
|
||||
, bcName = n } controlName m =
|
||||
|
|
|
|||
|
|
@ -86,6 +86,6 @@ listenDevices cl = do
|
|||
|
||||
runRemovableMon :: Maybe SysClient -> SometimesIO
|
||||
runRemovableMon cl =
|
||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
||||
sometimesDBus cl "removeable device monitor" "dbus monitor" deps $ io . listenDevices
|
||||
where
|
||||
deps = toAnd_ addedDep removedDep
|
||||
|
|
|
|||
|
|
@ -11,11 +11,11 @@ module XMonad.Internal.DBus.Screensaver
|
|||
, ssSignalDep
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Data.Internal.DBus
|
||||
import Data.Internal.Dependency
|
||||
|
||||
import RIO
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
import qualified DBus.Introspection as I
|
||||
|
|
@ -102,7 +102,7 @@ exportScreensaver ses =
|
|||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||
where
|
||||
cmd cl = let cl' = toClient cl in
|
||||
export cl' ssPath defaultInterface
|
||||
liftIO $ export cl' ssPath defaultInterface
|
||||
{ interfaceName = interface
|
||||
, interfaceMethods =
|
||||
[ autoMethod memToggle $ emitState cl' =<< toggle
|
||||
|
|
@ -123,7 +123,7 @@ exportScreensaver ses =
|
|||
bus = Bus [] xmonadBusName
|
||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||
|
||||
callToggle :: Maybe SesClient -> SometimesIO
|
||||
callToggle :: Maybe SesClient -> SometimesX
|
||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
|
||||
xmonadBusName ssPath interface memToggle
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue