ENH use rio in (one) interactive command

bin/xmonad.hs

@@ -123,7 +123,7 @@ run = do
           dws <- startDynWorkspaces fs
           runIO <- askRunInIO
           let cleanup = runCleanup runIO toClean db
-          kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
+          kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
           sk <- evalAlways $ fsShowKeys fs
           ha <- evalAlways $ fsACPIHandler fs
           tt <- evalAlways $ fsTabbedTheme fs
@@ -171,7 +171,7 @@ getCreateDirectories = do
         _ -> return ()
 
 data FeatureSet = FeatureSet
-  { fsKeys :: X () -> DBusState -> [KeyGroup FeatureX]
+  { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
   , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
   , fsRemovableMon :: Maybe SysClient -> SometimesIO
@@ -262,7 +262,7 @@ printDeps = withDBus_ $ \db -> do
   let mockCleanup = runCleanup runIO mockClean db
   let bfs =
         concatMap (fmap kbMaybeAction . kgBindings) $
-          externalBindings mockCleanup db
+          externalBindings runIO mockCleanup db
   let dbus =
         fmap (\f -> f $ dbSesClient db) dbusExporters
           :: [Sometimes (XIO (), XIO ())]
@@ -794,8 +794,8 @@ filterExternal = fmap go
             ]
         }
 
-externalBindings :: X () -> DBusState -> [KeyGroup FeatureX]
+externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-externalBindings cleanup db =
+externalBindings runIO cleanup db =
   [ KeyGroup
       "Launchers"
       [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
@@ -860,7 +860,7 @@ externalBindings cleanup db =
       , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
       , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
       , KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
-      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
+      , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ (liftIO . runIO) <$> callToggle ses
       , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
       ]
   ]

lib/Data/Internal/XIO.hs

@@ -221,12 +221,13 @@ type Feature a = Either (Sometimes a) (Always a)
 -- | Feature that is guaranteed to work
 -- This is composed of sub-features that are tested in order, and if all fail
 -- the fallback is a monadic action (eg a plain haskell function)
-data Always a = Always T.Text (Always_ a)
+data Always a = Always T.Text (Always_ a) deriving (Functor)
 
 -- | Feature that is guaranteed to work (inner data)
 data Always_ a
   = Option (SubfeatureRoot a) (Always_ a)
   | Always_ (FallbackRoot a)
+  deriving (Functor)
 
 -- | Root of a fallback action for an always
 -- This may either be a lone action or a function that depends on the results
@@ -235,15 +236,23 @@ data FallbackRoot a
   = FallbackAlone a
   | forall p. FallbackTree (p -> a) (FallbackStack p)
 
+instance Functor FallbackRoot where
+  fmap f (FallbackAlone a) = FallbackAlone (f a)
+  fmap f (FallbackTree g s) = FallbackTree (f . g) s
+
 -- | Always features that are used as a payload for a fallback action
 data FallbackStack p
   = FallbackBottom (Always p)
   | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
 
+instance Functor FallbackStack where
+  fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
+  fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
+
 -- | Feature that might not be present
 -- This is like an Always except it doesn't fall back on a guaranteed monadic
 -- action
-data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a)
+data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
 
 -- | Feature that might not be present (inner data)
 type Sometimes_ a = [SubfeatureRoot a]
@@ -256,6 +265,7 @@ data Subfeature f = Subfeature
   { sfData :: f
   , sfName :: T.Text
   }
+  deriving (Functor)
 
 type SubfeatureRoot a = Subfeature (Root a)
 
@@ -268,6 +278,12 @@ data Root a
   | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
   | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
 
+instance Functor Root where
+  fmap f (IORoot a t) = IORoot (f . a) t
+  fmap f (IORoot_ a t) = IORoot_ (f a) t
+  fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
+  fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
+
 -- | The dependency tree with rule to merge results when needed
 data Tree d d_ p
   = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
@@ -927,12 +943,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
 -- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
 -- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
 
--- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
--- ioRoot (IORoot a t) = IORoot (io . a) t
--- ioRoot (IORoot_ a t) = IORoot_ (io a) t
--- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
--- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-
 --------------------------------------------------------------------------------
 -- Feature constructors
 

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -124,7 +124,7 @@ exportScreensaver ses =
     bus = Bus [] xmonadBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
-callToggle :: Maybe SesClient -> SometimesX
+callToggle :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 callToggle =
   sometimesEndpoint
     "screensaver toggle"