ENH use rio process for deps

bin/xmobar.hs

@@ -214,14 +214,14 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
   where
     root useIcon = IORoot_ (batteryCmd useIcon)
     tree = Only_ $ IOTest_ "Test if battery is present" []
-      $ fmap (Msg LevelError) <$> hasBattery
+      $ io $ fmap (Msg LevelError) <$> hasBattery
 
 getVPN :: Maybe SysClient -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
     test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
-      networkManagerPkgs vpnPresent
+      networkManagerPkgs $ io vpnPresent
 
 getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd

bin/xmonad.hs

@@ -79,7 +79,6 @@ parse ["--deps"] = withCache printDeps
 parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
 parse _          = usage
 
-
 run :: IO ()
 run = do
   -- These first two commands are only significant when xmonad is restarted.
@@ -150,38 +149,17 @@ features cl = FeatureSet
 evalConf db@DBusState { dbSysClient = cl } = do
   -- start DBus interfaces first since many features after this test these
   -- interfaces as dependencies
-  io $ putStrLn "hi"
-  -- io $ hFlush stdout
   let fs = features cl
   tt <- evalAlways $ fsTabbedTheme fs
-  io $ putStrLn "tabbed theme started"
-  -- io $ hFlush stdout
-  -- io $ print =<< readCreateProcessWithExitCode (proc "echo" ["hi"]) ""
   startDBusInterfaces fs
-  io $ putStrLn "dbus started"
-  -- io $ hFlush stdout
   (xmobarHandle, ts) <- startChildDaemons fs
-  io $ putStrLn "child daemons started"
-  -- io $ hFlush stdout
   startRemovableMon fs
-  io $ putStrLn "removemon started"
-  -- io $ hFlush stdout
   startPowerMon fs
-  io $ putStrLn "powermon started"
-  -- io $ hFlush stdout
   dws <- startDynWorkspaces fs
-  io $ putStrLn "dyn workspace started"
-  -- io $ hFlush stdout
   -- fb <- evalAlways $ fsFontBuilder features
   kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
-  io $ putStrLn "keys started"
-  -- io $ hFlush stdout
   sk <- evalAlways $ fsShowKeys fs
-  io $ putStrLn "showkeys started"
-  -- io $ hFlush stdout
   ha <- evalAlways $ fsACPIHandler fs
-  io $ putStrLn "acpi handler started"
-  -- io $ hFlush stdout
   return $ ewmh
     $ addKeymap dws sk kbs
     $ docks
@@ -207,9 +185,7 @@ evalConf db@DBusState { dbSysClient = cl } = do
       io $ case h of
         Just h' -> hSetBuffering h' LineBuffering
         Nothing -> return ()
-      --installSignalHandlers
       ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
-      -- uninstallSignalHandlers
       return (h, ThreadState (p:ps) $ maybeToList h)
     startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
                         $ dbSysClient db
@@ -315,7 +291,7 @@ vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
   [Subfeature root "windows 8 VM"]
   where
     root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage")
-      $ IOTest_ name [] $ vmExists vm
+      $ IOTest_ name [] $ io $ vmExists vm
     name = T.unwords ["test if", vm, "exists"]
     c = "VirtualBoxVM"
     vm = "win8raw"

lib/Data/Internal/Dependency.hs

@@ -126,6 +126,7 @@ import qualified DBus.Introspection      as I
 
 import           RIO                    hiding (bracket, fromString)
 import           RIO.FilePath
+import           RIO.Process            hiding (findExecutable)
 import qualified RIO.Text               as T
 
 import           System.Directory
@@ -135,7 +136,6 @@ import           System.Posix.Files
 
 import           XMonad.Core            (X, io)
 import           XMonad.Internal.IO
-import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
 import           XMonad.Internal.Theme
 
@@ -150,9 +150,10 @@ import           XMonad.Internal.Theme
 withCache :: FIO a -> IO a
 withCache x = do
   logOpts <- logOptionsHandle stderr False
+  pc <- mkDefaultProcessContext
   withLogFunc logOpts $ \f -> do
     p <- getParams
-    let s = DepStage f p
+    let s = DepStage f pc p
     runRIO s x
 
 -- | Execute an Always immediately
@@ -315,7 +316,7 @@ data DBusDependency_ c = Bus [Fulfillment] BusName
 
 -- | A dependency that only requires IO to evaluate (no payload)
 data IODependency_ = IOSystem_ [Fulfillment] SystemDependency
-  | IOTest_ T.Text [Fulfillment] (IO (Maybe Msg))
+  | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
   | forall a. IOSometimes_ (Sometimes a)
 
 -- | A system component to an IODependency
@@ -386,12 +387,15 @@ type FIO a = RIO DepStage a
 
 data DepStage = DepStage
   { dsLogFun  :: !LogFunc
+  , dsProcCxt :: !ProcessContext
   , dsParams  :: !XParams
   }
 
 instance HasLogFunc DepStage where
   logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y })
 
+instance HasProcessContext DepStage where
+  processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y })
 
 data XParams = XParams
   { xpLogLevel :: LogLevel
@@ -645,27 +649,27 @@ testIODep_ :: IODependency_ -> FIO MResult_
 testIODep_ d = memoizeMVar $ testIODepNoCache_ d
 
 testIODepNoCache_ :: IODependency_ -> FIO Result_
-testIODepNoCache_ (IOSystem_ _ s) = io $ readResult_ <$> testSysDependency s
+testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
-testIODepNoCache_ (IOTest_ _ _ t) = io $ readResult_ <$> t
+testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
 testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd)
   <$> evalSometimesMsg x
 
 --------------------------------------------------------------------------------
 -- | System Dependency Testing
 
-testSysDependency :: SystemDependency -> IO (Maybe Msg)
+testSysDependency :: SystemDependency -> FIO (Maybe Msg)
-testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
+testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing)
   <$> findExecutable bin
   where
     msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
     e = if sys then "system" else "local"
-testSysDependency (Systemd t n) = shellTest cmd msg
+testSysDependency (Systemd t n) = shellTest "systemctl" args msg
   where
     msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
-    cmd = fmtCmd "systemctl" $ ["--user" | t == UserUnit] ++ ["status", n]
+    args = ["--user" | t == UserUnit] ++ ["status", n]
-testSysDependency (Process n) = shellTest (fmtCmd "pidof" [n])
+testSysDependency (Process n) = shellTest "pidof" [n]
   $ T.unwords ["Process", singleQuote n, "not found"]
-testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
+testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
   where
     testPerm False _ _  = Nothing
     testPerm True f res = Just $ f res
@@ -679,9 +683,9 @@ testSysDependency (AccessiblePath p r w) = permMsg <$> getPermissionsSafe p
         (_, Just False)          -> mkErr "file not writable"
         _                        -> Nothing
 
-shellTest :: T.Text -> T.Text -> IO (Maybe Msg)
+shellTest :: FilePath -> [T.Text] -> T.Text -> FIO (Maybe Msg)
-shellTest cmd msg = do
+shellTest cmd args msg = do
-  (rc, _, _) <- readCreateProcessWithExitCode (shell $ T.unpack cmd) ""
+  rc <- proc cmd (T.unpack <$> args) runProcess
   return $ case rc of
     ExitSuccess -> Nothing
     _           -> Just $ Msg LevelError msg
@@ -722,19 +726,19 @@ fontDependency :: T.Text -> [Fulfillment] -> IODependency FontBuilder
 fontDependency fam ful = IORead (fontTestName fam) ful $ testFont fam
 
 fontDependency_ :: T.Text -> [Fulfillment] -> IODependency_
-fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont' fam
+fontDependency_ fam ful = IOTest_ (fontTestName fam) ful $ voidRead <$> testFont fam
 
 fontTestName :: T.Text -> T.Text
 fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
 
-testFont :: T.Text -> FIO (Result FontBuilder)
+-- testFont :: T.Text -> FIO (Result FontBuilder)
-testFont = liftIO . testFont'
+-- testFont = liftIO . testFont'
 
-testFont' :: T.Text -> IO (Result FontBuilder)
+testFont :: T.Text -> FIO (Result FontBuilder)
-testFont' fam = maybe pass (Left . (:[])) <$> shellTest cmd msg
+testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
   where
     msg = T.unwords ["font family", qFam, "not found"]
-    cmd = fmtCmd "fc-list" ["-q", qFam]
+    args = [qFam]
     qFam = singleQuote fam
     pass = Right $ PostPass (buildFont $ Just fam) []
 
@@ -781,7 +785,7 @@ readInterface n f = IORead n [] go
 
 socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
 socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
-  . socketExists'
+  . io . socketExists'
 
 socketExists' :: IO FilePath -> IO (Maybe Msg)
 socketExists' getPath = do