From 73ed6b97346af4b0df403ba9a26776e21babba27 Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 31 Dec 2022 21:03:58 -0500
Subject: [PATCH] ENH run xmonad and xmobar totally in rio

---
 bin/xmobar.hs                         | 17 ++++-----
 bin/xmonad.hs                         | 26 +++++---------
 lib/Data/Internal/DBus.hs             | 34 +++++++++++++-----
 lib/XMonad/Internal/DBus/Control.hs   | 51 ++++++++++++++++++++++++---
 lib/Xmobar/Plugins/BacklightCommon.hs |  4 +--
 lib/Xmobar/Plugins/Common.hs          |  4 +--
 6 files changed, 90 insertions(+), 46 deletions(-)

diff --git a/bin/xmobar.hs b/bin/xmobar.hs
index c43bcc2..f27de5b 100644
--- a/bin/xmobar.hs
+++ b/bin/xmobar.hs
@@ -46,17 +46,16 @@ main = getArgs >>= parse
 parse :: [String] -> IO ()
 parse [] = run
 parse ["--deps"] = withCache printDeps
-parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
+parse ["--test"] = withCache $ withDBus_ evalConfig
 parse _ = usage
 
 run :: IO ()
-run = do
-  db <- connectDBus
-  c <- withCache $ evalConfig db
-  disconnectDBus db
+run = withCache $ withDBus_ $ \db -> do
+  c <- evalConfig db
   -- this is needed to see any printed messages
-  hFlush stdout
-  xmobar c
+  liftIO $ do
+    hFlush stdout
+    xmobar c
 
 evalConfig :: DBusState -> FIO Config
 evalConfig db = do
@@ -67,11 +66,9 @@ evalConfig db = do
   return $ config bf ifs ios cs d
 
 printDeps :: FIO ()
-printDeps = do
-  db <- io connectDBus
+printDeps = withDBus_ $ \db -> do
   let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
   io $ mapM_ (putStrLn . T.unpack) ps
-  io $ disconnectDBus db
 
 usage :: IO ()
 usage =
diff --git a/bin/xmonad.hs b/bin/xmonad.hs
index b9a525a..49c12d9 100644
--- a/bin/xmonad.hs
+++ b/bin/xmonad.hs
@@ -89,7 +89,7 @@ run = do
   uninstallSignalHandlers
   hSetBuffering stdout LineBuffering
   withCache $ do
-    withDBusX $ \db -> do
+    withDBusX_ $ \db -> do
       let sys = dbSysClient db
       let fs = features sys
       startDBusInterfaces db fs
@@ -204,13 +204,6 @@ startXmobar = do
 startChildDaemons :: FeatureSet -> FIO [Process () () ()]
 startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
 
-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
@@ -226,17 +219,14 @@ withXmobar = bracket startXmobar cleanup
       io $ killNoWait p
 
 printDeps :: FIO ()
-printDeps = do
-  db <- io connectDBus
+printDeps = withDBus_ $ \db -> do
   (i, f, d) <- allFeatures db
-  io $
-    mapM_ (putStrLn . T.unpack) $
-      fmap showFulfillment $
-        sort $
-          nub $
-            concat $
-              fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
-  io $ disconnectDBus db
+  mapM_ (liftIO . putStrLn . T.unpack) $
+    fmap showFulfillment $
+      sort $
+        nub $
+          concat $
+            fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
 
 allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
 allFeatures db = do
diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs
index f895196..14b7775 100644
--- a/lib/Data/Internal/DBus.hs
+++ b/lib/Data/Internal/DBus.hs
@@ -40,19 +40,30 @@ import qualified RIO.Text as T
 class SafeClient c where
   toClient :: c -> Client
 
-  getDBusClient :: MonadUnliftIO m => m (Maybe c)
+  getDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => m (Maybe c)
 
   disconnectDBusClient :: MonadUnliftIO m => c -> m ()
   disconnectDBusClient = liftIO . disconnect . toClient
 
-  withDBusClient :: MonadUnliftIO m => (c -> m a) -> m (Maybe a)
+  withDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => (c -> m a)
+    -> m (Maybe a)
   withDBusClient f =
     bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
 
-  withDBusClient_ :: MonadUnliftIO m => (c -> m ()) -> m ()
+  withDBusClient_
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => (c -> m ())
+    -> m ()
   withDBusClient_ = void . withDBusClient
 
-  fromDBusClient :: MonadUnliftIO m => (c -> a) -> m (Maybe a)
+  fromDBusClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => (c -> a)
+    -> m (Maybe a)
   fromDBusClient f = withDBusClient (return . f)
 
 newtype SysClient = SysClient Client
@@ -60,20 +71,25 @@ newtype SysClient = SysClient Client
 instance SafeClient SysClient where
   toClient (SysClient cl) = cl
 
-  getDBusClient = fmap SysClient <$> getDBusClient' True
+  getDBusClient = fmap SysClient <$> getSomeDBusClient True
 
 newtype SesClient = SesClient Client
 
 instance SafeClient SesClient where
   toClient (SesClient cl) = cl
 
-  getDBusClient = fmap SesClient <$> getDBusClient' False
+  getDBusClient = fmap SesClient <$> getSomeDBusClient False
 
-getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
-getDBusClient' sys = do
+getSomeDBusClient
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> m (Maybe Client)
+getSomeDBusClient sys = do
   res <- try $ liftIO $ if sys then connectSystem else connectSession
   case res of
-    Left e -> liftIO $ putStrLn (clientErrorMessage e) >> return Nothing
+    Left e -> do
+      logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
+      return Nothing
     Right c -> return $ Just c
 
 --------------------------------------------------------------------------------
diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs
index 0f43ac4..f139eb4 100644
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 --------------------------------------------------------------------------------
@@ -6,6 +7,10 @@
 module XMonad.Internal.DBus.Control
   ( Client
   , DBusState (..)
+  , withDBus
+  , withDBus_
+  , withDBusX
+  , withDBusX_
   , connectDBus
   , connectDBusX
   , disconnectDBus
@@ -34,8 +39,37 @@ data DBusState = DBusState
   , dbSysClient :: Maybe SysClient
   }
 
+withDBusX_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m ()
+withDBusX_ = void . withDBusX_
+
+withDBusX
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m (Maybe a)
+withDBusX f = withDBus $ \db ->
+  -- TODO log error if this fails
+  forM (dbSesClient db) $ \ses ->
+    bracket_ (requestXMonadName ses) (releaseXMonadName ses) (f db)
+
+withDBus_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m ()
+withDBus_ = void . withDBus
+
+withDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m a
+withDBus = bracket connectDBus disconnectDBus
+
 -- | Connect to the DBus
-connectDBus :: MonadUnliftIO m => m DBusState
+connectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => m DBusState
 connectDBus = do
   ses <- getDBusClient
   sys <- getDBusClient
@@ -48,14 +82,17 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
 -- | Connect to the DBus and request the XMonad name
-connectDBusX :: MonadUnliftIO m => m DBusState
+connectDBusX :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) => m DBusState
 connectDBusX = do
   db <- connectDBus
   forM_ (dbSesClient db) requestXMonadName
   return db
 
 -- | Disconnect from DBus and release the XMonad name
-disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
+disconnectDBusX
+  :: MonadUnliftIO m
+  => DBusState
+  -> m ()
 disconnectDBusX db = do
   forM_ (dbSesClient db) releaseXMonadName
   disconnectDBus db
@@ -64,8 +101,12 @@ disconnectDBusX db = do
 dbusExporters :: [Maybe SesClient -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
-releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
+releaseXMonadName
+  :: MonadUnliftIO m
+  => SesClient
+  -> m ()
+releaseXMonadName ses = do
+  liftIO $ void $ releaseName (toClient ses) xmonadBusName
 
 requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
 requestXMonadName ses = do
diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs
index 2fd17b0..7605953 100644
--- a/lib/Xmobar/Plugins/BacklightCommon.hs
+++ b/lib/Xmobar/Plugins/BacklightCommon.hs
@@ -13,8 +13,8 @@ import Xmobar.Plugins.Common
 
 startBacklight
   :: (MonadUnliftIO m, RealFrac a)
-  => ((Maybe a -> m ()) -> SesClient -> m ())
-  -> (SesClient -> m (Maybe a))
+  => ((Maybe a -> RIO SimpleApp ()) -> SesClient -> RIO SimpleApp ())
+  -> (SesClient -> RIO SimpleApp (Maybe a))
   -> T.Text
   -> Callback
   -> m ()
diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs
index 98b9acc..1983bba 100644
--- a/lib/Xmobar/Plugins/Common.hs
+++ b/lib/Xmobar/Plugins/Common.hs
@@ -70,6 +70,6 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
-  -> (c -> m ())
+  -> (c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
+withDBusClientConnection cb f = runSimpleApp $ displayMaybe' cb f =<< getDBusClient