From 8a217d08eb8076e13cc6d17f380ab9530383679f Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 31 Dec 2022 23:02:50 -0500
Subject: [PATCH] ENH don't use putstrln for errors on dbus startup

---
 lib/Data/Internal/DBus.hs           | 28 ++++++++++++++++++++++------
 lib/XMonad/Internal/DBus/Control.hs | 18 ++++++++++++++----
 2 files changed, 36 insertions(+), 10 deletions(-)

diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs
index f895196..888bd39 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
@@ -69,11 +80,16 @@ instance SafeClient SesClient where
 
   getDBusClient = fmap SesClient <$> getDBusClient' False
 
-getDBusClient' :: MonadUnliftIO m => Bool -> m (Maybe Client)
+getDBusClient'
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> m (Maybe Client)
 getDBusClient' 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
+      logInfo $ 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 4369b2f..e490c38 100644
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@@ -60,14 +60,22 @@ withDBusX f = withDBus $ \db -> do
       logInfo "unregistering xmonad from DBus"
       releaseXMonadName cl
 
-withDBus_ :: MonadUnliftIO m => (DBusState -> m a) -> m ()
+withDBus_
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => (DBusState -> m a)
+  -> m ()
 withDBus_ = void . withDBus
 
-withDBus :: MonadUnliftIO m => (DBusState -> m a) -> m a
+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
@@ -80,7 +88,9 @@ 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