From 3c6dafe8bdd55f75a410c1e61a0a88d024b03d68 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 11 Nov 2021 00:11:15 -0500 Subject: [PATCH] ENH define deps in terms of 'features' --- bin/xmobar.hs | 2 +- lib/XMonad/Internal/Command/Desktop.hs | 18 +++-- lib/XMonad/Internal/Concurrent/Removable.hs | 6 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 69 ++++++++++++++----- .../DBus/Brightness/IntelBacklight.hs | 4 +- lib/XMonad/Internal/DBus/Common.hs | 13 ++++ lib/XMonad/Internal/DBus/Screensaver.hs | 47 ++++++++----- lib/XMonad/Internal/Dependency.hs | 66 +++++++++++++----- 8 files changed, 160 insertions(+), 65 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index e4a26ff..82d3ece 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -232,7 +232,7 @@ dateCmd = CmdSpec -- toJust :: a -> Bool -> Maybe a -- toJust x b = if b then Just x else Nothing -dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency +dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a dbusDep usesys bus obj iface mem = Dependency { depRequired = True, depData = d } where diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index 89c632f..6ff52f5 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -17,7 +17,7 @@ module XMonad.Internal.Command.Desktop , runVolumeUp , runVolumeMute , runToggleBluetooth - , runToggleDPMS + -- , runToggleDPMS , runToggleEthernet , runRestart , runRecompile @@ -33,7 +33,7 @@ module XMonad.Internal.Command.Desktop , runNotificationContext ) where -import Control.Monad (void) +import Control.Monad (void) import System.Directory ( createDirectoryIfMissing @@ -43,8 +43,8 @@ import System.Environment import System.FilePath import XMonad.Actions.Volume -import XMonad.Core hiding (spawn) -import XMonad.Internal.DBus.Screensaver +import XMonad.Core hiding (spawn) +-- import XMonad.Internal.DBus.Screensaver import XMonad.Internal.Dependency import XMonad.Internal.Notify import XMonad.Internal.Process @@ -93,7 +93,11 @@ runTerm :: IO MaybeX runTerm = spawnIfInstalled myTerm runTMux :: IO MaybeX -runTMux = runIfInstalled [exe myTerm, exe "tmux", exe "bash"] cmd +runTMux = evalFeature $ Feature + { ftrAction = cmd + , ftrSilent = False + , ftrChildren = [exe myTerm, exe "tmux", exe "bash"] + } where cmd = spawn $ "tmux has-session" @@ -171,8 +175,8 @@ runToggleBluetooth = runIfInstalled [exe myBluetooth] $ spawn #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } -runToggleDPMS :: X () -runToggleDPMS = io $ void callToggle +-- runToggleDPMS :: IO MaybeX +-- runToggleDPMS = io <$> evalFeature callToggle runToggleEthernet :: IO MaybeX runToggleEthernet = runIfInstalled [exe "nmcli"] $ spawn diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 7e88ae4..324b2fa 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -32,7 +32,7 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> Dependency +dbusDep :: MemberName -> Dependency (IO a) dbusDep m = Dependency { depRequired = True, depData = d } where d = DBusEndpoint @@ -43,10 +43,10 @@ dbusDep m = Dependency { depRequired = True, depData = d } , ddDbusMember = Signal_ m } -addedDep :: Dependency +addedDep :: Dependency (IO a) addedDep = dbusDep memAdded -removedDep :: Dependency +removedDep :: Dependency (IO a) removedDep = dbusDep memRemoved driveInsertedSound :: FilePath diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index c7e1db2..769f78d 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Brightness.Common , matchSignal ) where -import Control.Monad (void, when) +import Control.Monad (void) import Data.Int (Int32) @@ -45,19 +45,23 @@ data BrightnessControls = BrightnessControls , bctlDec :: MaybeExe (IO ()) } -exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b +exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b -> Client -> IO BrightnessControls -exportBrightnessControls deps bc client = do - (req, opt) <- checkInstalled deps - let callBacklight' = createInstalled req opt . callBacklight bc - when (null req) $ - exportBrightnessControls' bc client - return $ BrightnessControls - { bctlMax = callBacklight' memMax - , bctlMin = callBacklight' memMin - , bctlInc = callBacklight' memInc - , bctlDec = callBacklight' memDec - } +exportBrightnessControls deps bc client = + initControls client (brightnessExporter deps bc) controls + where + controls exporter = do + let callBacklight' = evalFeature . callBacklight bc exporter + mx <- callBacklight' memMax + mn <- callBacklight' memMin + ic <- callBacklight' memInc + dc <- callBacklight' memDec + return $ BrightnessControls + { bctlMax = mx + , bctlMin = mn + , bctlInc = ic + , bctlDec = dc + } callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c) callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do @@ -78,6 +82,30 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do -------------------------------------------------------------------------------- -- | Internal DBus Crap +-- exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () +-- exportBrightnessControls' bc client = do +-- maxval <- bcGetMax bc -- assume the max value will never change +-- let autoMethod' m f = autoMethod m $ emitBrightness bc client =<< f bc maxval +-- let funget = bcGet bc +-- export client (bcPath bc) defaultInterface +-- { interfaceName = bcInterface bc +-- , interfaceMethods = +-- [ autoMethod' memMax bcMax +-- , autoMethod' memMin bcMin +-- , autoMethod' memInc bcInc +-- , autoMethod' memDec bcDec +-- , autoMethod memGet (round <$> funget maxval :: IO Int32) +-- ] +-- } + +brightnessExporter :: RealFrac b => [Dependency (IO ())] + -> BrightnessConfig a b -> Client -> Feature (IO ()) (IO ()) +brightnessExporter deps bc client = Feature + { ftrAction = exportBrightnessControls' bc client + , ftrSilent = False + , ftrChildren = deps + } + exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () exportBrightnessControls' bc client = do maxval <- bcGetMax bc -- assume the max value will never change @@ -100,9 +128,18 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = where sig = signal p i memCur -callBacklight :: BrightnessConfig a b -> MemberName -> IO () -callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem = - void $ callMethod $ methodCall p i mem +-- callBacklight :: BrightnessConfig a b -> MemberName -> IO () +-- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem = +-- void $ callMethod $ methodCall p i mem + +callBacklight :: BrightnessConfig a b -> Feature (IO ()) (IO ()) -> MemberName + -> Feature (IO ()) (IO ()) +callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem = + Feature + { ftrAction = void $ callMethod $ methodCall p i mem + , ftrSilent = False + , ftrChildren = [SubFeature exporter] + } bodyGetBrightness :: Num a => [Variant] -> Maybe a bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 64c92b8..a509ef0 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -113,10 +113,10 @@ intelBacklightConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -curFileDep :: Dependency +curFileDep :: Dependency (IO a) curFileDep = pathRW curFile -maxFileDep :: Dependency +maxFileDep :: Dependency (IO a) maxFileDep = pathR maxFile exportIntelBacklight :: Client -> IO BrightnessControls diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index b3234b1..72b1d34 100644 --- a/lib/XMonad/Internal/DBus/Common.hs +++ b/lib/XMonad/Internal/DBus/Common.hs @@ -6,11 +6,14 @@ module XMonad.Internal.DBus.Common , callMethod' , addMatchCallback , xmonadBus + , initControls ) where import DBus import DBus.Client +import XMonad.Internal.Dependency + xmonadBus :: BusName xmonadBus = busName_ "org.xmonad" @@ -36,3 +39,13 @@ addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler addMatchCallback rule cb = do client <- connectSession addMatch client rule $ cb . signalBody + +initControls :: Client -> (Client -> Feature (IO ()) (IO ())) + -> (Feature (IO ()) (IO ()) -> IO a) -> IO a +initControls client exporter controls = do + let x = exporter client + e <- evalFeature x + case e of + (Installed c _) -> c + _ -> return () + controls x diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index d98b12e..431c589 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Screensaver , SSControls(..) ) where -import Control.Monad (void, when) +import Control.Monad (void) import DBus import DBus.Client @@ -31,7 +31,7 @@ type SSState = Bool -- true is enabled ssExecutable :: String ssExecutable = "xset" -ssDep :: Dependency +ssDep :: Dependency (IO a) ssDep = exe ssExecutable toggle :: IO SSState @@ -100,24 +100,35 @@ bodyGetCurrentState _ = Nothing newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) } exportScreensaver :: Client -> IO SSControls -exportScreensaver client = do - (req, opt) <- checkInstalled [ssDep] - when (null req) $ - exportScreensaver' client - return $ SSControls { ssToggle = createInstalled req opt callToggle } +exportScreensaver client = initControls client exportScreensaver' controls + where + controls exporter = do + t <- evalFeature $ callToggle exporter + return $ SSControls { ssToggle = t } -exportScreensaver' :: Client -> IO () -exportScreensaver' client = do - export client ssPath defaultInterface - { interfaceName = interface - , interfaceMethods = - [ autoMethod memToggle $ emitState client =<< toggle - , autoMethod memQuery query - ] - } +exportScreensaver' :: Client -> Feature (IO ()) (IO ()) +exportScreensaver' client = Feature + { ftrAction = cmd + , ftrSilent = False + , ftrChildren = [ssDep] + } + where + cmd = export client ssPath defaultInterface + { interfaceName = interface + , interfaceMethods = + [ autoMethod memToggle $ emitState client =<< toggle + , autoMethod memQuery query + ] + } -callToggle :: IO () -callToggle = void $ callMethod $ methodCall ssPath interface memToggle +callToggle :: Feature (IO ()) (IO ()) -> Feature (IO ()) (IO ()) +callToggle exporter = Feature + { ftrAction = cmd + , ftrSilent = False + , ftrChildren = [SubFeature exporter] + } + where + cmd = void $ callMethod $ methodCall ssPath interface memToggle callQuery :: IO (Maybe SSState) callQuery = do diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index be79041..6edf52d 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -10,6 +10,8 @@ module XMonad.Internal.Dependency , DependencyData(..) , DBusMember(..) , MaybeX + , Feature(..) + , evalFeature , exe , systemUnit , userUnit @@ -80,43 +82,69 @@ data DependencyData = Executable String | Systemd UnitType String deriving (Eq, Show) -data Dependency = Dependency +-- data Dependency = Dependency +-- { depRequired :: Bool +-- , depData :: DependencyData +-- } +-- deriving (Eq, Show) + +data Dependency a = SubFeature (Feature a a) + | Dependency { depRequired :: Bool , depData :: DependencyData - } - deriving (Eq, Show) + } deriving (Eq, Show) -exe :: String -> Dependency +data Feature a b = Feature + { ftrAction :: a + , ftrSilent :: Bool + , ftrChildren :: [Dependency b] + } deriving (Eq, Show) + +evalFeature :: Feature a b -> IO (MaybeExe a) +evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do + c' <- concat <$> mapM go c + return $ case foldl groupResult ([], []) c' of + ([], opt) -> Installed a opt + (req, opt) -> if s then Ignore else Missing req opt + where + go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs + go Dependency { depRequired = r, depData = d } = do + i <- depInstalled d + return [(r, d) | not i ] + groupResult (x, y) (True, z) = (z:x, y) + groupResult (x, y) (False, z) = (x, z:y) + +exe :: String -> Dependency a exe n = Dependency { depRequired = True , depData = Executable n } -unit :: UnitType -> String -> Dependency +unit :: UnitType -> String -> Dependency a unit t n = Dependency { depRequired = True , depData = Systemd t n } -path :: Bool -> Bool -> String -> Dependency +path :: Bool -> Bool -> String -> Dependency a path r w n = Dependency { depRequired = True , depData = AccessiblePath n r w } -pathR :: String -> Dependency +pathR :: String -> Dependency a pathR = path True False -pathW :: String -> Dependency +pathW :: String -> Dependency a pathW = path False True -pathRW :: String -> Dependency +pathRW :: String -> Dependency a pathRW = path True True -systemUnit :: String -> Dependency +systemUnit :: String -> Dependency a systemUnit = unit SystemUnit -userUnit :: String -> Dependency +userUnit :: String -> Dependency a userUnit = unit UserUnit -- TODO this is poorly named. This actually represents an action that has @@ -210,7 +238,7 @@ depInstalled DBusEndpoint { ddDbusBus = b , ddDbusMember = m } = dbusInstalled b s o i m -checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData]) +checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData]) checkInstalled = fmap go . filterMissing where go = join (***) (fmap depData) . partition depRequired @@ -218,14 +246,16 @@ checkInstalled = fmap go . filterMissing createInstalled :: [DependencyData] -> [DependencyData] -> a -> MaybeExe a createInstalled req opt x = if null req then Installed x opt else Missing req opt -filterMissing :: [Dependency] -> IO [Dependency] +filterMissing :: [Dependency a] -> IO [Dependency a] filterMissing = filterM (fmap not . depInstalled . depData) --- runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a)) -runIfInstalled :: [Dependency] -> a -> IO (MaybeExe a) -runIfInstalled ds x = do - (req, opt) <- checkInstalled ds - return $ createInstalled req opt x +runIfInstalled :: [Dependency a] -> b -> IO (MaybeExe b) +runIfInstalled ds x = evalFeature $ + Feature + { ftrAction = x + , ftrSilent = False + , ftrChildren = ds + } spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ())) spawnIfInstalled n = runIfInstalled [exe n] $ spawn n