WIP use unliftio everywhere-ish

bin/xmobar.hs

@@ -56,17 +56,20 @@ main = getArgs >>= parse
 parse :: [String] -> IO ()
 parse []         = run
 parse ["--deps"] = withCache printDeps
-parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
+parse ["--test"] = withCache $ do
+  db <- connectDBus
+  void $ evalConfig db
 parse _          = usage
 
 run :: IO ()
-run = do
+run =
+  withCache $ do
     db <- connectDBus
-  c <- withCache $ evalConfig db
+    c <- evalConfig db
     disconnectDBus db
     -- this is needed to see any printed messages
-  hFlush stdout
+    liftIO $ hFlush stdout
-  xmobar c
+    liftIO $ xmobar c
 
 evalConfig :: DBusState -> FIO Config
 evalConfig db = do
@@ -78,10 +81,10 @@ evalConfig db = do
 
 printDeps :: FIO ()
 printDeps = do
-  db <- io connectDBus
+  db <- connectDBus
   let ps = sort $ nub $ fmap showFulfillment $ concatMap dumpFeature $ allFeatures db
   io $ mapM_ (putStrLn . T.unpack) ps
-  io $ disconnectDBus db
+  disconnectDBus db
 
 usage :: IO ()
 usage = putStrLn $ intercalate "\n"

bin/xmonad.hs

@@ -8,12 +8,8 @@
 
 module Main (main) where
 
-import           Control.Monad
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
-import           Data.List
-import           Data.Maybe
 import           Data.Monoid
 import           Data.Text.IO                                   (hPutStrLn)
 
@@ -23,6 +19,7 @@ import           Graphics.X11.Xlib.Extras
 
 import           RIO
 import           RIO.Directory
+import           RIO.List
 import           RIO.Process
 import qualified RIO.Text                                       as T
 
@@ -204,7 +201,7 @@ startChildDaemons :: FeatureSet -> FIO [Process () () ()]
 startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs)
 
 withDBusX :: (DBusState -> FIO a) -> FIO a
-withDBusX = bracket (io connectDBusX) cleanup
+withDBusX = bracket connectDBusX cleanup
   where
     cleanup db = do
       logInfo "unregistering xmonad from DBus"
@@ -226,7 +223,7 @@ withXmobar = bracket startXmobar cleanup
 
 printDeps :: FIO ()
 printDeps = do
-  db <- io connectDBus
+  db <- connectDBus
   (i, f, d) <- allFeatures db
   io $ mapM_ (putStrLn . T.unpack)
     $ fmap showFulfillment

lib/Data/Internal/DBus.hs

@@ -27,13 +27,8 @@ module Data.Internal.DBus
   , bodyToMaybe
   ) where
 
-import           Control.Exception
+import           RIO
-import           Control.Monad
+import qualified RIO.Map     as M
-
-import           Data.Bifunctor
-import qualified Data.Map.Strict   as M
-import           Data.Maybe
-
 import qualified RIO.Text    as T
 
 import           DBus
@@ -45,23 +40,38 @@ import           DBus.Client
 class SafeClient c where
   toClient :: c -> Client
 
-  getDBusClient :: IO (Maybe c)
+  getDBusClient
+    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+    => m (Maybe c)
 
-  disconnectDBusClient :: c -> IO ()
+  disconnectDBusClient
-  disconnectDBusClient = disconnect . toClient
+    :: (MonadUnliftIO m)
+    => c
+    -> m ()
+  disconnectDBusClient = liftIO . disconnect . toClient
 
-  withDBusClient :: (c -> IO a) -> IO (Maybe a)
+  withDBusClient
+    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+    => (c -> m a)
+    -> m (Maybe a)
+  -- TODO bracket
   withDBusClient f = do
     client <- getDBusClient
     forM client $ \c -> do
       r <- f c
-      disconnect (toClient c)
+      liftIO $ disconnect (toClient c)
       return r
 
-  withDBusClient_ :: (c -> IO ()) -> IO ()
+  withDBusClient_
+    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+    => (c -> m ())
+    -> m ()
   withDBusClient_ = void . withDBusClient
 
-  fromDBusClient :: (c -> a) -> IO (Maybe a)
+  fromDBusClient
+    :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+    => (c -> a)
+    -> m (Maybe a)
   fromDBusClient f = withDBusClient (return . f)
 
 newtype SysClient = SysClient Client
@@ -69,20 +79,25 @@ newtype SysClient = SysClient Client
 instance SafeClient SysClient where
   toClient (SysClient cl) = cl
 
-  getDBusClient = fmap SysClient <$> getDBusClient' True
+  getDBusClient = fmap SysClient <$> getDBusClient_ True
 
 newtype SesClient = SesClient Client
 
 instance SafeClient SesClient where
   toClient (SesClient cl) = cl
 
-  getDBusClient = fmap SesClient <$> getDBusClient' False
+  getDBusClient = fmap SesClient <$> getDBusClient_ False
 
-getDBusClient' :: Bool -> IO (Maybe Client)
+getDBusClient_
-getDBusClient' sys = do
+  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
-  res <- try $ if sys then connectSystem else connectSession
+  => Bool
+  -> m (Maybe Client)
+getDBusClient_ sys = do
+  res <- try $ liftIO $ if sys then connectSystem else connectSession
   case res of
-    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
+    Left e  -> do
+      logError $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
+      return Nothing
     Right c -> return $ Just c
 
 --------------------------------------------------------------------------------
@@ -90,12 +105,14 @@ getDBusClient' sys = do
 
 type MethodBody = Either T.Text [Variant]
 
-callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
+callMethod' :: (MonadIO m, SafeClient c) => c -> MethodCall -> m MethodBody
-callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
+callMethod' cl =
+  liftIO
+  . fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
   . call (toClient cl)
 
-callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
+callMethod :: (MonadIO m, SafeClient c) => c -> BusName -> ObjectPath -> InterfaceName
-  -> MemberName -> IO MethodBody
+  -> MemberName -> m MethodBody
 callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
 
 methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
@@ -108,7 +125,7 @@ methodCallBus b p i m = (methodCall p i m)
 dbusInterface :: InterfaceName
 dbusInterface = interfaceName_ "org.freedesktop.DBus"
 
-callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
+callGetNameOwner :: (MonadIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
 callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
   where
     mc = (methodCallBus dbusName dbusPath dbusInterface mem)
@@ -129,9 +146,14 @@ bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 type SignalCallback = [Variant] -> IO ()
 
-addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
+addMatchCallback
-  -> IO SignalHandler
+  :: (MonadIO m, SafeClient c)
-addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
+  => MatchRule
+  -> SignalCallback
+  -> c
+  -> m SignalHandler
+addMatchCallback rule cb cl =
+  liftIO $ addMatch (toClient cl) rule $ cb . signalBody
 
 matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
   -> Maybe MemberName -> MatchRule
@@ -142,8 +164,14 @@ matchSignal b p i m = matchAny
   , matchMember = m
   }
 
-matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
+matchSignalFull
-  -> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
+  :: (MonadIO m, SafeClient c)
+  => c
+  -> BusName
+  -> Maybe ObjectPath
+  -> Maybe InterfaceName
+  -> Maybe MemberName
+  -> m (Maybe MatchRule)
 matchSignalFull client b p i m =
   fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
 
@@ -156,23 +184,29 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
-callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
+callPropertyGet :: (MonadIO m, SafeClient c) => BusName -> ObjectPath -> InterfaceName
-  -> MemberName -> c -> IO [Variant]
+  -> MemberName -> c -> m [Variant]
-callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
+callPropertyGet bus path iface property cl =
+  liftIO
+  $ fmap (either (const []) (:[]))
   $ getProperty (toClient cl) $ methodCallBus bus path iface property
 
 matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
 matchProperty b p =
   matchSignal b p (Just propertyInterface) (Just propertySignal)
 
-matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
+matchPropertyFull
-  -> IO (Maybe MatchRule)
+  :: (MonadIO m, SafeClient c)
+  => c
+  -> BusName
+  -> Maybe ObjectPath
+  -> m (Maybe MatchRule)
 matchPropertyFull cl b p =
   matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
 
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
-withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
+withSignalMatch :: Monad m => (Maybe a -> m ()) -> SignalMatch a -> m ()
 withSignalMatch f (Match x) = f (Just x)
 withSignalMatch f Failure   = f Nothing
 withSignalMatch _ NoMatch   = return ()
@@ -208,24 +242,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
 omInterfacesRemoved :: MemberName
 omInterfacesRemoved = memberName_ "InterfacesRemoved"
 
-callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
+callGetManagedObjects
-  -> IO ObjectTree
+  :: (MonadIO m, SafeClient c)
+  => c
+  -> BusName
+  -> ObjectPath
+  -> m ObjectTree
 callGetManagedObjects cl bus path =
   either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
   <$> callMethod cl bus path omInterface getManagedObjects
 
-addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
+addInterfaceChangedListener
-  -> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: (MonadIO m, SafeClient c)
+  => BusName
+  -> MemberName
+  -> ObjectPath
+  -> SignalCallback
+  -> c
+  -> m (Maybe SignalHandler)
 addInterfaceChangedListener bus prop path sc cl = do
   rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
   forM rule $ \r -> addMatchCallback r sc cl
 
-addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
+addInterfaceAddedListener
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: (MonadIO m, SafeClient c)
+  => BusName
+  -> ObjectPath
+  -> SignalCallback
+  -> c
+  -> m (Maybe SignalHandler)
 addInterfaceAddedListener bus =
   addInterfaceChangedListener bus omInterfacesAdded
 
-addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
+addInterfaceRemovedListener
-  -> SignalCallback -> c -> IO (Maybe SignalHandler)
+  :: (MonadIO m, SafeClient c)
+  => BusName
+  -> ObjectPath
+  -> SignalCallback
+  -> c
+  -> m (Maybe SignalHandler)
 addInterfaceRemovedListener bus =
   addInterfaceChangedListener bus omInterfacesRemoved

lib/Data/Internal/Dependency.hs

@@ -106,17 +106,9 @@ module Data.Internal.Dependency
   , shellTest
   ) where
 
-import           Control.Monad.IO.Class
-import           Control.Monad.Identity
-import           Control.Monad.Reader
-
 import           Data.Aeson            hiding (Error, Result)
 import           Data.Aeson.Key
-import           Data.Bifunctor
-import           Data.Either
 import           Data.Internal.DBus
-import           Data.List
-import           Data.Maybe
 import           Data.Yaml
 
 import           GHC.IO.Exception      (ioe_description)
@@ -125,11 +117,12 @@ import           DBus                   hiding (typeOf)
 import qualified DBus.Introspection    as I
 
 import           RIO                   hiding (bracket, fromString)
+import           RIO.Directory
 import           RIO.FilePath
+import           RIO.List
 import           RIO.Process           hiding (findExecutable)
 import qualified RIO.Text              as T
 
-import           System.Directory
 import           System.Environment
 import           System.IO.Error
 import           System.Posix.Files

lib/XMonad/Internal/Command/DMenu.hs

@@ -24,12 +24,9 @@ import           DBus
 
 import           Graphics.X11.Types
 
+import           RIO.Directory
 import qualified RIO.Text                        as T
 
-import           System.Directory
-    ( XdgDirectory (..)
-    , getXdgDirectory
-    )
 import           System.IO
 
 import           XMonad.Core                     hiding (spawn)

lib/XMonad/Internal/Command/Desktop.hs

@@ -47,11 +47,11 @@ import           Data.Internal.Dependency
 import           DBus
 
 import           RIO
+import           RIO.Directory
 import           RIO.FilePath
 import qualified RIO.Process                 as P
 import qualified RIO.Text                    as T
 
-import           System.Directory
 import           System.Environment
 import           System.Posix.User
 

lib/XMonad/Internal/Command/Power.hs

@@ -29,17 +29,15 @@ module XMonad.Internal.Command.Power
 
 import           Data.Internal.Dependency
 
-import           Data.Either
-import qualified Data.Map                    as M
-
 import           Graphics.X11.Types
 
 import           RIO
+import           RIO.Directory
 import           RIO.FilePath
+import qualified RIO.Map                     as M
 import qualified RIO.Process                 as P
 import qualified RIO.Text                    as T
 
-import           System.Directory
 import           System.IO.Error
 
 import           XMonad.Core                 hiding (spawn)

lib/XMonad/Internal/Concurrent/ClientMessage.hs

@@ -19,6 +19,7 @@ module XMonad.Internal.Concurrent.ClientMessage
   ( XMsgType(..)
   , sendXMsg
   , splitXMsg
+  , withOpenDisplay
   ) where
 
 import           Data.Char

lib/XMonad/Internal/Concurrent/DynamicWorkspaces.hs

@@ -33,17 +33,7 @@ module XMonad.Internal.Concurrent.DynamicWorkspaces
   , doSink
   ) where
 
-import           Data.List                                (deleteBy, find)
-import qualified Data.Map                                 as M
-import           Data.Maybe
-
--- import           Control.Concurrent
-import           Control.Monad
-import           Control.Monad.Reader
-
-
 import           Graphics.X11.Types
-
 import           Graphics.X11.Xlib.Atom
 import           Graphics.X11.Xlib.Display
 import           Graphics.X11.Xlib.Event
@@ -55,6 +45,8 @@ import           RIO                                      hiding
     ( Display
     , display
     )
+import           RIO.List
+import qualified RIO.Map                                  as M
 import qualified RIO.Set                                  as S
 
 import           System.Process
@@ -106,9 +98,6 @@ data WConf = WConf
 
 type W a = RIO WConf ()
 
-withOpenDisplay :: (Display -> IO a) -> IO a
-withOpenDisplay = bracket (openDisplay "") closeDisplay
-
 runWorkspaceMon :: [DynWorkspace] -> IO ()
 runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
   root <- rootWindow dpy $ defaultScreen dpy

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -12,13 +12,13 @@ module XMonad.Internal.Concurrent.VirtualBox
 
 import           Data.Internal.Dependency
 
-import           Text.XML.Light
-
 import           RIO                      hiding (try)
 import           RIO.Directory
 import           RIO.FilePath
 import qualified RIO.Text                 as T
 
+import           Text.XML.Light
+
 import           XMonad.Internal.Shell
 
 vmExists :: T.Text -> IO (Maybe Msg)

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

@@ -12,14 +12,12 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
   , blPath
   ) where
 
-import           Control.Monad                          (when)
-
-import           Data.Int                               (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
 import           DBus
 
+import           RIO
 import           RIO.FilePath
 
 import           XMonad.Internal.DBus.Brightness.Common

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

@@ -13,9 +13,6 @@ module XMonad.Internal.DBus.Brightness.Common
   , signalDep
   ) where
 
-import           Control.Monad               (void)
-
-import           Data.Int                    (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
@@ -23,6 +20,7 @@ import           DBus
 import           DBus.Client
 import qualified DBus.Introspection          as I
 
+import           RIO
 import qualified RIO.Text                    as T
 
 import           XMonad.Core                 (io)

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

@@ -12,12 +12,12 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
   , blPath
   ) where
 
-import           Data.Int                               (Int32)
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
 import           DBus
 
+import           RIO
 import           RIO.FilePath
 
 import           XMonad.Internal.DBus.Brightness.Common

lib/XMonad/Internal/DBus/Control.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
---------------------------------------------------------------------------------
 -- | High-level interface for managing XMonad's DBus
 
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module XMonad.Internal.DBus.Control
   ( Client
   , DBusState(..)
@@ -17,14 +17,15 @@ module XMonad.Internal.DBus.Control
   , dbusExporters
   ) where
 
-import           Control.Monad
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
 import           DBus
 import           DBus.Client
 
+import           RIO
+import qualified RIO.Text                                       as T
+
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Common
@@ -37,27 +38,36 @@ data DBusState = DBusState
     }
 
 -- | Connect to the DBus
-connectDBus :: IO DBusState
+connectDBus
+  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+  => m DBusState
 connectDBus = do
   ses <- getDBusClient
   sys <- getDBusClient
   return DBusState { dbSesClient = ses, dbSysClient = sys }
 
 -- | Disconnect from the DBus
-disconnectDBus :: DBusState -> IO ()
+disconnectDBus
+  :: (MonadUnliftIO m)
+  => DBusState -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
 -- | Connect to the DBus and request the XMonad name
-connectDBusX :: IO DBusState
+connectDBusX
+  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+  => m DBusState
 connectDBusX = do
   db <- connectDBus
   forM_ (dbSesClient db) requestXMonadName
   return db
 
 -- | Disconnect from DBus and release the XMonad name
-disconnectDBusX :: DBusState -> IO ()
+disconnectDBusX
+  :: (MonadUnliftIO m)
+  => DBusState
+  -> m ()
 disconnectDBusX db = do
   forM_ (dbSesClient db) releaseXMonadName
   disconnectDBus db
@@ -66,18 +76,25 @@ disconnectDBusX db = do
 dbusExporters :: [Maybe SesClient -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
-releaseXMonadName :: SesClient -> IO ()
+releaseXMonadName
-releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName
+  :: (MonadUnliftIO m)
+  => SesClient
+  -> m ()
+releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName
 
-requestXMonadName :: SesClient -> IO ()
+requestXMonadName
+  :: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
+  => SesClient
+  -> m ()
 requestXMonadName ses = do
-  res <- requestName (toClient ses) xmonadBusName []
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
   -- TODO if the client is not released on shutdown the owner will be different
   let msg | res == NamePrimaryOwner = Nothing
-          | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
+          | res == NameAlreadyOwner = Just "this process already owns bus name"
           | res == NameInQueue
-            || res == NameExists = Just $ "another process owns " ++ xn
+            || res == NameExists = Just "another process owns bus name"
-          | otherwise = Just $ "unknown error when requesting " ++ xn
+          | otherwise = Just "unknown error when requesting bus name"
-  forM_ msg putStrLn
+  forM_ msg $ \m ->
+    logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
   where
-    xn = "'" ++ formatBusName xmonadBusName ++ "'"
+    xn = T.pack $ formatBusName xmonadBusName

lib/XMonad/Internal/DBus/Removable.hs

@@ -8,15 +8,15 @@
 
 module XMonad.Internal.DBus.Removable (runRemovableMon) where
 
-import           Control.Monad
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
-import           Data.Map.Strict                 (Map, member)
 
 import           DBus
 import           DBus.Client
 
+import           RIO
+import qualified RIO.Map                         as M
+
 import           XMonad.Core                     (io)
 import           XMonad.Internal.Command.Desktop
 
@@ -60,7 +60,7 @@ driveFlag :: String
 driveFlag = "org.freedesktop.UDisks2.Drive"
 
 addedHasDrive :: [Variant] -> Bool
-addedHasDrive [_, a] = maybe False (member driveFlag)
+addedHasDrive [_, a] = maybe False (M.member driveFlag)
   (fromVariant a :: Maybe (Map String (Map String Variant)))
 addedHasDrive _ = False
 

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -14,15 +14,15 @@ module XMonad.Internal.DBus.Screensaver
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
 
-import           RIO
-
 import           DBus
 import           DBus.Client
 import qualified DBus.Introspection                       as I
 
 import           Graphics.X11.XScreenSaver
-import           Graphics.X11.Xlib.Display
 
+import           RIO
+
+import           XMonad.Internal.Concurrent.ClientMessage
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Shell
 
@@ -45,10 +45,7 @@ toggle = do
 
 query :: IO SSState
 query = do
-  -- TODO bracket the display
+  xssi <- withOpenDisplay xScreenSaverQueryInfo
-  dpy <- openDisplay ""
-  xssi <- xScreenSaverQueryInfo dpy
-  closeDisplay dpy
   return $ case xssi of
     Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
     Just XScreenSaverInfo { xssi_state = _ }                   -> True

lib/XMonad/Internal/IO.hs

@@ -25,12 +25,11 @@ module XMonad.Internal.IO
   ) where
 
 import           Data.Char
-import           Data.Text       (pack, unpack)
-import           Data.Text.IO    as T (readFile, writeFile)
 
 import           RIO
 import           RIO.Directory
 import           RIO.FilePath
+import qualified RIO.Text        as T
 
 import           System.IO.Error
 
@@ -38,7 +37,7 @@ import           System.IO.Error
 -- | read
 
 readInt :: (Read a, Integral a) => FilePath -> IO a
-readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
+readInt = fmap (read . T.unpack . T.takeWhile isDigit) . readFileUtf8
 
 readBool :: FilePath -> IO Bool
 readBool = fmap (==(1 :: Int)) . readInt
@@ -47,7 +46,7 @@ readBool = fmap (==(1 :: Int)) . readInt
 -- | write
 
 writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
-writeInt f = T.writeFile f . pack . show
+writeInt f = writeFileUtf8 f . T.pack . show
 
 writeBool :: FilePath -> Bool -> IO ()
 writeBool f b = writeInt f ((if b then 1 else 0) :: Int)

lib/XMonad/Internal/Process.hs

@@ -1,17 +0,0 @@
---------------------------------------------------------------------------------
--- | Functions for managing processes
-
-module XMonad.Internal.Process where
-
--- import           Control.Exception
--- import           Control.Monad
--- import           Control.Monad.IO.Class
-
--- import qualified RIO.Text               as T
-
--- import           System.Exit
--- import           System.IO
--- import           System.Process
-
--- import           XMonad.Core            hiding (spawn)
-

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -10,6 +10,7 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
 import           Data.Internal.DBus
 
+import           RIO
 import qualified RIO.Text              as T
 
 import           Xmobar.Plugins.Common
@@ -17,9 +18,9 @@ import           Xmobar.Plugins.Common
 startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
   -> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
 startBacklight matchSignal callGetBrightness icon cb = do
-    withDBusClientConnection cb $ \c -> do
+    withDBusClientConnection cb $ \c -> liftIO $ do
-      matchSignal display c
+      matchSignal dpy c
-      display =<< callGetBrightness c
+      dpy =<< callGetBrightness c
     where
       formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
-      display = displayMaybe cb formatBrightness
+      dpy = displayMaybe cb formatBrightness

lib/Xmobar/Plugins/Bluetooth.hs

@@ -38,19 +38,16 @@ module Xmobar.Plugins.Bluetooth
   , btDep
   ) where
 
-import           Control.Concurrent.MVar
-import           Control.Monad
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
-import           Data.List
 import           Data.List.Split
-import qualified Data.Map                    as M
-import           Data.Maybe
 
 import           DBus
 import           DBus.Client
 
+import           RIO
+import           RIO.List
+import qualified RIO.Map                     as M
 import qualified RIO.Text                    as T
 
 import           XMonad.Internal.DBus.Common
@@ -71,23 +68,24 @@ instance Exec Bluetooth where
   start (Bluetooth icons colors) cb =
     withDBusClientConnection cb $ startAdapter icons colors cb
 
-startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
+startAdapter :: MonadIO m => Icons -> Colors -> Callback -> SysClient -> m ()
 startAdapter is cs cb cl = do
   ot <- getBtObjectTree cl
+  -- TODO use RIO for this?
   state <- newMVar emptyState
-  let display = displayIcon cb (iconFormatter is cs) state
+  let dpy = displayIcon cb (iconFormatter is cs) state
-  forM_ (findAdapter ot) $ \adapter -> do
+  forM_ (findAdapter ot) $ \adapter -> liftIO $ do
     -- set up adapter
     initAdapter state adapter cl
     -- TODO this step could fail; at least warn the user...
-    void $ addAdaptorListener state display adapter cl
+    void $ addAdaptorListener state dpy adapter cl
     -- set up devices on the adapter (and listeners for adding/removing devices)
     let devices = findDevices adapter ot
-    addDeviceAddedListener state display adapter cl
+    addDeviceAddedListener state dpy adapter cl
-    addDeviceRemovedListener state display adapter cl
+    addDeviceRemovedListener state dpy adapter cl
-    forM_ devices $ \d -> addAndInitDevice state display d cl
+    forM_ devices $ \d -> addAndInitDevice state dpy d cl
     -- after setting things up, show the icon based on the initialized state
-    display
+    dpy
 
 --------------------------------------------------------------------------------
 -- | Icon Display
@@ -99,9 +97,9 @@ type IconFormatter = (Maybe Bool -> Bool -> T.Text)
 
 type Icons = (T.Text, T.Text)
 
-displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon :: MonadIO m => Callback -> IconFormatter -> MutableBtState -> m ()
 displayIcon callback formatter =
-  callback . T.unpack . uncurry formatter <=< readState
+  liftIO . callback . T.unpack . uncurry formatter <=< readState
 
 -- TODO maybe I want this to fail when any of the device statuses are Nothing
 iconFormatter :: Icons -> Colors -> IconFormatter
@@ -138,7 +136,7 @@ emptyState = BtState
   , btPowered = Nothing
   }
 
-readState :: MutableBtState -> IO (Maybe Bool, Bool)
+readState :: MonadIO m => MutableBtState -> m (Maybe Bool, Bool)
 readState state = do
   p <- readPowered state
   c <- readDevices state
@@ -161,55 +159,55 @@ adaptorHasDevice adaptor device = case splitPath device of
 splitPath :: ObjectPath -> [T.Text]
 splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
 
-getBtObjectTree :: SysClient -> IO ObjectTree
+getBtObjectTree :: MonadIO m => SysClient -> m ObjectTree
 getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener :: SignalCallback -> SysClient -> IO ()
+addBtOMListener :: MonadIO m => SignalCallback -> SysClient -> m ()
-addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
+addBtOMListener sc = liftIO . void . addInterfaceAddedListener btBus btOMPath sc
 
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceAddedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
-addDeviceAddedListener state display adapter client =
+addDeviceAddedListener state dpy adapter client =
   addBtOMListener addDevice client
   where
-    addDevice = pathCallback adapter display $ \d ->
+    addDevice = pathCallback adapter dpy $ \d ->
-      addAndInitDevice state display d client
+      addAndInitDevice state dpy d client
 
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addDeviceRemovedListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
-addDeviceRemovedListener state display adapter sys =
+addDeviceRemovedListener state dpy adapter sys =
   addBtOMListener remDevice sys
   where
-    remDevice = pathCallback adapter display $ \d -> do
+    remDevice = pathCallback adapter dpy $ \d -> do
       old <- removeDevice state d
       forM_ old $ removeMatch (toClient sys) . btDevSigHandler
 
 pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
-pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
+pathCallback adapter dpy f [device, _] = forM_ (fromVariant device) $ \d ->
-  when (adaptorHasDevice adapter d) $ f d >> display
+  when (adaptorHasDevice adapter d) $ f d >> dpy
 pathCallback _ _ _ _ = return ()
 
 --------------------------------------------------------------------------------
 -- | Adapter
 
-initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
+initAdapter :: MonadIO m => MutableBtState -> ObjectPath -> SysClient -> m ()
 initAdapter state adapter client = do
   reply <- callGetPowered adapter client
-  putPowered state $ fromSingletonVariant reply
+  liftIO $ putPowered state $ fromSingletonVariant reply
 
-matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
+matchBTProperty :: MonadIO m => SysClient -> ObjectPath -> m (Maybe MatchRule)
 matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
 
-addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
+addAdaptorListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
-addAdaptorListener state display adaptor sys = do
+addAdaptorListener state dpy adaptor sys = do
   rule <- matchBTProperty sys adaptor
   forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) sys
   where
-    procMatch = withSignalMatch $ \b -> putPowered state b >> display
+    procMatch = withSignalMatch $ \b -> liftIO $ putPowered state b >> dpy
 
-callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
+callGetPowered :: MonadIO m => ObjectPath -> SysClient -> m [Variant]
 callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
   $ memberName_ $ T.unpack adaptorPowered
 
@@ -219,7 +217,7 @@ matchPowered = matchPropertyChanged adapterInterface adaptorPowered
 putPowered :: MutableBtState -> Maybe Bool -> IO ()
 putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
 
-readPowered :: MutableBtState -> IO (Maybe Bool)
+readPowered :: MonadIO m => MutableBtState -> m (Maybe Bool)
 readPowered = fmap btPowered . readMVar
 
 adapterInterface :: InterfaceName
@@ -231,13 +229,13 @@ adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
 -- | Devices
 
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
+addAndInitDevice :: MonadUnliftIO m => MutableBtState -> IO () -> ObjectPath -> SysClient -> m ()
-addAndInitDevice state display device client = do
+addAndInitDevice state dpy device client = do
-  sh <- addDeviceListener state display device client
+  sh <- addDeviceListener state dpy device client
   -- TODO add some intelligent error messages here
   forM_ sh $ \s -> initDevice state s device client
 
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
+initDevice :: MonadUnliftIO m => MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> m ()
 initDevice state sh device sys = do
   reply <- callGetConnected device sys
   void $ insertDevice state device $
@@ -245,22 +243,22 @@ initDevice state sh device sys = do
              , btDevSigHandler = sh
              }
 
-addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
+addDeviceListener :: MonadIO m => MutableBtState -> IO () -> ObjectPath -> SysClient
-  -> IO (Maybe SignalHandler)
+  -> m (Maybe SignalHandler)
-addDeviceListener state display device sys = do
+addDeviceListener state dpy device sys = do
   rule <- matchBTProperty sys device
   forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) sys
   where
-    procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
+    procMatch = withSignalMatch $ \c -> updateDevice state device c >> dpy
 
 matchConnected :: [Variant] -> SignalMatch Bool
 matchConnected = matchPropertyChanged devInterface devConnected
 
-callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
+callGetConnected :: MonadIO m => ObjectPath -> SysClient -> m [Variant]
 callGetConnected p = callPropertyGet btBus p devInterface
   $ memberName_ (T.unpack devConnected)
 
-insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
+insertDevice :: MonadUnliftIO m => MutableBtState -> ObjectPath -> BTDevice -> m Bool
 insertDevice m device dev = modifyMVar m $ \s -> do
   let new = M.insert device dev $ btDevices s
   return (s { btDevices = new }, anyDevicesConnected new)
@@ -278,7 +276,7 @@ removeDevice m device = modifyMVar m $ \s -> do
   let devs = btDevices s
   return (s { btDevices = M.delete device devs }, M.lookup device devs)
 
-readDevices :: MutableBtState -> IO ConnectedDevices
+readDevices :: MonadIO m => MutableBtState -> m ConnectedDevices
 readDevices = fmap btDevices . readMVar
 
 devInterface :: InterfaceName

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -14,7 +14,6 @@ module Xmobar.Plugins.ClevoKeyboard
 import qualified RIO.Text                                      as T
 
 import           Xmobar
-
 import           Xmobar.Plugins.BacklightCommon
 
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard

lib/Xmobar/Plugins/Common.hs

@@ -10,18 +10,17 @@ module Xmobar.Plugins.Common
   , Callback
   , Colors(..)
   , displayMaybe
-  , displayMaybe'
+  , displayMaybe_
   , xmobarFGColor
   )
   where
 
-import           Control.Monad
-
 import           Data.Internal.DBus
 
 import           DBus
 import           DBus.Client
 
+import           RIO
 import qualified RIO.Text                as T
 
 import           XMonad.Hooks.DynamicLog (xmobarColor)
@@ -35,17 +34,21 @@ data Colors = Colors
   }
   deriving (Eq, Show, Read)
 
-startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
+startListener :: (MonadIO m, SafeClient c, IsVariant a) => MatchRule -> (c -> m [Variant])
   -> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
-  -> c -> IO ()
+  -> c -> m ()
 startListener rule getProp fromSignal toColor cb client = do
   reply <- getProp client
-  displayMaybe cb toColor $ fromSingletonVariant reply
+  displayMaybe cb (liftIO . toColor) $ fromSingletonVariant reply
   void $ addMatchCallback rule (procMatch . fromSignal) client
   where
     procMatch = procSignalMatch cb toColor
 
-procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
+procSignalMatch
+  :: Callback
+  -> (a -> IO T.Text)
+  -> SignalMatch a
+  -> IO ()
 procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
 
 colorText :: Colors -> Bool -> T.Text -> T.Text
@@ -58,11 +61,17 @@ xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
 na :: T.Text
 na = "N/A"
 
-displayMaybe :: Callback -> (a -> IO T.Text) -> Maybe a -> IO ()
+displayMaybe :: (MonadIO m) => Callback -> (a -> m T.Text) -> Maybe a -> m ()
-displayMaybe cb f = (cb . T.unpack) <=< maybe (return na) f
+displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f
 
-displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
+displayMaybe_ :: MonadIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
-displayMaybe' cb = maybe (cb $ T.unpack na)
+displayMaybe_ cb = maybe (liftIO $ cb $ T.unpack na)
 
-withDBusClientConnection :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
+withDBusClientConnection
-withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient
+  :: (SafeClient c)
+  => Callback
+  -> (c -> RIO SimpleApp ())
+  -> IO ()
+withDBusClientConnection cb f = do
+  -- TODO be more sophisticated
+  runSimpleApp $ withDBusClient_ $ displayMaybe_ cb f . Just

lib/Xmobar/Plugins/Device.hs

@@ -11,14 +11,12 @@ module Xmobar.Plugins.Device
   , devDep
   ) where
 
-import           Control.Monad
-
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
-import           Data.Word
 
 import           DBus
 
+import           RIO
 import qualified RIO.Text                        as T
 
 import           XMonad.Internal.Command.Desktop
@@ -64,9 +62,9 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
 instance Exec Device where
   alias (Device (iface, _, _)) = T.unpack iface
   start (Device (iface, text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
+    withDBusClientConnection cb $ \sys -> liftIO $ do
       path <- getDevice sys iface
-      displayMaybe' cb (listener sys) path
+      displayMaybe_ cb (listener sys) path
     where
       listener sys path = do
         rule <- matchPropertyFull sys networkManagerBus (Just path)

lib/Xmobar/Plugins/IntelBacklight.hs

@@ -14,7 +14,6 @@ module Xmobar.Plugins.IntelBacklight
 import qualified RIO.Text                                       as T
 
 import           Xmobar
-
 import           Xmobar.Plugins.BacklightCommon
 
 import           XMonad.Internal.DBus.Brightness.IntelBacklight

lib/Xmobar/Plugins/Screensaver.hs

@@ -11,6 +11,7 @@ module Xmobar.Plugins.Screensaver
   , ssAlias
   ) where
 
+import           RIO
 import qualified RIO.Text                         as T
 
 import           Xmobar
@@ -26,9 +27,9 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
   alias (Screensaver _) = T.unpack ssAlias
   start (Screensaver (text, colors)) cb = do
-    withDBusClientConnection cb $ \sys -> do
+    withDBusClientConnection cb $ \sys -> liftIO $ do
-      matchSignal display sys
+      matchSignal dpy sys
-      display =<< callQuery sys
+      dpy =<< callQuery sys
     where
-      display = displayMaybe cb $ return . (\s -> colorText colors s text)
+      dpy = displayMaybe cb $ return . (\s -> colorText colors s text)
 

lib/Xmobar/Plugins/VPN.hs

@@ -13,17 +13,15 @@ module Xmobar.Plugins.VPN
   , vpnDep
   ) where
 
-import           Control.Concurrent.MVar
-import           Control.Monad
 
 import           Data.Internal.DBus
 import           Data.Internal.Dependency
-import qualified Data.Map                        as M
-import           Data.Maybe
-import qualified Data.Set                        as S
 
 import           DBus
 
+import           RIO
+import qualified RIO.Map                         as M
+import qualified RIO.Set                         as S
 import qualified RIO.Text                        as T
 
 import           XMonad.Internal.Command.Desktop
@@ -38,11 +36,11 @@ instance Exec VPN where
   start (VPN (text, colors)) cb =
     withDBusClientConnection cb $ \c -> do
     state <- initState c
-    let display = displayMaybe cb iconFormatter . Just =<< readState state
+    let dpy = displayMaybe cb iconFormatter . Just =<< readState state
-    let signalCallback' f = f state display
+    let signalCallback' f = f state dpy
     vpnAddedListener (signalCallback' addedCallback) c
     vpnRemovedListener (signalCallback' removedCallback) c
-    display
+    liftIO dpy
     where
       iconFormatter b = return $ colorText colors b text
 
@@ -57,7 +55,7 @@ type VPNState = S.Set ObjectPath
 
 type MutableVPNState = MVar VPNState
 
-initState :: SysClient -> IO MutableVPNState
+initState :: MonadIO m => SysClient -> m MutableVPNState
 initState client = do
   ot <- getVPNObjectTree client
   newMVar $ findTunnels ot
@@ -65,28 +63,28 @@ initState client = do
 readState :: MutableVPNState -> IO Bool
 readState = fmap (not . null) . readMVar
 
-updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
+updateState :: MonadUnliftIO m => (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
-  -> ObjectPath -> IO ()
+  -> ObjectPath -> m ()
 updateState f state op = modifyMVar_ state $ return . f op
 
 --------------------------------------------------------------------------------
 -- | Tunnel Device Detection
 --
 
-getVPNObjectTree :: SysClient -> IO ObjectTree
+getVPNObjectTree :: MonadIO m => SysClient -> m ObjectTree
 getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
 
 findTunnels :: ObjectTree -> VPNState
 findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
 
-vpnAddedListener :: SignalCallback -> SysClient -> IO ()
+vpnAddedListener :: MonadIO m => SignalCallback -> SysClient -> m ()
 vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb
 
-vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
+vpnRemovedListener :: MonadIO m => SignalCallback -> SysClient -> m ()
 vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb
 
 addedCallback :: MutableVPNState -> IO () -> SignalCallback
-addedCallback state display [device, added] = update >> display
+addedCallback state dpy [device, added] = update >> dpy
   where
     added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
     is = M.keys $ fromMaybe M.empty added'
@@ -94,7 +92,7 @@ addedCallback state display [device, added] = update >> display
 addedCallback _ _ _                       = return ()
 
 removedCallback :: MutableVPNState -> IO () -> SignalCallback
-removedCallback state display [device, interfaces] = update >> display
+removedCallback state dpy [device, interfaces] = update >> dpy
   where
     is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
     update = updateDevice S.delete state device is