WIP kinda get rio process to work for all subprocesses

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
+import           RIO.Directory
-    , bracket
-    , handleIO
-    )
 import           RIO.Process
 import qualified RIO.Text                                       as T
 
-import           System.Directory
 import           System.Environment
-import           System.IO                                      hiding
+import           System.Posix.Signals
-    ( hPutStrLn
+import           System.Process                                 (getPid)
-    )
-import           System.IO.Error
-import           System.Process                                 hiding
-    ( createPipe
-    , proc
-    )
 
 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
+    withDBusX $ \db -> do
-      -- conf <- evalConf db
-      -- ds <- io getCreateDirectories
-      -- io $ launch conf ds
       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 $ runXMonad conf
-          io $ launch conf dirs
   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
+withDBusX :: (DBusState -> FIO a) -> FIO a
-withChildDaemons fs = bracket (startChildDaemons fs) (mapM_ (io . killHandle))
+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_ killNoWait $ tsXmobar ts
-  mapM_ killHandle $ tsChildPIDs ts
+  finally (mapM_ killNoWait $ tsChildPIDs ts) $
-  disconnectDBusX db
+    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

lib/Data/Internal/Dependency.hs

@@ -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 :: Sometimes (FIO a) -> FIO (Maybe a)
-executeSometimes a = maybe (return Nothing) (io . fmap Just) =<< evalSometimes 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)
 

lib/XMonad/Internal/Command/Desktop.hs

@@ -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

lib/XMonad/Internal/Command/Power.hs

@@ -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

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -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

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -50,10 +50,10 @@ data BrightnessConfig a b = BrightnessConfig
   }
 
 data BrightnessControls = BrightnessControls
-  { bctlMax :: SometimesIO
+  { bctlMax :: SometimesX
-  , bctlMin :: SometimesIO
+  , bctlMin :: SometimesX
-  , bctlInc :: SometimesIO
+  , bctlInc :: SometimesX
-  , bctlDec :: SometimesIO
+  , 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' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
-exportBrightnessControls' bc cl = do
+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 =

lib/XMonad/Internal/DBus/Removable.hs

@@ -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

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -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