ENH use a bunch of nested feature stuff
This commit is contained in:
parent
01e991f182
commit
5907035e9d
|
@ -292,46 +292,47 @@ rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
|
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = feature "wireless status indicator" Default
|
getWireless = feature "wireless status indicator" Default
|
||||||
$ GenTree (Double wirelessCmd $ readInterface isWireless) []
|
-- TODO this is stupid
|
||||||
|
$ GenTree (Double wirelessCmd $ readInterface isWireless) (Only $ exe "ls")
|
||||||
|
|
||||||
getEthernet :: Maybe Client -> BarFeature
|
getEthernet :: Maybe Client -> BarFeature
|
||||||
getEthernet client = feature "ethernet status indicator" Default
|
getEthernet client = feature "ethernet status indicator" Default
|
||||||
$ DBusTree action client [devDep] []
|
$ DBusTree action client (Only $ fullDep devDep)
|
||||||
where
|
where
|
||||||
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
|
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = feature "battery level indicator" Default
|
getBattery = feature "battery level indicator" Default
|
||||||
$ GenTree (Single batteryCmd) [IOTest desc hasBattery]
|
$ GenTree (Single batteryCmd) (Only $ fullDep $ IOTest desc hasBattery)
|
||||||
where
|
where
|
||||||
desc = "Test if battery is present"
|
desc = "Test if battery is present"
|
||||||
|
|
||||||
getVPN :: Maybe Client -> BarFeature
|
getVPN :: Maybe Client -> BarFeature
|
||||||
getVPN client = feature "VPN status indicator" Default
|
getVPN client = feature "VPN status indicator" Default
|
||||||
$ DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
|
$ DBusTree (Single (const vpnCmd)) client $ And (Only $ fullDep vpnDep) (Only dp)
|
||||||
where
|
where
|
||||||
dp = IOTest desc vpnPresent
|
dp = fullDep $ DBusGenDep $ IOTest desc vpnPresent
|
||||||
desc = "Use nmcli to test if VPN is present"
|
desc = "Use nmcli to test if VPN is present"
|
||||||
|
|
||||||
getBt :: Maybe Client -> BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
getBt client = feature "bluetooth status indicator" Default
|
getBt client = feature "bluetooth status indicator" Default
|
||||||
$ DBusTree (Single (const btCmd)) client [btDep] []
|
$ DBusTree (Single (const btCmd)) client (Only $ fullDep btDep)
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = feature "volume level indicator" Default
|
getAlsa = feature "volume level indicator" Default
|
||||||
$ GenTree (Single alsaCmd) [Executable "alsactl"]
|
$ GenTree (Single alsaCmd) (Only $ exe "alsactl")
|
||||||
|
|
||||||
getBl :: Maybe Client -> BarFeature
|
getBl :: Maybe Client -> BarFeature
|
||||||
getBl client = feature "Intel backlight indicator" Default
|
getBl client = feature "Intel backlight indicator" Default
|
||||||
$ DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] []
|
$ DBusTree (Single (const blCmd)) client (Only $ fullDep intelBacklightSignalDep)
|
||||||
|
|
||||||
getCk :: Maybe Client -> BarFeature
|
getCk :: Maybe Client -> BarFeature
|
||||||
getCk client = feature "Clevo keyboard indicator" Default
|
getCk client = feature "Clevo keyboard indicator" Default
|
||||||
$ DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] []
|
$ DBusTree (Single (const ckCmd)) client (Only $ fullDep clevoKeyboardSignalDep)
|
||||||
|
|
||||||
getSs :: Maybe Client -> BarFeature
|
getSs :: Maybe Client -> BarFeature
|
||||||
getSs client = feature "screensaver indicator" Default
|
getSs client = feature "screensaver indicator" Default
|
||||||
$ DBusTree (Single (const ssCmd)) client [ssSignalDep] []
|
$ DBusTree (Single (const ssCmd)) client (Only $ fullDep ssSignalDep)
|
||||||
|
|
||||||
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
||||||
getAllCommands right = do
|
getAllCommands right = do
|
||||||
|
|
|
@ -122,32 +122,32 @@ run = do
|
||||||
forkIO_ = void . forkIO
|
forkIO_ = void . forkIO
|
||||||
|
|
||||||
printDeps :: IO ()
|
printDeps :: IO ()
|
||||||
printDeps = do
|
printDeps = skip
|
||||||
(i, x) <- allFeatures
|
-- (i, x) <- allFeatures
|
||||||
mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
|
-- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
|
||||||
where
|
-- where
|
||||||
extractFeatures (Feature f) = dtDeps $ ftrDepTree f
|
-- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
|
||||||
extractFeatures (ConstFeature _) = []
|
-- extractFeatures (ConstFeature _) = []
|
||||||
dtDeps (GenTree _ ds) = ds
|
-- dtDeps (GenTree _ ds) = ds
|
||||||
dtDeps (DBusTree _ _ _ ds) = ds
|
-- dtDeps (DBusTree _ _ ds) = ds
|
||||||
printDep = putStrLn . depName
|
-- printDep (FullDep d) = putStrLn . depName d
|
||||||
|
|
||||||
allFeatures :: IO ([FeatureIO], [FeatureX])
|
-- allFeatures :: IO ([FeatureIO], [FeatureX])
|
||||||
allFeatures = do
|
-- allFeatures = do
|
||||||
ses <- getDBusClient False
|
-- ses <- getDBusClient False
|
||||||
sys <- getDBusClient True
|
-- sys <- getDBusClient True
|
||||||
let db = DBusState ses sys
|
-- let db = DBusState ses sys
|
||||||
lockRes <- evalFeature runScreenLock
|
-- lockRes <- evalFeature runScreenLock
|
||||||
let lock = whenSatisfied lockRes
|
-- let lock = whenSatisfied lockRes
|
||||||
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
-- let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||||
$ externalBindings ts db lock
|
-- $ externalBindings ts db lock
|
||||||
let dbus = fmap (\f -> f ses) dbusExporters
|
-- let dbus = fmap (\f -> f ses) dbusExporters
|
||||||
let others = [runRemovableMon sys, runPowermon]
|
-- let others = [runRemovableMon sys, runPowermon]
|
||||||
forM_ ses disconnect
|
-- forM_ ses disconnect
|
||||||
forM_ sys disconnect
|
-- forM_ sys disconnect
|
||||||
return (dbus ++ others, bfs)
|
-- return (dbus ++ others, bfs)
|
||||||
where
|
-- where
|
||||||
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
-- ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn $ intercalate "\n"
|
usage = putStrLn $ intercalate "\n"
|
||||||
|
|
|
@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
||||||
-- | Exported Commands
|
-- | Exported Commands
|
||||||
|
|
||||||
runDevMenu :: FeatureX
|
runDevMenu :: FeatureX
|
||||||
runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do
|
runDevMenu = featureDefault "device manager" (Only $ exe myDmenuDevices) $ do
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||||
spawnCmd myDmenuDevices
|
spawnCmd myDmenuDevices
|
||||||
$ ["-c", c]
|
$ ["-c", c]
|
||||||
|
@ -84,11 +84,11 @@ runBTMenu = featureExeArgs "bluetooth selector" myDmenuBluetooth
|
||||||
$ "-c":themeArgs "#0044bb"
|
$ "-c":themeArgs "#0044bb"
|
||||||
|
|
||||||
runBwMenu :: FeatureX
|
runBwMenu :: FeatureX
|
||||||
runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $
|
runBwMenu = featureDefault "password manager" (Only $ exe myDmenuPasswords) $
|
||||||
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
runVPNMenu :: FeatureX
|
runVPNMenu :: FeatureX
|
||||||
runVPNMenu = featureDefault "VPN selector" [Executable myDmenuVPN] $
|
runVPNMenu = featureDefault "VPN selector" (Only $ exe myDmenuVPN) $
|
||||||
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
-- TODO this is weirdly inverted
|
-- TODO this is weirdly inverted
|
||||||
|
@ -101,7 +101,7 @@ runShowKeys x = addName "Show Keybindings" $ do
|
||||||
|
|
||||||
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
|
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
|
||||||
runDMenuShowKeys kbs =
|
runDMenuShowKeys kbs =
|
||||||
featureDefault "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do
|
featureDefault "keyboard shortcut menu" (Only $ exe myDmenuCmd) $ io $ do
|
||||||
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
||||||
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||||
where
|
where
|
||||||
|
@ -116,7 +116,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||||
|
|
||||||
runClipMenu :: FeatureX
|
runClipMenu :: FeatureX
|
||||||
runClipMenu =
|
runClipMenu =
|
||||||
featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"]
|
featureDefault "clipboard manager" (And (Only $ exe myDmenuCmd) (Only $ exe "greenclip"))
|
||||||
$ spawnCmd myDmenuCmd args
|
$ spawnCmd myDmenuCmd args
|
||||||
where
|
where
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
args = [ "-modi", "\"clipboard:greenclip print\""
|
||||||
|
|
|
@ -97,7 +97,7 @@ runTerm = featureExe "terminal" myTerm
|
||||||
runTMux :: FeatureX
|
runTMux :: FeatureX
|
||||||
runTMux = featureDefault "terminal multiplexer" deps cmd
|
runTMux = featureDefault "terminal multiplexer" deps cmd
|
||||||
where
|
where
|
||||||
deps = [Executable myTerm, Executable "tmux", Executable "bash"]
|
deps = listToAnds (exe myTerm) $ fmap exe ["tmux", "bash"]
|
||||||
cmd = spawn
|
cmd = spawn
|
||||||
$ "tmux has-session"
|
$ "tmux has-session"
|
||||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||||
|
@ -106,7 +106,7 @@ runTMux = featureDefault "terminal multiplexer" deps cmd
|
||||||
msg = "could not connect to tmux session"
|
msg = "could not connect to tmux session"
|
||||||
|
|
||||||
runCalc :: FeatureX
|
runCalc :: FeatureX
|
||||||
runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"]
|
runCalc = featureDefault "calculator" (And (Only $ exe myTerm) (Only $ exe "R"))
|
||||||
$ spawnCmd myTerm ["-e", "R"]
|
$ spawnCmd myTerm ["-e", "R"]
|
||||||
|
|
||||||
runBrowser :: FeatureX
|
runBrowser :: FeatureX
|
||||||
|
@ -153,7 +153,7 @@ playSound file = do
|
||||||
|
|
||||||
featureSound :: String -> FilePath -> X () -> X () -> FeatureX
|
featureSound :: String -> FilePath -> X () -> X () -> FeatureX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
featureDefault ("volume " ++ n ++ " control") [Executable "paplay"]
|
featureDefault ("volume " ++ n ++ " control") (Only $ exe "paplay")
|
||||||
$ pre >> playSound file >> post
|
$ pre >> playSound file >> post
|
||||||
|
|
||||||
runVolumeDown :: FeatureX
|
runVolumeDown :: FeatureX
|
||||||
|
@ -192,7 +192,7 @@ runNotificationContext =
|
||||||
|
|
||||||
runToggleBluetooth :: FeatureX
|
runToggleBluetooth :: FeatureX
|
||||||
runToggleBluetooth =
|
runToggleBluetooth =
|
||||||
featureDefault "bluetooth toggle" [Executable myBluetooth]
|
featureDefault "bluetooth toggle" (Only $ exe myBluetooth)
|
||||||
$ spawn
|
$ spawn
|
||||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||||
#!&& "a=on"
|
#!&& "a=on"
|
||||||
|
@ -201,7 +201,7 @@ runToggleBluetooth =
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
||||||
|
|
||||||
runToggleEthernet :: FeatureX
|
runToggleEthernet :: FeatureX
|
||||||
runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"]
|
runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "nmcli")
|
||||||
$ spawn
|
$ spawn
|
||||||
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
|
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
|
||||||
#!&& "a=connect"
|
#!&& "a=connect"
|
||||||
|
@ -210,14 +210,14 @@ runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"]
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||||
|
|
||||||
runStartISyncTimer :: FeatureX
|
runStartISyncTimer :: FeatureX
|
||||||
runStartISyncTimer = featureDefault "isync timer" [userUnit "mbsync.timer"]
|
runStartISyncTimer = featureDefault "isync timer" (Only $ userUnit "mbsync.timer")
|
||||||
$ spawn
|
$ spawn
|
||||||
$ "systemctl --user start mbsync.timer"
|
$ "systemctl --user start mbsync.timer"
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
|
||||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
|
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
|
||||||
|
|
||||||
runStartISyncService :: FeatureX
|
runStartISyncService :: FeatureX
|
||||||
runStartISyncService = featureDefault "isync" [userUnit "mbsync.service"]
|
runStartISyncService = featureDefault "isync" (Only $ userUnit "mbsync.service")
|
||||||
$ spawn
|
$ spawn
|
||||||
$ "systemctl --user start mbsync.service"
|
$ "systemctl --user start mbsync.service"
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
|
||||||
|
@ -262,7 +262,7 @@ getCaptureDir = do
|
||||||
fallback = (</> ".local/share") <$> getHomeDirectory
|
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||||
|
|
||||||
runFlameshot :: String -> String -> FeatureX
|
runFlameshot :: String -> String -> FeatureX
|
||||||
runFlameshot n mode = featureDefault n [Executable myCapture]
|
runFlameshot n mode = featureDefault n (Only $ exe myCapture)
|
||||||
$ spawnCmd myCapture [mode]
|
$ spawnCmd myCapture [mode]
|
||||||
|
|
||||||
-- TODO this will steal focus from the current window (and puts it
|
-- TODO this will steal focus from the current window (and puts it
|
||||||
|
@ -280,6 +280,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: FeatureX
|
runCaptureBrowser :: FeatureX
|
||||||
runCaptureBrowser =
|
runCaptureBrowser =
|
||||||
featureDefault "screen capture browser" [Executable myImageBrowser] $ do
|
featureDefault "screen capture browser" (Only $ exe myImageBrowser) $ do
|
||||||
dir <- io getCaptureDir
|
dir <- io getCaptureDir
|
||||||
spawnCmd myImageBrowser [dir]
|
spawnCmd myImageBrowser [dir]
|
||||||
|
|
|
@ -101,7 +101,7 @@ runOptimusPrompt' = do
|
||||||
#!&& "killall xmonad"
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: FeatureX
|
runOptimusPrompt :: FeatureX
|
||||||
runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager]
|
runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager)
|
||||||
runOptimusPrompt'
|
runOptimusPrompt'
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
|
||||||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||||
-- and send ClientMessage events when it receives them
|
-- and send ClientMessage events when it receives them
|
||||||
runPowermon :: FeatureIO
|
runPowermon :: FeatureIO
|
||||||
runPowermon = featureDefault "ACPI event monitor" [pathR acpiPath] listenACPI
|
runPowermon = featureDefault "ACPI event monitor" (Only $ pathR acpiPath) listenACPI
|
||||||
|
|
||||||
-- | Handle ClientMessage event containing and ACPI event (to be used in
|
-- | Handle ClientMessage event containing and ACPI event (to be used in
|
||||||
-- Xmonad's event hook)
|
-- Xmonad's event hook)
|
||||||
|
|
|
@ -107,10 +107,10 @@ clevoKeyboardConfig = BrightnessConfig
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
stateFileDep :: Dependency
|
stateFileDep :: FullDep Dependency
|
||||||
stateFileDep = pathRW stateFile
|
stateFileDep = pathRW stateFile
|
||||||
|
|
||||||
brightnessFileDep :: Dependency
|
brightnessFileDep :: FullDep Dependency
|
||||||
brightnessFileDep = pathR brightnessFile
|
brightnessFileDep = pathR brightnessFile
|
||||||
|
|
||||||
clevoKeyboardSignalDep :: DBusDep
|
clevoKeyboardSignalDep :: DBusDep
|
||||||
|
|
|
@ -85,11 +85,14 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal DBus Crap
|
-- | Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
|
brightnessExporter :: RealFrac b => [FullDep Dependency] -> BrightnessConfig a b
|
||||||
-> Maybe Client -> FeatureIO
|
-> Maybe Client -> FeatureIO
|
||||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
|
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
|
||||||
(n ++ " exporter") Default
|
(n ++ " exporter") Default
|
||||||
$ DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps
|
$ DBusTree (Single (exportBrightnessControls' bc)) client ds
|
||||||
|
where
|
||||||
|
ds = listToAnds (fullDep $ Bus xmonadBusName)
|
||||||
|
$ fmap (fmap DBusGenDep) deps
|
||||||
|
|
||||||
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
|
||||||
exportBrightnessControls' bc client = do
|
exportBrightnessControls' bc client = do
|
||||||
|
|
|
@ -89,10 +89,10 @@ intelBacklightConfig = BrightnessConfig
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
curFileDep :: Dependency
|
curFileDep :: FullDep Dependency
|
||||||
curFileDep = pathRW curFile
|
curFileDep = pathRW curFile
|
||||||
|
|
||||||
maxFileDep :: Dependency
|
maxFileDep :: FullDep Dependency
|
||||||
maxFileDep = pathR maxFile
|
maxFileDep = pathR maxFile
|
||||||
|
|
||||||
intelBacklightSignalDep :: DBusDep
|
intelBacklightSignalDep :: DBusDep
|
||||||
|
|
|
@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
|
||||||
memRemoved :: MemberName
|
memRemoved :: MemberName
|
||||||
memRemoved = memberName_ "InterfacesRemoved"
|
memRemoved = memberName_ "InterfacesRemoved"
|
||||||
|
|
||||||
dbusDep :: MemberName -> DBusDep
|
dbusDep :: MemberName -> FullDep DBusDep
|
||||||
dbusDep m = Endpoint bus path interface $ Signal_ m
|
dbusDep m = fullDep $ Endpoint bus path interface $ Signal_ m
|
||||||
|
|
||||||
addedDep :: DBusDep
|
addedDep :: FullDep DBusDep
|
||||||
addedDep = dbusDep memAdded
|
addedDep = dbusDep memAdded
|
||||||
|
|
||||||
removedDep :: DBusDep
|
removedDep :: FullDep DBusDep
|
||||||
removedDep = dbusDep memRemoved
|
removedDep = dbusDep memRemoved
|
||||||
|
|
||||||
driveInsertedSound :: FilePath
|
driveInsertedSound :: FilePath
|
||||||
|
@ -83,4 +83,4 @@ listenDevices client = do
|
||||||
|
|
||||||
runRemovableMon :: Maybe Client -> FeatureIO
|
runRemovableMon :: Maybe Client -> FeatureIO
|
||||||
runRemovableMon client = feature "removeable device monitor" Default
|
runRemovableMon client = feature "removeable device monitor" Default
|
||||||
$ DBusTree (Single listenDevices) client [addedDep, removedDep] []
|
$ DBusTree (Single listenDevices) client $ And (Only addedDep) (Only removedDep)
|
||||||
|
|
|
@ -95,11 +95,8 @@ bodyGetCurrentState _ = Nothing
|
||||||
-- | Exported haskell API
|
-- | Exported haskell API
|
||||||
|
|
||||||
exportScreensaver :: Maybe Client -> FeatureIO
|
exportScreensaver :: Maybe Client -> FeatureIO
|
||||||
exportScreensaver client = Feature $ Feature_
|
exportScreensaver client = feature "screensaver interface" Default
|
||||||
{ ftrDepTree = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable]
|
$ DBusTree (Single cmd) client (And (Only bus) (Only ssx))
|
||||||
, ftrName = "screensaver interface"
|
|
||||||
, ftrWarning = Default
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
cmd cl = export cl ssPath defaultInterface
|
cmd cl = export cl ssPath defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
|
@ -119,6 +116,8 @@ exportScreensaver client = Feature $ Feature_
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
bus = fullDep $ Bus xmonadBusName
|
||||||
|
ssx = fullDep $ DBusGenDep $ Executable ssExecutable
|
||||||
|
|
||||||
callToggle :: Maybe Client -> FeatureIO
|
callToggle :: Maybe Client -> FeatureIO
|
||||||
callToggle =
|
callToggle =
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
@ -6,7 +7,10 @@
|
||||||
|
|
||||||
module XMonad.Internal.Dependency
|
module XMonad.Internal.Dependency
|
||||||
( MaybeAction
|
( MaybeAction
|
||||||
|
, AnyFeature(..)
|
||||||
|
, DepChoice(..)
|
||||||
, MaybeX
|
, MaybeX
|
||||||
|
, FullDep(..)
|
||||||
, DepTree(..)
|
, DepTree(..)
|
||||||
, Action(..)
|
, Action(..)
|
||||||
, DBusDep(..)
|
, DBusDep(..)
|
||||||
|
@ -37,6 +41,9 @@ module XMonad.Internal.Dependency
|
||||||
, executeFeatureWith
|
, executeFeatureWith
|
||||||
, executeFeatureWith_
|
, executeFeatureWith_
|
||||||
, depName
|
, depName
|
||||||
|
, fullDep
|
||||||
|
, exe
|
||||||
|
, listToAnds
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -44,7 +51,7 @@ import Control.Monad.Identity
|
||||||
|
|
||||||
-- import Data.Aeson
|
-- import Data.Aeson
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
import Data.Maybe
|
||||||
-- import qualified Data.Text as T
|
-- import qualified Data.Text as T
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
@ -90,7 +97,9 @@ data Feature_ a = Feature_
|
||||||
, ftrWarning :: Warning
|
, ftrWarning :: Warning
|
||||||
}
|
}
|
||||||
|
|
||||||
data Feature a = Feature (Feature_ a) | ConstFeature a
|
data Feature a = Feature (Feature_ a) (Feature a)
|
||||||
|
| NoFeature
|
||||||
|
| ConstFeature a
|
||||||
|
|
||||||
-- TODO this is silly as is, and could be made more useful by representing
|
-- TODO this is silly as is, and could be made more useful by representing
|
||||||
-- loglevels
|
-- loglevels
|
||||||
|
@ -100,8 +109,12 @@ type FeatureX = Feature (X ())
|
||||||
|
|
||||||
type FeatureIO = Feature (IO ())
|
type FeatureIO = Feature (IO ())
|
||||||
|
|
||||||
|
data AnyFeature = FX FeatureX | FIO FeatureIO
|
||||||
|
|
||||||
feature :: String -> Warning -> DepTree a -> Feature a
|
feature :: String -> Warning -> DepTree a -> Feature a
|
||||||
feature n w t = Feature $ Feature_
|
feature n w t = Feature f NoFeature
|
||||||
|
where
|
||||||
|
f = Feature_
|
||||||
{ ftrDepTree = t
|
{ ftrDepTree = t
|
||||||
, ftrName = n
|
, ftrName = n
|
||||||
, ftrWarning = w
|
, ftrWarning = w
|
||||||
|
@ -109,9 +122,11 @@ feature n w t = Feature $ Feature_
|
||||||
|
|
||||||
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
|
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
|
||||||
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
|
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
|
||||||
ioFeature (Feature f) = Feature $ f {ftrDepTree = liftIO <$> ftrDepTree f}
|
ioFeature NoFeature = NoFeature
|
||||||
|
ioFeature (Feature f r)
|
||||||
|
= Feature (f {ftrDepTree = liftIO <$> ftrDepTree f}) $ ioFeature r
|
||||||
|
|
||||||
featureDefault :: String -> [Dependency] -> a -> Feature a
|
featureDefault :: String -> DepChoice (FullDep Dependency) -> a -> Feature a
|
||||||
featureDefault n ds x = feature n Default $ GenTree (Single x) ds
|
featureDefault n ds x = feature n Default $ GenTree (Single x) ds
|
||||||
|
|
||||||
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
featureExe :: MonadIO m => String -> String -> Feature (m ())
|
||||||
|
@ -119,15 +134,15 @@ featureExe n cmd = featureExeArgs n cmd []
|
||||||
|
|
||||||
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
|
featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
|
||||||
featureExeArgs n cmd args =
|
featureExeArgs n cmd args =
|
||||||
featureDefault n [Executable cmd] $ spawnCmd cmd args
|
featureDefault n (Only $ FullDep (Right False) $ Executable cmd) $ spawnCmd cmd args
|
||||||
|
|
||||||
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
|
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
|
||||||
-> MemberName -> Maybe Client -> FeatureIO
|
-> MemberName -> Maybe Client -> FeatureIO
|
||||||
featureEndpoint name busname path iface mem client = feature name Default
|
featureEndpoint name busname path iface mem client = feature name Default
|
||||||
$ DBusTree (Single cmd) client deps []
|
$ DBusTree (Single cmd) client deps
|
||||||
where
|
where
|
||||||
cmd c = void $ callMethod c busname path iface mem
|
cmd c = void $ callMethod c busname path iface mem
|
||||||
deps = [Endpoint busname path iface $ Method_ mem]
|
deps = Only $ FullDep (Right False) $ Endpoint busname path iface $ Method_ mem
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependency Trees
|
-- | Dependency Trees
|
||||||
|
@ -136,12 +151,19 @@ featureEndpoint name busname path iface mem client = feature name Default
|
||||||
-- DBus client to evaluate (and will automatically fail if this is missing).
|
-- DBus client to evaluate (and will automatically fail if this is missing).
|
||||||
-- The former can be evaluated independently.
|
-- The former can be evaluated independently.
|
||||||
|
|
||||||
data DepTree a = GenTree (Action a) [Dependency]
|
data DepChoice a = And (DepChoice a) (DepChoice a)
|
||||||
| DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency]
|
| Or (DepChoice a) (DepChoice a)
|
||||||
|
| Only a
|
||||||
|
|
||||||
|
listToAnds :: a -> [a] -> DepChoice a
|
||||||
|
listToAnds i = foldr (And . Only) (Only i)
|
||||||
|
|
||||||
|
data DepTree a = GenTree (Action a) (DepChoice (FullDep Dependency))
|
||||||
|
| DBusTree (Action (Client -> a)) (Maybe Client) (DepChoice (FullDep DBusDep))
|
||||||
|
|
||||||
instance Functor DepTree where
|
instance Functor DepTree where
|
||||||
fmap f (GenTree a ds) = GenTree (f <$> a) ds
|
fmap f (GenTree a ds) = GenTree (f <$> a) ds
|
||||||
fmap f (DBusTree a c es ds) = DBusTree (fmap (fmap f) a) c es ds
|
fmap f (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Actions
|
-- | Actions
|
||||||
|
@ -169,9 +191,11 @@ type MaybeX = MaybeAction (X ())
|
||||||
|
|
||||||
evalFeature :: Feature a -> IO (MaybeAction a)
|
evalFeature :: Feature a -> IO (MaybeAction a)
|
||||||
evalFeature (ConstFeature x) = return $ Just x
|
evalFeature (ConstFeature x) = return $ Just x
|
||||||
evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w})) = do
|
evalFeature NoFeature = return Nothing
|
||||||
|
-- TODO actually deal with alt
|
||||||
|
evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w}) _) = do
|
||||||
procName <- getProgName
|
procName <- getProgName
|
||||||
res <- evalTree a
|
res <- evalTree =<< evalTree' a
|
||||||
either (printWarnings procName) (return . Just) res
|
either (printWarnings procName) (return . Just) res
|
||||||
where
|
where
|
||||||
printWarnings procName es = do
|
printWarnings procName es = do
|
||||||
|
@ -184,29 +208,92 @@ evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w})) =
|
||||||
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
|
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
|
||||||
bracket s = "[" ++ s ++ "]"
|
bracket s = "[" ++ s ++ "]"
|
||||||
|
|
||||||
|
mapMDepChoice :: Monad m => (a -> m a) -> (a -> Bool) -> DepChoice a -> m (DepChoice a)
|
||||||
|
mapMDepChoice f pass = fmap snd . go
|
||||||
|
where
|
||||||
|
go d@(And a b) = do
|
||||||
|
(ra, a') <- go a
|
||||||
|
if not ra then return (False, d) else do
|
||||||
|
(rb, b') <- go b
|
||||||
|
return $ if rb then (True, And a' b') else (False, d)
|
||||||
|
go d@(Or a b) = do
|
||||||
|
(ra, a') <- go a
|
||||||
|
if ra then return (True, Or a' b) else do
|
||||||
|
(rb, b') <- go b
|
||||||
|
return $ if rb then (True, Or a' b') else (False, d)
|
||||||
|
go d@(Only a) = do
|
||||||
|
a' <- f a
|
||||||
|
return $ if pass a' then (True, Only a') else (False, d)
|
||||||
|
|
||||||
|
-- foldDepChoice :: (a -> Bool) -> DepChoice a -> Bool
|
||||||
|
-- foldDepChoice get dc = case dc of
|
||||||
|
-- And a b -> go a && go b
|
||||||
|
-- Or a b -> go a || go b
|
||||||
|
-- Only a -> get a
|
||||||
|
-- where
|
||||||
|
-- go = foldDepChoice get
|
||||||
|
|
||||||
|
foldDepChoice' :: Bool -> (a -> Maybe b) -> DepChoice a -> [b]
|
||||||
|
foldDepChoice' justSucceed get = fromMaybe [] . go []
|
||||||
|
where
|
||||||
|
go acc (And a b) = Just $ andFun acc a b
|
||||||
|
go acc (Or a b) = Just $ orFun acc a b
|
||||||
|
go acc (Only a) = (:acc) <$> get a
|
||||||
|
(andFun, orFun) = if justSucceed then (and', or') else (or', and')
|
||||||
|
and' acc a b = case (go acc a, go acc b) of
|
||||||
|
(Just a', Just b') -> a' ++ b' ++ acc
|
||||||
|
(Just a', Nothing) -> a' ++ acc
|
||||||
|
(Nothing, _) -> acc
|
||||||
|
or' acc a b = fromMaybe [] (go acc a) ++ fromMaybe [] (go acc b) ++ acc
|
||||||
|
|
||||||
|
-- foldDepChoice :: DepChoice a -> (a -> Maybe b) -> [b]
|
||||||
|
-- foldDepChoice dc f = go [] dc
|
||||||
|
-- where
|
||||||
|
-- go acc d = case d of
|
||||||
|
-- And a b -> do
|
||||||
|
-- acc'@(a':_) <- go acc a
|
||||||
|
-- if pass a' then go acc' b else return acc
|
||||||
|
-- Or a b -> do
|
||||||
|
-- acc'@(a':_) <- go acc a
|
||||||
|
-- if pass a' then return [a'] else go acc' b
|
||||||
|
-- Only a -> maybe acc $ f a
|
||||||
|
|
||||||
|
-- TODO wet code
|
||||||
evalTree :: DepTree a -> IO (Either [String] a)
|
evalTree :: DepTree a -> IO (Either [String] a)
|
||||||
|
evalTree (GenTree a ds) = do
|
||||||
|
case foldDepChoice' False fullDepMsg ds of
|
||||||
|
[] -> evalAction a
|
||||||
|
es -> return $ Left es
|
||||||
|
evalTree (DBusTree a (Just client) ds) = do
|
||||||
|
case foldDepChoice' False fullDepMsg ds of
|
||||||
|
[] -> fmap (\f -> f client) <$> evalAction a
|
||||||
|
es -> return $ Left es
|
||||||
|
evalTree (DBusTree _ Nothing _) = return $ Left ["client not available"]
|
||||||
|
|
||||||
evalTree (GenTree action ds) = do
|
fullDepMsg :: FullDep a -> Maybe String
|
||||||
es <- catMaybes <$> mapM evalDependency ds
|
fullDepMsg (FullDep e _) = either Just (const Nothing) e
|
||||||
case es of
|
|
||||||
[] -> do
|
evalTree' :: DepTree a -> IO (DepTree a)
|
||||||
action' <- evalAction action
|
|
||||||
return $ case action' of
|
evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
|
||||||
Right f -> Right f
|
where
|
||||||
Left es' -> Left es'
|
eval (FullDep _ d) = do
|
||||||
es' -> return $ Left es'
|
r <- evalDependency d
|
||||||
|
return $ FullDep (maybe (Right True) Left r) d
|
||||||
|
pass (FullDep (Right True) _) = True
|
||||||
|
pass _ = True
|
||||||
|
|
||||||
|
evalTree' d@(DBusTree _ Nothing _) = return d
|
||||||
|
evalTree' (DBusTree a (Just client) ds) = DBusTree a (Just client) <$> mapMDepChoice eval pass ds
|
||||||
|
where
|
||||||
|
eval (FullDep _ d) = do
|
||||||
|
r <- eval' d
|
||||||
|
return $ FullDep (maybe (Right True) Left r) d
|
||||||
|
eval' (DBusGenDep d) = evalDependency d
|
||||||
|
eval' x = dbusDepSatisfied client x
|
||||||
|
pass (FullDep (Right True) _) = True
|
||||||
|
pass _ = True
|
||||||
|
|
||||||
evalTree (DBusTree _ Nothing _ _) = return $ Left ["client not available"]
|
|
||||||
evalTree (DBusTree action (Just client) es ds) = do
|
|
||||||
eperrors <- mapM (dbusDepSatisfied client) es
|
|
||||||
dperrors <- mapM evalDependency ds
|
|
||||||
case catMaybes (eperrors ++ dperrors) of
|
|
||||||
[] -> do
|
|
||||||
action' <- evalAction action
|
|
||||||
return $ case action' of
|
|
||||||
Right f -> Right $ f client
|
|
||||||
Left es' -> Left es'
|
|
||||||
es' -> return $ Left es'
|
|
||||||
|
|
||||||
evalAction :: Action a -> IO (Either [String] a)
|
evalAction :: Action a -> IO (Either [String] a)
|
||||||
evalAction (Single a) = return $ Right a
|
evalAction (Single a) = return $ Right a
|
||||||
|
@ -236,27 +323,36 @@ ifSatisfied _ alt = alt
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependencies (General)
|
-- | Dependencies (General)
|
||||||
|
|
||||||
|
data FullDep a = FullDep (Either String Bool) a deriving (Functor)
|
||||||
|
|
||||||
|
fullDep :: a -> FullDep a
|
||||||
|
fullDep = FullDep (Right True)
|
||||||
|
|
||||||
data Dependency = Executable String
|
data Dependency = Executable String
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| IOTest String (IO (Maybe String))
|
| IOTest String (IO (Maybe String))
|
||||||
| Systemd UnitType String
|
| Systemd UnitType String
|
||||||
|
| DepFeature AnyFeature
|
||||||
|
|
||||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||||
|
|
||||||
pathR :: String -> Dependency
|
exe :: String -> FullDep Dependency
|
||||||
pathR n = AccessiblePath n True False
|
exe = fullDep . Executable
|
||||||
|
|
||||||
pathW :: String -> Dependency
|
pathR :: String -> FullDep Dependency
|
||||||
pathW n = AccessiblePath n False True
|
pathR n = fullDep $ AccessiblePath n True False
|
||||||
|
|
||||||
pathRW :: String -> Dependency
|
pathW :: String -> FullDep Dependency
|
||||||
pathRW n = AccessiblePath n True True
|
pathW n = fullDep $ AccessiblePath n False True
|
||||||
|
|
||||||
systemUnit :: String -> Dependency
|
pathRW :: String -> FullDep Dependency
|
||||||
systemUnit = Systemd SystemUnit
|
pathRW n = fullDep $ AccessiblePath n True True
|
||||||
|
|
||||||
userUnit :: String -> Dependency
|
systemUnit :: String -> FullDep Dependency
|
||||||
userUnit = Systemd UserUnit
|
systemUnit = fullDep . Systemd SystemUnit
|
||||||
|
|
||||||
|
userUnit :: String -> FullDep Dependency
|
||||||
|
userUnit = fullDep . Systemd UserUnit
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependencies (DBus)
|
-- | Dependencies (DBus)
|
||||||
|
@ -269,7 +365,7 @@ data DBusMember = Method_ MemberName
|
||||||
data DBusDep =
|
data DBusDep =
|
||||||
Bus BusName
|
Bus BusName
|
||||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||||
deriving (Eq, Show)
|
| DBusGenDep Dependency
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dependency evaluation (General)
|
-- | Dependency evaluation (General)
|
||||||
|
@ -282,6 +378,9 @@ evalDependency (Executable n) = exeSatisfied n
|
||||||
evalDependency (IOTest _ t) = t
|
evalDependency (IOTest _ t) = t
|
||||||
evalDependency (Systemd t n) = unitSatisfied t n
|
evalDependency (Systemd t n) = unitSatisfied t n
|
||||||
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
|
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
|
||||||
|
evalDependency (DepFeature _) = undefined
|
||||||
|
-- TODO add something here to eval a nested feature's dependencies while
|
||||||
|
-- bypassing the feature itself
|
||||||
|
|
||||||
exeSatisfied :: String -> IO (Maybe String)
|
exeSatisfied :: String -> IO (Maybe String)
|
||||||
exeSatisfied x = do
|
exeSatisfied x = do
|
||||||
|
@ -374,6 +473,8 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
|
||||||
, formatBusName busname
|
, formatBusName busname
|
||||||
]
|
]
|
||||||
|
|
||||||
|
dbusDepSatisfied _ (DBusGenDep d) = evalDependency d
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Printing dependencies
|
-- | Printing dependencies
|
||||||
|
|
||||||
|
@ -410,4 +511,5 @@ depName (Systemd t n) = "systemd (" ++ tp t ++ "): " ++ n
|
||||||
tp SystemUnit = "sys"
|
tp SystemUnit = "sys"
|
||||||
tp UserUnit = "user"
|
tp UserUnit = "user"
|
||||||
depName (AccessiblePath p _ _) = "path: " ++ p
|
depName (AccessiblePath p _ _) = "path: " ++ p
|
||||||
|
depName (DepFeature _) = "feature: blablabla"
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue