diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 267dc02..5841249 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} -------------------------------------------------------------------------------- -- XMonad binary @@ -98,7 +99,9 @@ run = do void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db void $ async $ void $ executeSometimes $ fsPowerMon fs dws <- startDynWorkspaces fs - kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) + runIO <- askRunInIO + let cleanup = runCleanup runIO ts db + kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup ts db) sk <- evalAlways $ fsShowKeys fs ha <- evalAlways $ fsACPIHandler fs tt <- evalAlways $ fsTabbedTheme fs @@ -151,7 +154,7 @@ getCreateDirectories = do _ -> return () data FeatureSet = FeatureSet - { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] + { fsKeys :: X () -> ThreadState -> DBusState -> [KeyGroup FeatureX] , fsDBusExporters :: [Maybe SesClient -> SometimesIO] , fsPowerMon :: SometimesIO , fsRemovableMon :: Maybe SysClient -> SometimesIO @@ -222,10 +225,11 @@ printDeps = withDBus_ $ \db -> do fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) -allFeatures db = do +allFeatures db = withRunInIO $ \runIO -> do + let cleanup = runCleanup runIO ts db let bfs = concatMap (fmap kbMaybeAction . kgBindings) $ - externalBindings ts db + externalBindings cleanup ts db let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters let others = [runRemovableMon $ dbSysClient db, runPowermon] return (dbus ++ others, Left runScreenLock : bfs, allDWs') @@ -249,11 +253,16 @@ data ThreadState = ThreadState , tsXmobar :: Maybe (Process Handle () ()) } -runCleanup :: ThreadState -> DBusState -> X () -runCleanup ts db = io $ do +runCleanup + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => (m () -> IO ()) + -> ThreadState + -> DBusState + -> X () +runCleanup runIO ts db = io $ do mapM_ killNoWait $ tsXmobar ts mapM_ killNoWait $ tsChildPIDs ts - disconnectDBusX db + liftIO $ runIO $ disconnectDBusX db -- | Kill a process (group) after xmonad has already started -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad @@ -739,8 +748,8 @@ filterExternal = fmap go ] } -externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] -externalBindings ts db = +externalBindings :: X () -> ThreadState -> DBusState -> [KeyGroup FeatureX] +externalBindings cleanup _ db = [ KeyGroup "Launchers" [ KeyBinding "" "select/launch app" $ Left runAppMenu @@ -816,7 +825,7 @@ externalBindings ts db = ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls ftrAlways n = Right . Always n . Always_ . FallbackAlone - restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) + restartf = ftrAlways "restart function" (cleanup >> runRestart) recompilef = ftrAlways "recompile function" runRecompile type MaybeX = Maybe (X ()) diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 1799442..50c2baa 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -91,7 +91,10 @@ connectDBusX = do return db -- | Disconnect from DBus and release the XMonad name -disconnectDBusX :: MonadUnliftIO m => DBusState -> m () +disconnectDBusX + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => DBusState + -> m () disconnectDBusX db = do forM_ (dbSesClient db) releaseXMonadName disconnectDBus db @@ -100,8 +103,14 @@ 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 + :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) + => SesClient + -> m () +releaseXMonadName ses = do + -- TODO this might error? + liftIO $ void $ releaseName (toClient ses) xmonadBusName + logInfo "released xmonad name" requestXMonadName :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)