ENH use new dependency framework throughout
This commit is contained in:
parent
d8a88531b0
commit
5326b49ce2
|
|
@ -239,7 +239,7 @@ dateCmd = CmdSpec
|
|||
-- which case ethernet interfaces always start with "en" and wireless
|
||||
-- interfaces always start with "wl"
|
||||
|
||||
type BarFeature = Feature CmdSpec
|
||||
type BarFeature = Sometimes CmdSpec
|
||||
|
||||
isWireless :: String -> Bool
|
||||
isWireless ('w':'l':_) = True
|
||||
|
|
@ -255,13 +255,14 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
|
|||
sysfsNet :: FilePath
|
||||
sysfsNet = "/sys/class/net"
|
||||
|
||||
readInterface :: (String -> Bool) -> IO (Either [String] String)
|
||||
readInterface :: (String -> Bool) -> IO (Either String String)
|
||||
readInterface f = do
|
||||
ns <- filter f <$> listInterfaces
|
||||
case ns of
|
||||
[] -> return $ Left ["no interfaces found"]
|
||||
[] -> return $ Left "no interfaces found"
|
||||
(x:xs) -> do
|
||||
unless (null xs) $
|
||||
-- TODO store this somehow intead of printing
|
||||
putStrLn $ "WARNING: extra interfaces found, using " ++ x
|
||||
return $ Right x
|
||||
|
||||
|
|
@ -275,66 +276,71 @@ vpnPresent = do
|
|||
where
|
||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||
|
||||
rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec]
|
||||
rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
|
||||
rightPlugins sysClient sesClient = mapM evalFeature
|
||||
[ getWireless
|
||||
, getEthernet sysClient
|
||||
, getVPN sysClient
|
||||
, getBt sysClient
|
||||
, getAlsa
|
||||
, getBattery
|
||||
, getBl sesClient
|
||||
, getCk sesClient
|
||||
, getSs sesClient
|
||||
, ConstFeature lockCmd
|
||||
, ConstFeature dateCmd
|
||||
[ Left getWireless
|
||||
, Left $ getEthernet sysClient
|
||||
, Left $ getVPN sysClient
|
||||
, Left $ getBt sysClient
|
||||
, Left getAlsa
|
||||
, Left getBattery
|
||||
, Left $ getBl sesClient
|
||||
, Left $ getCk sesClient
|
||||
, Left $ getSs sesClient
|
||||
, Right $ Always lockCmd
|
||||
, Right $ Always dateCmd
|
||||
]
|
||||
|
||||
getWireless :: BarFeature
|
||||
getWireless = feature "wireless status indicator" Default
|
||||
-- TODO this is stupid
|
||||
$ GenTree (Double wirelessCmd $ readInterface isWireless) (Only $ exe "ls")
|
||||
getWireless = sometimes1 "wireless status indicator"
|
||||
$ IOTree (Consumer wirelessCmd)
|
||||
$ Only $ IORead "get wifi interface" $ fmap Just <$> readInterface isWireless
|
||||
|
||||
getEthernet :: Maybe Client -> BarFeature
|
||||
getEthernet client = feature "ethernet status indicator" Default
|
||||
$ DBusTree action client (Only $ fullDep devDep)
|
||||
getEthernet client = sometimes1 "ethernet status indicator" $
|
||||
DBusTree (Consumer act) client deps
|
||||
where
|
||||
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
|
||||
act i = const $ ethernetCmd i
|
||||
deps = And (\_ s -> s) (Only devDep) (Only readEth)
|
||||
readEth = DBusIO $ IORead "read ethernet interface"
|
||||
$ fmap Just <$> readInterface isEthernet
|
||||
|
||||
getBattery :: BarFeature
|
||||
getBattery = feature "battery level indicator" Default
|
||||
$ GenTree (Single batteryCmd) (Only $ fullDep $ IOTest desc hasBattery)
|
||||
where
|
||||
desc = "Test if battery is present"
|
||||
getBattery = sometimesIO "battery level indicator"
|
||||
(Only $ IOTest "Test if battery is present" hasBattery)
|
||||
batteryCmd
|
||||
|
||||
getVPN :: Maybe Client -> BarFeature
|
||||
getVPN client = feature "VPN status indicator" Default
|
||||
$ DBusTree (Single (const vpnCmd)) client $ And (Only $ fullDep vpnDep) (Only dp)
|
||||
getVPN client = sometimesDBus client "VPN status indicator"
|
||||
(toAnd vpnDep test) (const vpnCmd)
|
||||
where
|
||||
dp = fullDep $ DBusGenDep $ IOTest desc vpnPresent
|
||||
desc = "Use nmcli to test if VPN is present"
|
||||
test = DBusIO $ IOTest "Use nmcli to test if VPN is present" vpnPresent
|
||||
|
||||
getBt :: Maybe Client -> BarFeature
|
||||
getBt client = feature "bluetooth status indicator" Default
|
||||
$ DBusTree (Single (const btCmd)) client (Only $ fullDep btDep)
|
||||
getBt client = sometimesDBus client "bluetooth status indicator"
|
||||
(Only btDep)
|
||||
(const btCmd)
|
||||
|
||||
getAlsa :: BarFeature
|
||||
getAlsa = feature "volume level indicator" Default
|
||||
$ GenTree (Single alsaCmd) (Only $ exe "alsactl")
|
||||
getAlsa = sometimesIO "volume level indicator"
|
||||
(Only $ Executable True "alsact")
|
||||
alsaCmd
|
||||
|
||||
getBl :: Maybe Client -> BarFeature
|
||||
getBl client = feature "Intel backlight indicator" Default
|
||||
$ DBusTree (Single (const blCmd)) client (Only $ fullDep intelBacklightSignalDep)
|
||||
getBl client = sometimesDBus client "Intel backlight indicator"
|
||||
(Only intelBacklightSignalDep)
|
||||
(const blCmd)
|
||||
|
||||
getCk :: Maybe Client -> BarFeature
|
||||
getCk client = feature "Clevo keyboard indicator" Default
|
||||
$ DBusTree (Single (const ckCmd)) client (Only $ fullDep clevoKeyboardSignalDep)
|
||||
getCk client = sometimesDBus client "Clevo keyboard indicator"
|
||||
(Only clevoKeyboardSignalDep)
|
||||
(const ckCmd)
|
||||
|
||||
getSs :: Maybe Client -> BarFeature
|
||||
getSs client = feature "screensaver indicator" Default
|
||||
$ DBusTree (Single (const ssCmd)) client (Only $ fullDep ssSignalDep)
|
||||
getSs client = sometimesDBus client "screensaver indicator"
|
||||
(Only ssSignalDep) $ const ssCmd
|
||||
|
||||
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
|
||||
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
||||
getAllCommands right = do
|
||||
let left =
|
||||
[ CmdSpec
|
||||
|
|
|
|||
118
bin/xmonad.hs
118
bin/xmonad.hs
|
|
@ -20,9 +20,6 @@ import Data.List
|
|||
, sortOn
|
||||
)
|
||||
import Data.Maybe
|
||||
( isJust
|
||||
, mapMaybe
|
||||
)
|
||||
import Data.Monoid (All (..))
|
||||
|
||||
import Graphics.X11.Types
|
||||
|
|
@ -88,15 +85,15 @@ run :: IO ()
|
|||
run = do
|
||||
db <- connectXDBus
|
||||
(h, p) <- spawnPipe "xmobar"
|
||||
executeFeature_ $ runRemovableMon $ dbSystemClient db
|
||||
executeFeatureWith_ forkIO_ runPowermon
|
||||
void $ executeSometimes $ runRemovableMon $ dbSystemClient db
|
||||
forkIO_ $ void $ executeSometimes runPowermon
|
||||
forkIO_ $ runWorkspaceMon allDWs
|
||||
let ts = ThreadState
|
||||
{ tsChildPIDs = [p]
|
||||
, tsChildHandles = [h]
|
||||
}
|
||||
lockRes <- evalFeature runScreenLock
|
||||
let lock = whenSatisfied lockRes
|
||||
lockRes <- evalSometimes runScreenLock
|
||||
let lock = fromMaybe skip lockRes
|
||||
ext <- evalExternal $ externalBindings ts db lock
|
||||
-- IDK why this is necessary; nothing prior to this line will print if missing
|
||||
hFlush stdout
|
||||
|
|
@ -127,7 +124,7 @@ printDeps = skip
|
|||
-- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
|
||||
-- where
|
||||
-- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
|
||||
-- extractFeatures (ConstFeature _) = []
|
||||
-- extractFeatures (Always _) = []
|
||||
-- dtDeps (GenTree _ ds) = ds
|
||||
-- dtDeps (DBusTree _ _ ds) = ds
|
||||
-- printDep (FullDep d) = putStrLn . depName d
|
||||
|
|
@ -540,13 +537,13 @@ data KeyGroup a = KeyGroup
|
|||
, kgBindings :: [KeyBinding a]
|
||||
}
|
||||
|
||||
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX]
|
||||
evalExternal :: [KeyGroup (FeatureX)] -> IO [KeyGroup MaybeX]
|
||||
evalExternal = mapM go
|
||||
where
|
||||
go k@KeyGroup { kgBindings = bs } =
|
||||
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs
|
||||
|
||||
evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
|
||||
evalKeyBinding :: KeyBinding (FeatureX) -> IO (KeyBinding MaybeX)
|
||||
evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
|
||||
(\f -> k { kbMaybeAction = f }) <$> evalFeature a
|
||||
|
||||
|
|
@ -560,51 +557,51 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
|
|||
(Just x) -> Just $ k{ kbMaybeAction = x }
|
||||
Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
|
||||
|
||||
externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup FeatureX]
|
||||
externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup (FeatureX)]
|
||||
externalBindings ts db lock =
|
||||
[ KeyGroup "Launchers"
|
||||
[ KeyBinding "<XF86Search>" "select/launch app" runAppMenu
|
||||
, KeyBinding "M-g" "launch clipboard manager" runClipMenu
|
||||
, KeyBinding "M-a" "launch network selector" runNetMenu
|
||||
, KeyBinding "M-w" "launch window selector" runWinMenu
|
||||
, KeyBinding "M-u" "launch device selector" runDevMenu
|
||||
, KeyBinding "M-b" "launch bitwarden selector" runBwMenu
|
||||
, KeyBinding "M-v" "launch ExpressVPN selector" runVPNMenu
|
||||
, KeyBinding "M-e" "launch bluetooth selector" runBTMenu
|
||||
, KeyBinding "M-C-e" "launch editor" runEditor
|
||||
, KeyBinding "M-C-w" "launch browser" runBrowser
|
||||
, KeyBinding "M-C-t" "launch terminal with tmux" runTMux
|
||||
, KeyBinding "M-C-S-t" "launch terminal" runTerm
|
||||
, KeyBinding "M-C-q" "launch calc" runCalc
|
||||
, KeyBinding "M-C-f" "launch file manager" runFileManager
|
||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
|
||||
, KeyBinding "M-a" "launch network selector" $ Left runNetMenu
|
||||
, KeyBinding "M-w" "launch window selector" $ Left runWinMenu
|
||||
, KeyBinding "M-u" "launch device selector" $ Left runDevMenu
|
||||
, KeyBinding "M-b" "launch bitwarden selector" $ Left runBwMenu
|
||||
, KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
|
||||
, KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
|
||||
, KeyBinding "M-C-e" "launch editor" $ Left runEditor
|
||||
, KeyBinding "M-C-w" "launch browser" $ Left runBrowser
|
||||
, KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
|
||||
, KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
|
||||
, KeyBinding "M-C-q" "launch calc" $ Left runCalc
|
||||
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
|
||||
]
|
||||
|
||||
, KeyGroup "Actions"
|
||||
[ KeyBinding "M-q" "close window" $ ConstFeature kill1
|
||||
, KeyBinding "M-r" "run program" runCmdMenu
|
||||
, KeyBinding "M-<Space>" "warp pointer" $ ConstFeature $ warpToWindow 0.5 0.5
|
||||
, KeyBinding "M-C-s" "capture area" runAreaCapture
|
||||
, KeyBinding "M-C-S-s" "capture screen" runScreenCapture
|
||||
, KeyBinding "M-C-d" "capture desktop" runDesktopCapture
|
||||
, KeyBinding "M-C-b" "browse captures" runCaptureBrowser
|
||||
[ KeyBinding "M-q" "close window" $ ftrAlways kill1
|
||||
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5
|
||||
, KeyBinding "M-C-s" "capture area" $ Left runAreaCapture
|
||||
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
|
||||
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture
|
||||
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
|
||||
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
|
||||
]
|
||||
|
||||
, KeyGroup "Multimedia"
|
||||
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" runTogglePlay
|
||||
, KeyBinding "<XF86AudioPrev>" "previous track" runPrevTrack
|
||||
, KeyBinding "<XF86AudioNext>" "next track" runNextTrack
|
||||
, KeyBinding "<XF86AudioStop>" "stop" runStopPlay
|
||||
, KeyBinding "<XF86AudioLowerVolume>" "volume down" runVolumeDown
|
||||
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" runVolumeUp
|
||||
, KeyBinding "<XF86AudioMute>" "volume mute" runVolumeMute
|
||||
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
|
||||
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
|
||||
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
|
||||
, KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
|
||||
, KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
|
||||
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
|
||||
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
|
||||
]
|
||||
|
||||
, KeyGroup "Dunst"
|
||||
[ KeyBinding "M-`" "dunst history" runNotificationHistory
|
||||
, KeyBinding "M-S-`" "dunst close" runNotificationClose
|
||||
, KeyBinding "M-M1-`" "dunst context menu" runNotificationContext
|
||||
, KeyBinding "M-C-`" "dunst close all" runNotificationCloseAll
|
||||
[ KeyBinding "M-`" "dunst history" $ Left runNotificationHistory
|
||||
, KeyBinding "M-S-`" "dunst close" $ Left runNotificationClose
|
||||
, KeyBinding "M-M1-`" "dunst context menu" $ Left runNotificationContext
|
||||
, KeyBinding "M-C-`" "dunst close all" $ Left runNotificationCloseAll
|
||||
]
|
||||
|
||||
, KeyGroup "System"
|
||||
|
|
@ -616,23 +613,28 @@ externalBindings ts db lock =
|
|||
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec
|
||||
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
||||
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
||||
, KeyBinding "M-<End>" "power menu" $ ConstFeature $ runPowerPrompt lock
|
||||
, KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt
|
||||
, KeyBinding "M-<Delete>" "lock screen" runScreenLock
|
||||
, KeyBinding "M-<End>" "power menu" $ ftrAlways $ runPowerPrompt lock
|
||||
, KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt
|
||||
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
||||
-- M-<F1> reserved for showing the keymap
|
||||
, KeyBinding "M-<F2>" "restart xmonad" $ ConstFeature (runCleanup ts db >> runRestart)
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile
|
||||
, KeyBinding "M-<F7>" "start Isync Service" runStartISyncService
|
||||
, KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer
|
||||
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl
|
||||
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
|
||||
, KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart)
|
||||
, KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile
|
||||
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
|
||||
, KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
|
||||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left runToggleBluetooth
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle cl
|
||||
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
||||
]
|
||||
]
|
||||
where
|
||||
cl = dbSessionClient db
|
||||
brightessControls ctl getter = (ioFeature . getter . ctl) cl
|
||||
ib = brightessControls intelBacklightControls
|
||||
ck = brightessControls clevoKeyboardControls
|
||||
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
||||
ib = Left . brightessControls intelBacklightControls
|
||||
ck = Left . brightessControls clevoKeyboardControls
|
||||
ftrAlways = Right . Always
|
||||
|
||||
type MaybeX = Maybe (X ())
|
||||
|
||||
type FeatureX = Feature (X ())
|
||||
|
|
|
|||
|
|
@ -15,17 +15,17 @@ module XMonad.Internal.Command.DMenu
|
|||
, runAutorandrMenu
|
||||
) where
|
||||
|
||||
import Control.Monad.Reader
|
||||
-- import Control.Monad.Reader
|
||||
|
||||
import Graphics.X11.Types
|
||||
|
||||
import System.Directory (XdgDirectory (..), getXdgDirectory)
|
||||
import System.IO
|
||||
-- import System.IO
|
||||
|
||||
import XMonad.Core hiding (spawn)
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Notify
|
||||
import XMonad.Internal.Process
|
||||
-- import XMonad.Internal.Notify
|
||||
-- import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import XMonad.Util.NamedActions
|
||||
|
||||
|
|
@ -103,27 +103,27 @@ runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
|
|||
runShowKeys _ = NamedAction (skip :: (X ()))
|
||||
-- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
|
||||
|
||||
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
|
||||
runDMenuShowKeys kbs =
|
||||
Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
|
||||
-- runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
|
||||
-- runDMenuShowKeys kbs =
|
||||
-- Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
|
||||
|
||||
runNotifyShowKeys :: X ()
|
||||
runNotifyShowKeys = spawnNotify
|
||||
$ defNoteError { body = Just $ Text "could not display keymap" }
|
||||
-- runNotifyShowKeys :: X ()
|
||||
-- runNotifyShowKeys = spawnNotify
|
||||
-- $ defNoteError { body = Just $ Text "could not display keymap" }
|
||||
|
||||
runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
|
||||
runDMenuShowKeys' kbs = Subfeature
|
||||
{ sfName = "keyboard shortcut menu"
|
||||
, sfTree = IOTree (Standalone act) deps
|
||||
, sfLevel = Warn
|
||||
}
|
||||
where
|
||||
deps = Only $ Executable True myDmenuCmd
|
||||
act = io $ do
|
||||
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
||||
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
||||
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
|
||||
-- runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
|
||||
-- runDMenuShowKeys' kbs = Subfeature
|
||||
-- { sfName = "keyboard shortcut menu"
|
||||
-- , sfTree = IOTree (Standalone act) deps
|
||||
-- , sfLevel = Warn
|
||||
-- }
|
||||
-- where
|
||||
-- deps = Only $ Executable True myDmenuCmd
|
||||
-- act = io $ do
|
||||
-- (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
|
||||
-- forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
|
||||
-- cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
||||
-- ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
|
||||
|
||||
runCmdMenu :: SometimesX
|
||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||
|
|
|
|||
|
|
@ -107,13 +107,13 @@ clevoKeyboardConfig = BrightnessConfig
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Exported haskell API
|
||||
|
||||
stateFileDep :: IODependency a p
|
||||
stateFileDep :: IODependency p
|
||||
stateFileDep = pathRW stateFile
|
||||
|
||||
brightnessFileDep :: IODependency a p
|
||||
brightnessFileDep :: IODependency p
|
||||
brightnessFileDep = pathR brightnessFile
|
||||
|
||||
clevoKeyboardSignalDep :: DBusDependency RawBrightness p
|
||||
clevoKeyboardSignalDep :: DBusDependency RawBrightness
|
||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||
|
||||
exportClevoKeyboard :: Maybe Client -> SometimesIO
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
|
|||
either (const Nothing) bodyGetBrightness
|
||||
<$> callMethod client xmonadBusName p i memGet
|
||||
|
||||
signalDep :: BrightnessConfig a b -> DBusDependency a p
|
||||
signalDep :: BrightnessConfig a b -> DBusDependency m
|
||||
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
||||
Endpoint xmonadBusName p i $ Signal_ memCur
|
||||
|
||||
|
|
@ -85,7 +85,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Internal DBus Crap
|
||||
|
||||
brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)]
|
||||
brightnessExporter :: RealFrac b => [IODependency (Maybe x)]
|
||||
-> BrightnessConfig a b -> Maybe Client -> SometimesIO
|
||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
||||
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
|
||||
|
|
|
|||
|
|
@ -89,13 +89,13 @@ intelBacklightConfig = BrightnessConfig
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Exported haskell API
|
||||
|
||||
curFileDep :: IODependency a p
|
||||
curFileDep :: IODependency p
|
||||
curFileDep = pathRW curFile
|
||||
|
||||
maxFileDep :: IODependency a p
|
||||
maxFileDep :: IODependency p
|
||||
maxFileDep = pathR maxFile
|
||||
|
||||
intelBacklightSignalDep :: DBusDependency RawBrightness p
|
||||
intelBacklightSignalDep :: DBusDependency RawBrightness
|
||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||
|
||||
exportIntelBacklight :: Maybe Client -> SometimesIO
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client)
|
|||
startXMonadService = do
|
||||
client <- getDBusClient False
|
||||
forM_ client requestXMonadName
|
||||
mapM_ (\f -> executeSometimes_ $ f client) dbusExporters
|
||||
mapM_ (\f -> executeSometimes $ f client) dbusExporters
|
||||
return client
|
||||
|
||||
stopXMonadService :: Client -> IO ()
|
||||
|
|
|
|||
|
|
@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
|
|||
memRemoved :: MemberName
|
||||
memRemoved = memberName_ "InterfacesRemoved"
|
||||
|
||||
dbusDep :: MemberName -> DBusDependency a p
|
||||
dbusDep :: MemberName -> DBusDependency p
|
||||
dbusDep m = Endpoint bus path interface $ Signal_ m
|
||||
|
||||
addedDep :: DBusDependency a p
|
||||
addedDep :: DBusDependency p
|
||||
addedDep = dbusDep memAdded
|
||||
|
||||
removedDep :: DBusDependency a p
|
||||
removedDep :: DBusDependency p
|
||||
removedDep = dbusDep memRemoved
|
||||
|
||||
driveInsertedSound :: FilePath
|
||||
|
|
|
|||
|
|
@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
|
|||
matchSignal cb =
|
||||
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
||||
|
||||
ssSignalDep :: DBusDependency a p
|
||||
ssSignalDep :: DBusDependency p
|
||||
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState
|
||||
|
|
|
|||
|
|
@ -7,13 +7,16 @@
|
|||
module XMonad.Internal.Dependency
|
||||
( AlwaysX
|
||||
, AlwaysIO
|
||||
, Feature
|
||||
, Always(..)
|
||||
, TestedSometimes(..)
|
||||
, SometimesX
|
||||
, SometimesIO
|
||||
, Sometimes
|
||||
, executeSometimes_
|
||||
, ioSometimes
|
||||
, ioAlways
|
||||
, evalFeature
|
||||
, executeSometimes
|
||||
, executeAlways_
|
||||
, executeAlways
|
||||
, evalAlways
|
||||
, evalSometimes
|
||||
|
|
@ -50,7 +53,7 @@ import Control.Monad.Identity
|
|||
|
||||
-- import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
-- import Data.Either
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
-- import qualified Data.Text as T
|
||||
|
|
@ -61,7 +64,7 @@ import DBus.Internal
|
|||
import qualified DBus.Introspection as I
|
||||
|
||||
import System.Directory (findExecutable, readable, writable)
|
||||
import System.Environment
|
||||
-- import System.Environment
|
||||
import System.Exit
|
||||
|
||||
import XMonad.Core (X, io)
|
||||
|
|
@ -82,10 +85,19 @@ type SometimesX = Sometimes (X ())
|
|||
|
||||
type SometimesIO = Sometimes (IO ())
|
||||
|
||||
type Feature a = Either (Sometimes a) (Always a)
|
||||
|
||||
data Always a = Option (Subfeature a Tree) (Always a) | Always a
|
||||
|
||||
type Sometimes a = [Subfeature a Tree]
|
||||
|
||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||
ioSometimes = fmap ioSubfeature
|
||||
|
||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||
ioAlways (Always x) = Always $ io x
|
||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
||||
|
||||
data TestedAlways a p =
|
||||
Primary (Finished a p) [FailedFeature a p] (Always a)
|
||||
| Fallback a [FailedFeature a p]
|
||||
|
|
@ -115,17 +127,17 @@ type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
|
|||
sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
|
||||
sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
|
||||
|
||||
always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
|
||||
always1_ l n t x =
|
||||
Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
|
||||
-- always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
|
||||
-- always1_ l n t x =
|
||||
-- Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
|
||||
|
||||
sometimes1 :: String -> ActionTree a Tree -> Sometimes a
|
||||
sometimes1 = sometimes1_ Error
|
||||
|
||||
sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a
|
||||
sometimesIO :: String -> Tree (IODependency p) p -> a -> Sometimes a
|
||||
sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
|
||||
|
||||
sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p
|
||||
sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency p) p
|
||||
-> (Client -> a) -> Sometimes a
|
||||
sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
|
||||
|
||||
|
|
@ -140,18 +152,28 @@ data Subfeature a t = Subfeature
|
|||
|
||||
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
|
||||
|
||||
data Msg = Msg LogLevel String String
|
||||
ioSubfeature :: MonadIO m => Subfeature (IO a) t -> Subfeature (m a) t
|
||||
ioSubfeature sf = sf { sfTree = ioActionTree $ sfTree sf }
|
||||
|
||||
-- data Msg = Msg LogLevel String String
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Action Tree
|
||||
|
||||
data ActionTree a t =
|
||||
forall p. IOTree (Action a p) (t (IODependency a p) p)
|
||||
| forall p. DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p)
|
||||
forall p. IOTree (Action a p) (t (IODependency p) p)
|
||||
| forall p. DBusTree (Action (Client -> a) p) (Maybe Client)
|
||||
(t (DBusDependency p) p)
|
||||
|
||||
data Action a p = Standalone a | Consumer (p -> a)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
ioActionTree :: MonadIO m => ActionTree (IO a) t -> ActionTree (m a) t
|
||||
ioActionTree (IOTree (Standalone a) t) = IOTree (Standalone $ io a) t
|
||||
ioActionTree (IOTree (Consumer a) t) = IOTree (Consumer $ io . a) t
|
||||
ioActionTree (DBusTree (Standalone a) cl t) = DBusTree (Standalone $ io . a) cl t
|
||||
ioActionTree (DBusTree (Consumer a) cl t) = DBusTree (Consumer (\p c -> io $ a p c)) cl t
|
||||
|
||||
-- --------------------------------------------------------------------------------
|
||||
-- | Dependency Tree
|
||||
|
||||
data Tree d p =
|
||||
|
|
@ -192,30 +214,30 @@ smryNil = const $ Right (Nothing, [])
|
|||
smryFail :: String -> Either [String] a
|
||||
smryFail msg = Left [msg]
|
||||
|
||||
smryInit :: Summary p
|
||||
smryInit = Right (Nothing, [])
|
||||
-- smryInit :: Summary p
|
||||
-- smryInit = Right (Nothing, [])
|
||||
|
||||
foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
|
||||
foldResultTreeMsgs = undefined
|
||||
-- foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
|
||||
-- foldResultTreeMsgs = undefined
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Result
|
||||
|
||||
type Result p = Either [String] (Maybe p)
|
||||
-- type Result p = Either [String] (Maybe p)
|
||||
|
||||
resultNil :: p -> Result q
|
||||
resultNil = const $ Right Nothing
|
||||
-- resultNil :: p -> Result q
|
||||
-- resultNil = const $ Right Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | IO Dependency
|
||||
|
||||
data IODependency a p = Executable Bool FilePath
|
||||
data IODependency p = Executable Bool FilePath
|
||||
| AccessiblePath FilePath Bool Bool
|
||||
| IOTest String (IO (Maybe String))
|
||||
| IORead String (IO (Either String (Maybe p)))
|
||||
| Systemd UnitType String
|
||||
| NestedAlways (Always a) (a -> p)
|
||||
| NestedSometimes (Sometimes a) (a -> p)
|
||||
| forall a. NestedAlways (Always a) (a -> p)
|
||||
| forall a. NestedSometimes (Sometimes a) (a -> p)
|
||||
|
||||
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
|
||||
|
||||
|
|
@ -226,22 +248,22 @@ sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Somet
|
|||
sometimesExeArgs n sys path args =
|
||||
sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
|
||||
|
||||
pathR :: String -> IODependency a p
|
||||
pathR :: String -> IODependency p
|
||||
pathR n = AccessiblePath n True False
|
||||
|
||||
pathW :: String -> IODependency a p
|
||||
pathW :: String -> IODependency p
|
||||
pathW n = AccessiblePath n False True
|
||||
|
||||
pathRW :: String -> IODependency a p
|
||||
pathRW :: String -> IODependency p
|
||||
pathRW n = AccessiblePath n True True
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | DBus Dependency Result
|
||||
|
||||
data DBusDependency a p =
|
||||
data DBusDependency p =
|
||||
Bus BusName
|
||||
| Endpoint BusName ObjectPath InterfaceName DBusMember
|
||||
| DBusIO (IODependency a p)
|
||||
| DBusIO (IODependency p)
|
||||
|
||||
data DBusMember = Method_ MemberName
|
||||
| Signal_ MemberName
|
||||
|
|
@ -268,12 +290,16 @@ sometimesEndpoint name busname path iface mem client =
|
|||
-- Here we attempt to build and return the monadic actions encoded by each
|
||||
-- feature.
|
||||
|
||||
executeSometimes_ :: MonadIO m => Sometimes (m a) -> m ()
|
||||
executeSometimes_ = void . executeSometimes
|
||||
executeAlways :: MonadIO m => Always (m a) -> m a
|
||||
executeAlways = join . evalAlways
|
||||
|
||||
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
|
||||
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
|
||||
|
||||
evalFeature :: MonadIO m => Feature a -> m (Maybe a)
|
||||
evalFeature (Right a) = Just <$> evalAlways a
|
||||
evalFeature (Left s) = evalSometimes s
|
||||
|
||||
-- TODO actually print things
|
||||
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
|
||||
evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x
|
||||
|
|
@ -285,11 +311,6 @@ evalSometimesMsg x = io $ do
|
|||
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
|
||||
return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
|
||||
|
||||
executeAlways_ :: MonadIO m => Always (m a) -> m ()
|
||||
executeAlways_ = void . executeAlways
|
||||
|
||||
executeAlways :: MonadIO m => Always (m a) -> m a
|
||||
executeAlways = join . evalAlways
|
||||
|
||||
-- TODO actually print things
|
||||
evalAlways :: MonadIO m => Always a -> m a
|
||||
|
|
@ -309,7 +330,7 @@ evalAlwaysMsg a = io $ do
|
|||
-- for diagnostic purposes. This obviously has overlap with feature evaluation
|
||||
-- since we need to resolve dependencies to build each feature.
|
||||
|
||||
testAlways :: Always a -> IO (TestedAlways a p)
|
||||
testAlways :: Always m -> IO (TestedAlways m p)
|
||||
testAlways = go []
|
||||
where
|
||||
go failed (Option fd next) = do
|
||||
|
|
@ -320,7 +341,7 @@ testAlways = go []
|
|||
(SuccessfulFtr s) -> return $ Primary s failed next
|
||||
go failed (Always a) = return $ Fallback a failed
|
||||
|
||||
testSometimes :: Sometimes a -> IO (TestedSometimes a p)
|
||||
testSometimes :: Sometimes m -> IO (TestedSometimes m p)
|
||||
testSometimes = go (TestedSometimes Nothing [] [])
|
||||
where
|
||||
go ts [] = return ts
|
||||
|
|
@ -333,7 +354,7 @@ testSometimes = go (TestedSometimes Nothing [] [])
|
|||
addFail ts@(TestedSometimes { tsFailed = f }) new
|
||||
= ts { tsFailed = new:f }
|
||||
|
||||
testSubfeature :: Subfeature a Tree -> IO (FeatureResult a p)
|
||||
testSubfeature :: Subfeature m Tree -> IO (FeatureResult m p)
|
||||
testSubfeature fd@(Subfeature { sfTree = t }) = do
|
||||
atm <- testActionTree t
|
||||
return $ either untestable checkAction atm
|
||||
|
|
@ -346,7 +367,7 @@ testSubfeature fd@(Subfeature { sfTree = t }) = do
|
|||
}
|
||||
checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
|
||||
|
||||
testActionTree :: ActionTree a Tree -> IO (ActionTreeMaybe a p)
|
||||
testActionTree :: ActionTree m Tree -> IO (ActionTreeMaybe m p)
|
||||
testActionTree t = do
|
||||
case t of
|
||||
(IOTree a d) -> do
|
||||
|
|
@ -365,12 +386,12 @@ testActionTree t = do
|
|||
apply (Standalone a) _ = a
|
||||
apply (Consumer a) p = a p
|
||||
|
||||
testIOTree :: Tree (IODependency a p) p
|
||||
-> IO (ResultTree (IODependency a p) p, Maybe (Maybe p))
|
||||
testIOTree :: Tree (IODependency p) p
|
||||
-> IO (ResultTree (IODependency p) p, Maybe (Maybe p))
|
||||
testIOTree = testTree testIODependency
|
||||
|
||||
testDBusTree :: Client -> Tree (DBusDependency a p) p
|
||||
-> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p))
|
||||
testDBusTree :: Client -> Tree (DBusDependency p) p
|
||||
-> IO (ResultTree (DBusDependency p) p, Maybe (Maybe p))
|
||||
testDBusTree client = testTree (testDBusDependency client)
|
||||
|
||||
testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
|
||||
|
|
@ -395,7 +416,7 @@ testTree test = go
|
|||
(rb, pb) <- go b
|
||||
return (Both ra rb, fmap (f =<<) pb)
|
||||
|
||||
testIODependency :: IODependency a p -> IO (Summary p)
|
||||
testIODependency :: IODependency p -> IO (Summary p)
|
||||
testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
|
||||
where
|
||||
err = Left ["executable '" ++ bin ++ "' not found"]
|
||||
|
|
@ -441,7 +462,7 @@ testIODependency (NestedSometimes x f) = do
|
|||
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
|
||||
return $ maybe (Left []) (\Finished { finAction = a } -> Right (Just $ f a, [])) s
|
||||
|
||||
testDBusDependency :: Client -> DBusDependency a p -> IO (Summary p)
|
||||
testDBusDependency :: Client -> DBusDependency p -> IO (Summary p)
|
||||
testDBusDependency client (Bus bus) = do
|
||||
ret <- callMethod client queryBus queryPath queryIface queryMem
|
||||
return $ case ret of
|
||||
|
|
@ -493,14 +514,14 @@ testDBusDependency _ (DBusIO d) = testIODependency d
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Printing
|
||||
|
||||
printMsgs :: LogLevel -> [Msg] -> IO ()
|
||||
printMsgs lvl ms = do
|
||||
pn <- getProgName
|
||||
mapM_ (printMsg pn lvl) ms
|
||||
-- printMsgs :: LogLevel -> [Msg] -> IO ()
|
||||
-- printMsgs lvl ms = do
|
||||
-- pn <- getProgName
|
||||
-- mapM_ (printMsg pn lvl) ms
|
||||
|
||||
printMsg :: String -> LogLevel -> Msg -> IO ()
|
||||
printMsg pname lvl (Msg ml mn msg)
|
||||
| lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
|
||||
| otherwise = skip
|
||||
where
|
||||
bracket s = "[" ++ s ++ "]"
|
||||
-- printMsg :: String -> LogLevel -> Msg -> IO ()
|
||||
-- printMsg pname lvl (Msg ml mn msg)
|
||||
-- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
|
||||
-- | otherwise = skip
|
||||
-- where
|
||||
-- bracket s = "[" ++ s ++ "]"
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ import Xmobar.Plugins.Common
|
|||
btAlias :: String
|
||||
btAlias = "bluetooth"
|
||||
|
||||
btDep :: DBusDep
|
||||
btDep :: DBusDependency p
|
||||
btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
|
||||
|
||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ getByIP = memberName_ "GetDeviceByIpIface"
|
|||
devSignal :: String
|
||||
devSignal = "Ip4Connectivity"
|
||||
|
||||
devDep :: DBusDep
|
||||
devDep :: DBusDependency p
|
||||
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
|
||||
|
||||
getDevice :: Client -> String -> IO (Maybe ObjectPath)
|
||||
|
|
|
|||
|
|
@ -118,5 +118,5 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
|
|||
vpnAlias :: String
|
||||
vpnAlias = "vpn"
|
||||
|
||||
vpnDep :: DBusDep
|
||||
vpnDep :: DBusDependency p
|
||||
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects
|
||||
|
|
|
|||
Loading…
Reference in New Issue