ENH give all features an overall name
This commit is contained in:
parent
98a8da5168
commit
3e6f4c7e27
|
@ -273,6 +273,10 @@ vpnPresent = do
|
||||||
where
|
where
|
||||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||||
|
|
||||||
|
xmobarDBus :: String -> DBusDependency_ -> CmdSpec -> Maybe Client -> BarFeature
|
||||||
|
xmobarDBus n dep cmd cl = sometimesDBus cl n "xmobar dbus interface"
|
||||||
|
(Only_ dep) $ const cmd
|
||||||
|
|
||||||
rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
|
rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
|
||||||
rightPlugins sysClient sesClient = mapM evalFeature
|
rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
[ Left getWireless
|
[ Left getWireless
|
||||||
|
@ -284,53 +288,50 @@ rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
, Left $ getBl sesClient
|
, Left $ getBl sesClient
|
||||||
, Left $ getCk sesClient
|
, Left $ getCk sesClient
|
||||||
, Left $ getSs sesClient
|
, Left $ getSs sesClient
|
||||||
, Right $ Always lockCmd
|
, always' "lock indicator" lockCmd
|
||||||
, Right $ Always dateCmd
|
, always' "date indicator" dateCmd
|
||||||
]
|
]
|
||||||
|
where
|
||||||
|
always' n = Right . Always n . Always_
|
||||||
|
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd
|
getWireless = sometimes1 "wireless status indicator" "sysfs path"
|
||||||
|
$ IORoot wirelessCmd
|
||||||
$ Only $ readInterface "get wifi interface" isWireless
|
$ Only $ readInterface "get wifi interface" isWireless
|
||||||
|
|
||||||
getEthernet :: Maybe Client -> BarFeature
|
getEthernet :: Maybe Client -> BarFeature
|
||||||
getEthernet client = sometimes1 "ethernet status indicator" $
|
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
|
||||||
DBusRoot (const . ethernetCmd) tree client
|
$ DBusRoot (const . ethernetCmd) tree client
|
||||||
where
|
where
|
||||||
tree = And1 (Only readEth) (Only_ devDep)
|
tree = And1 (Only readEth) (Only_ devDep)
|
||||||
readEth = readInterface "read ethernet interface" isEthernet
|
readEth = readInterface "read ethernet interface" isEthernet
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = sometimesIO "battery level indicator"
|
getBattery = sometimesIO "battery level indicator" "sysfs path"
|
||||||
(Only_ $ sysTest "Test if battery is present" hasBattery)
|
(Only_ $ sysTest "Test if battery is present" hasBattery)
|
||||||
batteryCmd
|
batteryCmd
|
||||||
|
|
||||||
getVPN :: Maybe Client -> BarFeature
|
getVPN :: Maybe Client -> BarFeature
|
||||||
getVPN client = sometimesDBus client "VPN status indicator"
|
getVPN client = sometimesDBus client "VPN status indicator"
|
||||||
(toAnd vpnDep test) (const vpnCmd)
|
"xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
|
||||||
where
|
where
|
||||||
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
|
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe Client -> BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
getBt client = sometimesDBus client "bluetooth status indicator"
|
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
|
||||||
(Only_ btDep)
|
|
||||||
(const btCmd)
|
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = sometimesIO "volume level indicator" (Only_ $ sysExe "alsactl") alsaCmd
|
getAlsa = sometimesIO "volume level indicator" "alsactl"
|
||||||
|
(Only_ $ sysExe "alsactl") alsaCmd
|
||||||
|
|
||||||
getBl :: Maybe Client -> BarFeature
|
getBl :: Maybe Client -> BarFeature
|
||||||
getBl client = sometimesDBus client "Intel backlight indicator"
|
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
|
||||||
(Only_ intelBacklightSignalDep)
|
|
||||||
(const blCmd)
|
|
||||||
|
|
||||||
getCk :: Maybe Client -> BarFeature
|
getCk :: Maybe Client -> BarFeature
|
||||||
getCk client = sometimesDBus client "Clevo keyboard indicator"
|
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
|
||||||
(Only_ clevoKeyboardSignalDep)
|
|
||||||
(const ckCmd)
|
|
||||||
|
|
||||||
getSs :: Maybe Client -> BarFeature
|
getSs :: Maybe Client -> BarFeature
|
||||||
getSs client = sometimesDBus client "screensaver indicator"
|
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
|
||||||
(Only_ ssSignalDep) $ const ssCmd
|
|
||||||
|
|
||||||
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
|
||||||
getAllCommands right = do
|
getAllCommands right = do
|
||||||
|
|
|
@ -573,9 +573,9 @@ externalBindings ts db =
|
||||||
]
|
]
|
||||||
|
|
||||||
, KeyGroup "Actions"
|
, KeyGroup "Actions"
|
||||||
[ KeyBinding "M-q" "close window" $ ftrAlways kill1
|
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
|
||||||
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
, KeyBinding "M-r" "run program" $ Left runCmdMenu
|
||||||
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5
|
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
|
||||||
, KeyBinding "M-C-s" "capture area" $ Left runAreaCapture
|
, KeyBinding "M-C-s" "capture area" $ Left runAreaCapture
|
||||||
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
|
, KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
|
||||||
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture
|
, KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture
|
||||||
|
@ -610,11 +610,11 @@ externalBindings ts db =
|
||||||
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
||||||
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
||||||
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
|
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
|
||||||
, KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt
|
, KeyBinding "M-<Home>" "quit xmonad" quitf
|
||||||
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
||||||
-- M-<F1> reserved for showing the keymap
|
-- M-<F1> reserved for showing the keymap
|
||||||
, KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart)
|
, KeyBinding "M-<F2>" "restart xmonad" restartf
|
||||||
, KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile
|
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
|
||||||
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
|
, KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
|
||||||
, KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
|
, KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
|
||||||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||||
|
@ -629,7 +629,10 @@ externalBindings ts db =
|
||||||
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
||||||
ib = Left . brightessControls intelBacklightControls
|
ib = Left . brightessControls intelBacklightControls
|
||||||
ck = Left . brightessControls clevoKeyboardControls
|
ck = Left . brightessControls clevoKeyboardControls
|
||||||
ftrAlways = Right . Always
|
ftrAlways n = Right . Always n . Always_
|
||||||
|
quitf = ftrAlways "quit function" runQuitPrompt
|
||||||
|
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
||||||
|
recompilef = ftrAlways "recompile function" runRecompile
|
||||||
|
|
||||||
type MaybeX = Maybe (X ())
|
type MaybeX = Maybe (X ())
|
||||||
|
|
||||||
|
|
|
@ -57,7 +57,7 @@ myDmenuNetworks = "networkmanager_dmenu"
|
||||||
-- | Other internal functions
|
-- | Other internal functions
|
||||||
|
|
||||||
spawnDmenuCmd :: String -> [String] -> SometimesX
|
spawnDmenuCmd :: String -> [String] -> SometimesX
|
||||||
spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd
|
spawnDmenuCmd n = sometimesExeArgs n "rofi preset" True myDmenuCmd
|
||||||
|
|
||||||
themeArgs :: String -> [String]
|
themeArgs :: String -> [String]
|
||||||
themeArgs hexColor =
|
themeArgs hexColor =
|
||||||
|
@ -72,24 +72,29 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
|
||||||
-- | Exported Commands
|
-- | Exported Commands
|
||||||
|
|
||||||
runDevMenu :: SometimesX
|
runDevMenu :: SometimesX
|
||||||
runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
|
runDevMenu = sometimesIO "device manager" "rofi devices" t x
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
where
|
||||||
spawnCmd myDmenuDevices
|
t = Only_ $ localExe myDmenuDevices
|
||||||
$ ["-c", c]
|
x = do
|
||||||
++ "--" : themeArgs "#999933"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
|
||||||
++ myDmenuMatchingArgs
|
spawnCmd myDmenuDevices
|
||||||
|
$ ["-c", c]
|
||||||
|
++ "--" : themeArgs "#999933"
|
||||||
|
++ myDmenuMatchingArgs
|
||||||
|
|
||||||
runBTMenu :: SometimesX
|
runBTMenu :: SometimesX
|
||||||
runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
|
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
|
||||||
$ "-c":themeArgs "#0044bb"
|
myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
||||||
|
|
||||||
runBwMenu :: SometimesX
|
runBwMenu :: SometimesX
|
||||||
runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $
|
runBwMenu = sometimesIO "password manager" "rofi bitwarden"
|
||||||
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
(Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
|
||||||
|
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
runVPNMenu :: SometimesX
|
runVPNMenu :: SometimesX
|
||||||
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
|
runVPNMenu = sometimesIO "VPN selector" "rofi VPN"
|
||||||
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
(Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
|
||||||
|
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
|
|
||||||
runCmdMenu :: SometimesX
|
runCmdMenu :: SometimesX
|
||||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||||
|
@ -98,7 +103,7 @@ runAppMenu :: SometimesX
|
||||||
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
|
||||||
|
|
||||||
runClipMenu :: SometimesX
|
runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO "clipboard manager" deps act
|
runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
|
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
|
||||||
|
@ -111,18 +116,18 @@ runWinMenu :: SometimesX
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||||
|
|
||||||
runNetMenu :: SometimesX
|
runNetMenu :: SometimesX
|
||||||
runNetMenu =
|
runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
|
||||||
sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333"
|
True myDmenuNetworks $ themeArgs "#ff3333"
|
||||||
|
|
||||||
runAutorandrMenu :: SometimesX
|
runAutorandrMenu :: SometimesX
|
||||||
runAutorandrMenu =
|
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||||
sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"
|
True myDmenuMonitors $ themeArgs "#ff0066"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Shortcut menu
|
-- | Shortcut menu
|
||||||
|
|
||||||
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
runShowKeys = Option showKeysDMenu (Always fallback)
|
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback)
|
||||||
where
|
where
|
||||||
-- TODO this should technically depend on dunst
|
-- TODO this should technically depend on dunst
|
||||||
fallback = const $ spawnNotify
|
fallback = const $ spawnNotify
|
||||||
|
|
|
@ -92,10 +92,10 @@ ethernetIface = "enp7s0f1"
|
||||||
-- | Some nice apps
|
-- | Some nice apps
|
||||||
|
|
||||||
runTerm :: SometimesX
|
runTerm :: SometimesX
|
||||||
runTerm = sometimesExe "terminal" True myTerm
|
runTerm = sometimesExe "terminal" "urxvt" True myTerm
|
||||||
|
|
||||||
runTMux :: SometimesX
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO "terminal multiplexer" deps act
|
runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
|
||||||
where
|
where
|
||||||
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
|
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
|
||||||
act = spawn
|
act = spawn
|
||||||
|
@ -106,27 +106,27 @@ runTMux = sometimesIO "terminal multiplexer" deps act
|
||||||
msg = "could not connect to tmux session"
|
msg = "could not connect to tmux session"
|
||||||
|
|
||||||
runCalc :: SometimesX
|
runCalc :: SometimesX
|
||||||
runCalc = sometimesIO "calculator" deps act
|
runCalc = sometimesIO "calculator" "R" deps act
|
||||||
where
|
where
|
||||||
deps = toAnd (sysExe myTerm) (sysExe "R")
|
deps = toAnd (sysExe myTerm) (sysExe "R")
|
||||||
act = spawnCmd myTerm ["-e", "R"]
|
act = spawnCmd myTerm ["-e", "R"]
|
||||||
|
|
||||||
runBrowser :: SometimesX
|
runBrowser :: SometimesX
|
||||||
runBrowser = sometimesExe "web browser" False myBrowser
|
runBrowser = sometimesExe "web browser" "brave" False myBrowser
|
||||||
|
|
||||||
runEditor :: SometimesX
|
runEditor :: SometimesX
|
||||||
runEditor = sometimesExeArgs "text editor" True myEditor
|
runEditor = sometimesExeArgs "text editor" "emacs" True myEditor
|
||||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||||
|
|
||||||
runFileManager :: SometimesX
|
runFileManager :: SometimesX
|
||||||
runFileManager = sometimesExe "file browser" True "pcmanfm"
|
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Multimedia Commands
|
-- | Multimedia Commands
|
||||||
|
|
||||||
runMultimediaIfInstalled :: String -> String -> SometimesX
|
runMultimediaIfInstalled :: String -> String -> SometimesX
|
||||||
runMultimediaIfInstalled n cmd =
|
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
|
||||||
sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd]
|
"playerctl" True myMultimediaCtl [cmd]
|
||||||
|
|
||||||
runTogglePlay :: SometimesX
|
runTogglePlay :: SometimesX
|
||||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||||
|
@ -155,7 +155,7 @@ playSound file = do
|
||||||
|
|
||||||
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay")
|
sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
|
||||||
$ pre >> playSound file >> post
|
$ pre >> playSound file >> post
|
||||||
|
|
||||||
runVolumeDown :: SometimesX
|
runVolumeDown :: SometimesX
|
||||||
|
@ -172,7 +172,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
|
||||||
|
|
||||||
runNotificationCmd :: String -> FilePath -> SometimesX
|
runNotificationCmd :: String -> FilePath -> SometimesX
|
||||||
runNotificationCmd n cmd =
|
runNotificationCmd n cmd =
|
||||||
sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd]
|
sometimesExeArgs (n ++ " control") "dunst" True myNotificationCtrl [cmd]
|
||||||
|
|
||||||
runNotificationClose :: SometimesX
|
runNotificationClose :: SometimesX
|
||||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||||
|
@ -194,7 +194,7 @@ runNotificationContext =
|
||||||
|
|
||||||
runToggleBluetooth :: SometimesX
|
runToggleBluetooth :: SometimesX
|
||||||
runToggleBluetooth =
|
runToggleBluetooth =
|
||||||
sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth)
|
sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
|
||||||
$ spawn
|
$ spawn
|
||||||
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
$ myBluetooth ++ " show | grep -q \"Powered: no\""
|
||||||
#!&& "a=on"
|
#!&& "a=on"
|
||||||
|
@ -203,7 +203,7 @@ runToggleBluetooth =
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
||||||
|
|
||||||
runToggleEthernet :: SometimesX
|
runToggleEthernet :: SometimesX
|
||||||
runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
|
runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "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"
|
||||||
|
@ -212,14 +212,16 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
||||||
|
|
||||||
runStartISyncTimer :: SometimesX
|
runStartISyncTimer :: SometimesX
|
||||||
runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "mbsync.timer")
|
runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
|
||||||
|
(Only_ $ sysdUser "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 :: SometimesX
|
runStartISyncService :: SometimesX
|
||||||
runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "mbsync.service")
|
runStartISyncService = sometimesIO "isync" "mbsync service"
|
||||||
|
(Only_ $ sysdUser "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" }
|
||||||
|
@ -264,7 +266,7 @@ getCaptureDir = do
|
||||||
fallback = (</> ".local/share") <$> getHomeDirectory
|
fallback = (</> ".local/share") <$> getHomeDirectory
|
||||||
|
|
||||||
runFlameshot :: String -> String -> SometimesX
|
runFlameshot :: String -> String -> SometimesX
|
||||||
runFlameshot n mode = sometimesIO n (Only_ $ sysExe myCapture)
|
runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe 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
|
||||||
|
@ -281,7 +283,7 @@ runScreenCapture :: SometimesX
|
||||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: SometimesX
|
runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser =
|
runCaptureBrowser = sometimesIO "screen capture browser" "feh"
|
||||||
sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do
|
(Only_ $ sysExe myImageBrowser) $ do
|
||||||
dir <- io getCaptureDir
|
dir <- io getCaptureDir
|
||||||
spawnCmd myImageBrowser [dir]
|
spawnCmd myImageBrowser [dir]
|
||||||
|
|
|
@ -49,7 +49,7 @@ myOptimusManager = "optimus-manager"
|
||||||
-- | Core commands
|
-- | Core commands
|
||||||
|
|
||||||
runScreenLock :: SometimesX
|
runScreenLock :: SometimesX
|
||||||
runScreenLock = sometimesExe "screen locker" True myScreenlock
|
runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock
|
||||||
|
|
||||||
runPowerOff :: X ()
|
runPowerOff :: X ()
|
||||||
runPowerOff = spawn "systemctl poweroff"
|
runPowerOff = spawn "systemctl poweroff"
|
||||||
|
@ -104,8 +104,8 @@ runOptimusPrompt' = do
|
||||||
#!&& "killall xmonad"
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: SometimesX
|
runOptimusPrompt :: SometimesX
|
||||||
runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager)
|
runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager"
|
||||||
runOptimusPrompt'
|
(Only_ $ localExe myOptimusManager) runOptimusPrompt'
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Universal power prompt
|
-- | Universal power prompt
|
||||||
|
@ -134,7 +134,7 @@ instance XPrompt PowerPrompt where
|
||||||
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
||||||
|
|
||||||
runPowerPrompt :: AlwaysX
|
runPowerPrompt :: AlwaysX
|
||||||
runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock
|
runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock
|
||||||
where
|
where
|
||||||
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)
|
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)
|
||||||
|
|
||||||
|
|
|
@ -113,9 +113,9 @@ handleACPI lock tag = do
|
||||||
-- | 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 :: SometimesIO
|
runPowermon :: SometimesIO
|
||||||
runPowermon = sometimesIO "ACPI event monitor" socketDep listenACPI
|
runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI
|
||||||
|
|
||||||
runHandleACPI :: Always (String -> X ())
|
runHandleACPI :: Always (String -> X ())
|
||||||
runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip
|
runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip
|
||||||
where
|
where
|
||||||
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)
|
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)
|
||||||
|
|
|
@ -88,7 +88,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
||||||
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
|
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
|
||||||
-> Maybe Client -> SometimesIO
|
-> Maybe Client -> SometimesIO
|
||||||
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
|
||||||
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
|
sometimesDBus client n (n ++ " exporter") ds (exportBrightnessControls' bc)
|
||||||
where
|
where
|
||||||
ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
|
ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
|
||||||
|
|
||||||
|
@ -132,7 +132,7 @@ callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
|
||||||
callBacklight client BrightnessConfig { bcPath = p
|
callBacklight client BrightnessConfig { bcPath = p
|
||||||
, bcInterface = i
|
, bcInterface = i
|
||||||
, bcName = n } controlName m =
|
, bcName = n } controlName m =
|
||||||
sometimesEndpoint (unwords [n, controlName]) xmonadBusName p i m client
|
sometimesEndpoint n (unwords [n, controlName]) xmonadBusName p i m client
|
||||||
|
|
||||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||||
|
|
|
@ -83,6 +83,6 @@ listenDevices client = do
|
||||||
|
|
||||||
runRemovableMon :: Maybe Client -> SometimesIO
|
runRemovableMon :: Maybe Client -> SometimesIO
|
||||||
runRemovableMon cl =
|
runRemovableMon cl =
|
||||||
sometimesDBus cl "removeable device monitor" deps listenDevices
|
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
|
||||||
where
|
where
|
||||||
deps = toAnd addedDep removedDep
|
deps = toAnd addedDep removedDep
|
||||||
|
|
|
@ -96,7 +96,7 @@ bodyGetCurrentState _ = Nothing
|
||||||
|
|
||||||
exportScreensaver :: Maybe Client -> SometimesIO
|
exportScreensaver :: Maybe Client -> SometimesIO
|
||||||
exportScreensaver client =
|
exportScreensaver client =
|
||||||
sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd
|
sometimesDBus client "screensaver toggle" "xset" (toAnd bus ssx) cmd
|
||||||
where
|
where
|
||||||
cmd cl = export cl ssPath defaultInterface
|
cmd cl = export cl ssPath defaultInterface
|
||||||
{ interfaceName = interface
|
{ interfaceName = interface
|
||||||
|
@ -117,11 +117,11 @@ exportScreensaver client =
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
bus = Bus xmonadBusName
|
bus = Bus xmonadBusName
|
||||||
ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable
|
ssx = DBusIO $ sysExe ssExecutable
|
||||||
|
|
||||||
callToggle :: Maybe Client -> SometimesIO
|
callToggle :: Maybe Client -> SometimesIO
|
||||||
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
|
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName
|
||||||
interface memToggle
|
ssPath interface memToggle
|
||||||
|
|
||||||
callQuery :: Client -> IO (Maybe SSState)
|
callQuery :: Client -> IO (Maybe SSState)
|
||||||
callQuery client = do
|
callQuery client = do
|
||||||
|
|
|
@ -9,7 +9,9 @@ module XMonad.Internal.Dependency
|
||||||
-- feature types
|
-- feature types
|
||||||
( Feature
|
( Feature
|
||||||
, Always(..)
|
, Always(..)
|
||||||
, Sometimes
|
, Always_(..)
|
||||||
|
, Sometimes(..)
|
||||||
|
, Sometimes_
|
||||||
, AlwaysX
|
, AlwaysX
|
||||||
, AlwaysIO
|
, AlwaysIO
|
||||||
, SometimesX
|
, SometimesX
|
||||||
|
@ -137,26 +139,26 @@ dumpFeature = either dumpSometimes dumpAlways
|
||||||
|
|
||||||
-- | Dump the status of an Always to stdout
|
-- | Dump the status of an Always to stdout
|
||||||
dumpAlways :: Always a -> IO JSONUnquotable
|
dumpAlways :: Always a -> IO JSONUnquotable
|
||||||
dumpAlways = go []
|
dumpAlways (Always n x) = go [] x
|
||||||
where
|
where
|
||||||
go failed (Option o os) = do
|
go failed (Option o os) = do
|
||||||
(s, r) <- dumpSubfeatureRoot o
|
(s, r) <- dumpSubfeatureRoot o
|
||||||
if r
|
if r
|
||||||
then return $ jsonAlways (Just s) failed $ untested [] os
|
then return $ jsonAlways (Q n) (Just s) failed $ untested [] os
|
||||||
else go (s:failed) os
|
else go (s:failed) os
|
||||||
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed []
|
go failed (Always_ _) = return $ jsonAlways (Q n) (Just (UQ "true")) failed []
|
||||||
untested acc (Always _) = acc
|
untested acc (Always_ _) = acc
|
||||||
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
|
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
|
||||||
|
|
||||||
-- | Dump the status of a Sometimes to stdout
|
-- | Dump the status of a Sometimes to stdout
|
||||||
dumpSometimes :: Sometimes a -> IO JSONUnquotable
|
dumpSometimes :: Sometimes a -> IO JSONUnquotable
|
||||||
dumpSometimes = go []
|
dumpSometimes (Sometimes n a) = go [] a
|
||||||
where
|
where
|
||||||
go failed [] = return $ jsonSometimes Nothing failed []
|
go failed [] = return $ jsonSometimes (Q n) Nothing failed []
|
||||||
go failed (x:xs) = do
|
go failed (x:xs) = do
|
||||||
(s, r) <- dumpSubfeatureRoot x
|
(s, r) <- dumpSubfeatureRoot x
|
||||||
if r
|
if r
|
||||||
then return $ jsonSometimes (Just s) failed $ fmap dataSubfeatureRoot xs
|
then return $ jsonSometimes (Q n) (Just s) failed $ fmap dataSubfeatureRoot xs
|
||||||
else go (s:failed) xs
|
else go (s:failed) xs
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -178,12 +180,18 @@ type Feature a = Either (Sometimes a) (Always a)
|
||||||
-- | Feature that is guaranteed to work
|
-- | Feature that is guaranteed to work
|
||||||
-- This is composed of sub-features that are tested in order, and if all fail
|
-- This is composed of sub-features that are tested in order, and if all fail
|
||||||
-- the fallback is a monadic action (eg a plain haskell function)
|
-- the fallback is a monadic action (eg a plain haskell function)
|
||||||
data Always a = Option (SubfeatureRoot a) (Always a) | Always a
|
data Always a = Always String (Always_ a)
|
||||||
|
|
||||||
|
-- | Feature that is guaranteed to work (inner data)
|
||||||
|
data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ a
|
||||||
|
|
||||||
-- | Feature that might not be present
|
-- | Feature that might not be present
|
||||||
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
-- This is like an Always except it doesn't fall back on a guaranteed monadic
|
||||||
-- action
|
-- action
|
||||||
type Sometimes a = [SubfeatureRoot a]
|
data Sometimes a = Sometimes String (Sometimes_ a)
|
||||||
|
|
||||||
|
-- | Feature that might not be present (inner data)
|
||||||
|
type Sometimes_ a = [SubfeatureRoot a]
|
||||||
|
|
||||||
-- | Individually tested sub-feature data for Always/sometimes
|
-- | Individually tested sub-feature data for Always/sometimes
|
||||||
-- The polymorphism allows representing tested and untested states. Includes
|
-- The polymorphism allows representing tested and untested states. Includes
|
||||||
|
@ -259,7 +267,7 @@ data DBusMember = Method_ MemberName
|
||||||
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
|
||||||
|
|
||||||
-- | Tested Always feature
|
-- | Tested Always feature
|
||||||
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
|
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
|
||||||
| Fallback a [SubfeatureFail]
|
| Fallback a [SubfeatureFail]
|
||||||
|
|
||||||
-- | Tested Sometimes feature
|
-- | Tested Sometimes feature
|
||||||
|
@ -287,20 +295,20 @@ data PostFail = PostFail [String] | PostMissing String
|
||||||
-- | Testing pipeline
|
-- | Testing pipeline
|
||||||
|
|
||||||
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
|
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
|
||||||
evalSometimesMsg x = io $ do
|
evalSometimesMsg (Sometimes n xs) = io $ do
|
||||||
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
|
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
|
||||||
case s of
|
case s of
|
||||||
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
|
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs
|
||||||
_ -> Left <$> failedMsgs True fs
|
_ -> Left <$> failedMsgs True n fs
|
||||||
|
|
||||||
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
|
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
|
||||||
evalAlwaysMsg x = io $ do
|
evalAlwaysMsg (Always n x) = io $ do
|
||||||
r <- testAlways x
|
r <- testAlways x
|
||||||
case r of
|
case r of
|
||||||
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
|
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs
|
||||||
(Fallback act fs) -> PostPass act <$> failedMsgs False fs
|
(Fallback act fs) -> PostPass act <$> failedMsgs False n fs
|
||||||
|
|
||||||
testAlways :: Always a -> IO (PostAlways a)
|
testAlways :: Always_ a -> IO (PostAlways a)
|
||||||
testAlways = go []
|
testAlways = go []
|
||||||
where
|
where
|
||||||
go failed (Option fd next) = do
|
go failed (Option fd next) = do
|
||||||
|
@ -308,9 +316,9 @@ testAlways = go []
|
||||||
case r of
|
case r of
|
||||||
(Left l) -> go (l:failed) next
|
(Left l) -> go (l:failed) next
|
||||||
(Right pass) -> return $ Primary pass failed next
|
(Right pass) -> return $ Primary pass failed next
|
||||||
go failed (Always a) = return $ Fallback a failed
|
go failed (Always_ a) = return $ Fallback a failed
|
||||||
|
|
||||||
testSometimes :: Sometimes a -> IO (PostSometimes a)
|
testSometimes :: Sometimes_ a -> IO (PostSometimes a)
|
||||||
testSometimes = go (PostSometimes Nothing [])
|
testSometimes = go (PostSometimes Nothing [])
|
||||||
where
|
where
|
||||||
go ts [] = return ts
|
go ts [] = return ts
|
||||||
|
@ -486,11 +494,14 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i
|
||||||
-- | IO Lifting functions
|
-- | IO Lifting functions
|
||||||
|
|
||||||
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
|
||||||
ioSometimes = fmap ioSubfeature
|
ioSometimes (Sometimes n xs) = Sometimes n $ fmap ioSubfeature xs
|
||||||
|
|
||||||
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
|
||||||
ioAlways (Always x) = Always $ io x
|
ioAlways (Always n x) = Always n $ ioAlways' x
|
||||||
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
|
|
||||||
|
ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
|
||||||
|
ioAlways' (Always_ x) = Always_ $ io x
|
||||||
|
ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a
|
||||||
|
|
||||||
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
||||||
|
@ -504,37 +515,39 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Feature constructors
|
-- | Feature constructors
|
||||||
|
|
||||||
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
|
sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a
|
||||||
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
sometimes1_ l fn n t = Sometimes fn
|
||||||
|
[Subfeature{ sfData = t, sfName = n, sfLevel = l }]
|
||||||
|
|
||||||
always1_ :: LogLevel -> String -> Root a -> a -> Always a
|
always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a
|
||||||
always1_ l n t x =
|
always1_ l fn n t x = Always fn
|
||||||
Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
|
$ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ x)
|
||||||
|
|
||||||
sometimes1 :: String -> Root a -> Sometimes a
|
sometimes1 :: String -> String -> Root a -> Sometimes a
|
||||||
sometimes1 = sometimes1_ Error
|
sometimes1 = sometimes1_ Error
|
||||||
|
|
||||||
always1 :: String -> Root a -> a -> Always a
|
always1 :: String -> String -> Root a -> a -> Always a
|
||||||
always1 = always1_ Error
|
always1 = always1_ Error
|
||||||
|
|
||||||
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
|
sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a
|
||||||
sometimesIO n t x = sometimes1 n $ IORoot_ x t
|
sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t
|
||||||
|
|
||||||
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
|
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
|
||||||
sometimesExe n sys path = sometimesExeArgs n sys path []
|
sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
|
||||||
|
|
||||||
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
|
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
|
||||||
sometimesExeArgs n sys path args =
|
-> [String] -> Sometimes (m ())
|
||||||
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
sometimesExeArgs fn n sys path args =
|
||||||
|
sometimesIO fn n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
|
||||||
|
|
||||||
sometimesDBus :: Maybe Client -> String -> Tree_ DBusDependency_
|
sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
|
||||||
-> (Client -> a) -> Sometimes a
|
-> (Client -> a) -> Sometimes a
|
||||||
sometimesDBus c n t x = sometimes1 n $ DBusRoot_ x t c
|
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
|
||||||
|
|
||||||
sometimesEndpoint :: MonadIO m => String -> BusName -> ObjectPath -> InterfaceName
|
sometimesEndpoint :: MonadIO m => String -> String -> BusName -> ObjectPath -> InterfaceName
|
||||||
-> MemberName -> Maybe Client -> Sometimes (m ())
|
-> MemberName -> Maybe Client -> Sometimes (m ())
|
||||||
sometimesEndpoint name busname path iface mem client =
|
sometimesEndpoint fn name busname path iface mem client =
|
||||||
sometimesDBus client name deps cmd
|
sometimesDBus client fn name deps cmd
|
||||||
where
|
where
|
||||||
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
deps = Only_ $ Endpoint busname path iface $ Method_ mem
|
||||||
cmd c = io $ void $ callMethod c busname path iface mem
|
cmd c = io $ void $ callMethod c busname path iface mem
|
||||||
|
@ -734,18 +747,19 @@ newtype JSONUnquotable = UQ String
|
||||||
|
|
||||||
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
|
data JSONMixed = JSON_UQ JSONUnquotable | JSON_Q JSONQuotable
|
||||||
|
|
||||||
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
jsonAlways :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||||
-> JSONUnquotable
|
-> [JSONUnquotable] -> JSONUnquotable
|
||||||
jsonAlways = jsonFeature True
|
jsonAlways = jsonFeature True
|
||||||
|
|
||||||
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
|
jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||||
-> JSONUnquotable
|
-> [JSONUnquotable] -> JSONUnquotable
|
||||||
jsonSometimes = jsonFeature False
|
jsonSometimes = jsonFeature False
|
||||||
|
|
||||||
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable]
|
jsonFeature :: Bool -> JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
|
||||||
-> [JSONUnquotable] -> JSONUnquotable
|
-> [JSONUnquotable] -> JSONUnquotable
|
||||||
jsonFeature isalways success failed untested = jsonObject
|
jsonFeature isalways name success failed untested = jsonObject
|
||||||
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
|
[ ("type", JSON_Q $ Q $ if isalways then "always" else "sometimes")
|
||||||
|
, ("name", JSON_Q name)
|
||||||
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
|
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
|
||||||
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
|
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
|
||||||
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
|
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
|
||||||
|
@ -826,16 +840,16 @@ curly s = "{" ++ s ++ "}"
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Other random formatting
|
-- | Other random formatting
|
||||||
|
|
||||||
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
|
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
|
||||||
failedMsgs err = fmap concat . mapM (failedMsg err)
|
failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
|
||||||
|
|
||||||
failedMsg :: Bool -> SubfeatureFail -> IO [String]
|
failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
|
||||||
failedMsg err Subfeature { sfData = d, sfName = n } = do
|
failedMsg err fn Subfeature { sfData = d, sfName = n } = do
|
||||||
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
|
||||||
|
|
||||||
fmtMsg :: Bool -> String -> String -> IO String
|
fmtMsg :: Bool -> String -> String -> String -> IO String
|
||||||
fmtMsg err n msg = do
|
fmtMsg err fn n msg = do
|
||||||
let e = if err then "ERROR" else "WARNING"
|
let e = if err then "ERROR" else "WARNING"
|
||||||
p <- getProgName
|
p <- getProgName
|
||||||
return $ unwords [bracket p, bracket e, bracket n, msg]
|
return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue