ENH put entire runtime in rio

bin/xmonad.hs

@@ -22,6 +22,7 @@ import           Graphics.X11.Xlib.Extras
 
 import           RIO
     ( async
+    , bracket
     , handleIO
     )
 import           RIO.Process
@@ -83,7 +84,7 @@ main = getArgs >>= parse
 parse :: [String] -> IO ()
 parse []         = run
 parse ["--deps"] = withCache printDeps
-parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
+-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX
 parse _          = usage
 
 run :: IO ()
@@ -101,12 +102,54 @@ run = do
   -- signal handlers to carry over to the top.
   uninstallSignalHandlers
   hSetBuffering stdout LineBuffering
-  db <- connectDBusX
+  withCache $ do
-  conf <- withCache $ evalConf db
+    bracket (io connectDBusX) (io . disconnectDBus) $ \db -> do
-  ds <- getCreateDirectories
+      -- conf <- evalConf db
-  -- IDK why this is necessary; nothing prior to this will print if missing
+      -- ds <- io getCreateDirectories
-  -- hFlush stdout
+      -- io $ launch conf ds
-  launch conf ds
+      let sys = dbSysClient db
+      let fs = features sys
+      startDBusInterfaces db fs
+      withXmobar $ \xmobarP -> do
+        withChildDaemons fs $ \ds -> do
+          let ts = ThreadState ds (Just xmobarP)
+          startRemovableMon db fs
+          startPowerMon fs
+          dws <- startDynWorkspaces fs
+          kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
+          sk <- evalAlways $ fsShowKeys fs
+          ha <- evalAlways $ fsACPIHandler fs
+          tt <- evalAlways $ fsTabbedTheme fs
+          let conf = 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 = myLoghook xmobarP
+                      , clickJustFocuses = False
+                      , focusFollowsMouse = False
+                      , normalBorderColor = T.unpack XT.bordersColor
+                      , focusedBorderColor = T.unpack XT.selectedBordersColor
+                      }
+          dirs <- io getCreateDirectories
+          io $ launch conf dirs
+  where
+    startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs
+                        $ dbSysClient db
+    startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
+    startDynWorkspaces fs = do
+      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
+      void $ io $ async $ runWorkspaceMon dws
+      return dws
+
+startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
+startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
+  $ fsDBusExporters fs
 
 getCreateDirectories :: IO Directories
 getCreateDirectories = do
@@ -153,52 +196,67 @@ features cl = FeatureSet
   , fsDaemons = [runNetAppDaemon cl, runAutolock]
   }
 
-evalConf db@DBusState { dbSysClient = cl } = do
+-- evalConf db@DBusState { dbSysClient = cl } = do
-  -- start DBus interfaces first since many features after this test these
+--   -- start DBus interfaces first since many features after this test these
-  -- interfaces as dependencies
+--   -- interfaces as dependencies
-  let fs = features cl
+--   let fs = features cl
-  tt <- evalAlways $ fsTabbedTheme fs
+--   tt <- evalAlways $ fsTabbedTheme fs
-  startDBusInterfaces fs
+--   startDBusInterfaces fs
-  ts <- startChildDaemons fs
+--   ts <- startChildDaemons fs
-  startRemovableMon fs
+--   startRemovableMon fs
-  startPowerMon fs
+--   startPowerMon fs
-  dws <- startDynWorkspaces fs
+--   dws <- startDynWorkspaces fs
-  -- fb <- evalAlways $ fsFontBuilder features
+--   -- fb <- evalAlways $ fsFontBuilder features
-  kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
+--   kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
-  sk <- evalAlways $ fsShowKeys fs
+--   sk <- evalAlways $ fsShowKeys fs
-  ha <- evalAlways $ fsACPIHandler fs
+--   ha <- evalAlways $ fsACPIHandler fs
-  return $ ewmh
+--   return $ ewmh
-    $ addKeymap dws sk kbs
+--     $ addKeymap dws sk kbs
-    $ docks
+--     $ docks
-    $ def { terminal = myTerm
+--     $ def { terminal = myTerm
-          , modMask = myModMask
+--           , modMask = myModMask
-          , layoutHook = myLayouts tt
+--           , layoutHook = myLayouts tt
-          , manageHook = myManageHook dws
+--           , manageHook = myManageHook dws
-          , handleEventHook = myEventHook ha
+--           , handleEventHook = myEventHook ha
-          , startupHook = myStartupHook
+--           , startupHook = myStartupHook
-          , workspaces = myWorkspaces
+--           , workspaces = myWorkspaces
-          , logHook = maybe logViewports myLoghook $ tsXmobar ts
+--           , logHook = maybe logViewports myLoghook $ tsXmobar ts
-          , clickJustFocuses = False
+--           , clickJustFocuses = False
-          , focusFollowsMouse = False
+--           , focusFollowsMouse = False
-          , normalBorderColor = T.unpack XT.bordersColor
+--           , normalBorderColor = T.unpack XT.bordersColor
-          , focusedBorderColor = T.unpack XT.selectedBordersColor
+--           , focusedBorderColor = T.unpack XT.selectedBordersColor
-          }
+--           }
-  where
+--   where
-    forkIO_ = void . async
+--     forkIO_ = void . async
-    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
+--       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
-      ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs)
+  return p
-      return $ ThreadState ps $ Just p
+
-    startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs
+startChildDaemons :: FeatureSet -> FIO [ProcessHandle]
-                        $ dbSysClient db
+startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
-    startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
+
-    startDynWorkspaces fs = do
+withChildDaemons :: FeatureSet -> ([ProcessHandle] -> FIO a) -> FIO a
-      dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
+withChildDaemons fs = bracket (startChildDaemons fs) (mapM_ (io . killHandle))
-      io $ forkIO_ $ runWorkspaceMon dws
+
-      return dws
+withXmobar :: (Process Handle () () -> FIO a) -> FIO a
+withXmobar = bracket startXmobar stopProcess
 
 printDeps :: FIO ()
 printDeps = do