ENH give all features an overall name

This commit is contained in:
Nathan Dwarshuis 2022-06-28 23:27:55 -04:00
parent 98a8da5168
commit 3e6f4c7e27
10 changed files with 156 additions and 131 deletions

View File

@ -273,6 +273,10 @@ vpnPresent = do
where
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 sysClient sesClient = mapM evalFeature
[ Left getWireless
@ -284,53 +288,50 @@ rightPlugins sysClient sesClient = mapM evalFeature
, Left $ getBl sesClient
, Left $ getCk sesClient
, Left $ getSs sesClient
, Right $ Always lockCmd
, Right $ Always dateCmd
, always' "lock indicator" lockCmd
, always' "date indicator" dateCmd
]
where
always' n = Right . Always n . Always_
getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" $ IORoot wirelessCmd
getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd
$ Only $ readInterface "get wifi interface" isWireless
getEthernet :: Maybe Client -> BarFeature
getEthernet client = sometimes1 "ethernet status indicator" $
DBusRoot (const . ethernetCmd) tree client
getEthernet client = sometimes1 "ethernet status indicator" "sysfs path"
$ DBusRoot (const . ethernetCmd) tree client
where
tree = And1 (Only readEth) (Only_ devDep)
readEth = readInterface "read ethernet interface" isEthernet
getBattery :: BarFeature
getBattery = sometimesIO "battery level indicator"
getBattery = sometimesIO "battery level indicator" "sysfs path"
(Only_ $ sysTest "Test if battery is present" hasBattery)
batteryCmd
getVPN :: Maybe Client -> BarFeature
getVPN client = sometimesDBus client "VPN status indicator"
(toAnd vpnDep test) (const vpnCmd)
"xmobar dbus interface" (toAnd vpnDep test) (const vpnCmd)
where
test = DBusIO $ sysTest "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature
getBt client = sometimesDBus client "bluetooth status indicator"
(Only_ btDep)
(const btCmd)
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
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 client = sometimesDBus client "Intel backlight indicator"
(Only_ intelBacklightSignalDep)
(const blCmd)
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
getCk :: Maybe Client -> BarFeature
getCk client = sometimesDBus client "Clevo keyboard indicator"
(Only_ clevoKeyboardSignalDep)
(const ckCmd)
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
getSs :: Maybe Client -> BarFeature
getSs client = sometimesDBus client "screensaver indicator"
(Only_ ssSignalDep) $ const ssCmd
getSs = xmobarDBus "screensaver indicator" ssSignalDep ssCmd
getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do

View File

@ -573,9 +573,9 @@ externalBindings ts db =
]
, 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-<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-s" "capture screen" $ Left runScreenCapture
, 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 max" $ ck bctlMax
, 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
-- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile
, KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef
, 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
@ -629,7 +629,10 @@ externalBindings ts db =
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
ib = Left . brightessControls intelBacklightControls
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 ())

View File

@ -57,7 +57,7 @@ myDmenuNetworks = "networkmanager_dmenu"
-- | Other internal functions
spawnDmenuCmd :: String -> [String] -> SometimesX
spawnDmenuCmd n = sometimesExeArgs n True myDmenuCmd
spawnDmenuCmd n = sometimesExeArgs n "rofi preset" True myDmenuCmd
themeArgs :: String -> [String]
themeArgs hexColor =
@ -72,7 +72,10 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands
runDevMenu :: SometimesX
runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
runDevMenu = sometimesIO "device manager" "rofi devices" t x
where
t = Only_ $ localExe myDmenuDevices
x = do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices
$ ["-c", c]
@ -80,16 +83,18 @@ runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do
++ myDmenuMatchingArgs
runBTMenu :: SometimesX
runBTMenu = sometimesExeArgs "bluetooth selector" False myDmenuBluetooth
$ "-c":themeArgs "#0044bb"
runBTMenu = sometimesExeArgs "bluetooth selector" "rofi bluetooth" False
myDmenuBluetooth $ "-c":themeArgs "#0044bb"
runBwMenu :: SometimesX
runBwMenu = sometimesIO "password manager" (Only_ $ localExe myDmenuPasswords) $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runBwMenu = sometimesIO "password manager" "rofi bitwarden"
(Only_ $ localExe myDmenuPasswords) $ spawnCmd myDmenuPasswords
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runVPNMenu :: SometimesX
runVPNMenu = sometimesIO "VPN selector" (Only_ $ localExe myDmenuVPN) $
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
runVPNMenu = sometimesIO "VPN selector" "rofi VPN"
(Only_ $ localExe myDmenuVPN) $ spawnCmd myDmenuVPN
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
@ -98,7 +103,7 @@ runAppMenu :: SometimesX
runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: SometimesX
runClipMenu = sometimesIO "clipboard manager" deps act
runClipMenu = sometimesIO "clipboard manager" "rofi greenclip" deps act
where
act = spawnCmd myDmenuCmd args
deps = toAnd (sysExe myDmenuCmd) (sysExe "greenclip")
@ -111,18 +116,18 @@ runWinMenu :: SometimesX
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
runNetMenu :: SometimesX
runNetMenu =
sometimesExeArgs "network control menu" True myDmenuNetworks $ themeArgs "#ff3333"
runNetMenu = sometimesExeArgs "network control menu" "rofi NetworkManager"
True myDmenuNetworks $ themeArgs "#ff3333"
runAutorandrMenu :: SometimesX
runAutorandrMenu =
sometimesExeArgs "autorandr menu" True myDmenuMonitors $ themeArgs "#ff0066"
runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
True myDmenuMonitors $ themeArgs "#ff0066"
--------------------------------------------------------------------------------
-- | Shortcut menu
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
runShowKeys = Option showKeysDMenu (Always fallback)
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback)
where
-- TODO this should technically depend on dunst
fallback = const $ spawnNotify

View File

@ -92,10 +92,10 @@ ethernetIface = "enp7s0f1"
-- | Some nice apps
runTerm :: SometimesX
runTerm = sometimesExe "terminal" True myTerm
runTerm = sometimesExe "terminal" "urxvt" True myTerm
runTMux :: SometimesX
runTMux = sometimesIO "terminal multiplexer" deps act
runTMux = sometimesIO "terminal multiplexer" "tmux" deps act
where
deps = listToAnds (sysExe myTerm) $ fmap sysExe ["tmux", "bash"]
act = spawn
@ -106,27 +106,27 @@ runTMux = sometimesIO "terminal multiplexer" deps act
msg = "could not connect to tmux session"
runCalc :: SometimesX
runCalc = sometimesIO "calculator" deps act
runCalc = sometimesIO "calculator" "R" deps act
where
deps = toAnd (sysExe myTerm) (sysExe "R")
act = spawnCmd myTerm ["-e", "R"]
runBrowser :: SometimesX
runBrowser = sometimesExe "web browser" False myBrowser
runBrowser = sometimesExe "web browser" "brave" False myBrowser
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))"]
runFileManager :: SometimesX
runFileManager = sometimesExe "file browser" True "pcmanfm"
runFileManager = sometimesExe "file browser" "pcmanfm" True "pcmanfm"
--------------------------------------------------------------------------------
-- | Multimedia Commands
runMultimediaIfInstalled :: String -> String -> SometimesX
runMultimediaIfInstalled n cmd =
sometimesExeArgs (n ++ " multimedia control") True myMultimediaCtl [cmd]
runMultimediaIfInstalled n cmd = sometimesExeArgs (n ++ " multimedia control")
"playerctl" True myMultimediaCtl [cmd]
runTogglePlay :: SometimesX
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
@ -155,7 +155,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> SometimesX
featureSound n file pre post =
sometimesIO ("volume " ++ n ++ " control") (Only_ $ sysExe "paplay")
sometimesIO ("volume " ++ n ++ " control") "paplay" (Only_ $ sysExe "paplay")
$ pre >> playSound file >> post
runVolumeDown :: SometimesX
@ -172,7 +172,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
runNotificationCmd :: String -> FilePath -> SometimesX
runNotificationCmd n cmd =
sometimesExeArgs (n ++ " control") True myNotificationCtrl [cmd]
sometimesExeArgs (n ++ " control") "dunst" True myNotificationCtrl [cmd]
runNotificationClose :: SometimesX
runNotificationClose = runNotificationCmd "close notification" "close"
@ -194,7 +194,7 @@ runNotificationContext =
runToggleBluetooth :: SometimesX
runToggleBluetooth =
sometimesIO "bluetooth toggle" (Only_ $ sysExe myBluetooth)
sometimesIO "bluetooth toggle" "bluetoothctl" (Only_ $ sysExe myBluetooth)
$ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on"
@ -203,7 +203,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: SometimesX
runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
runToggleEthernet = sometimesIO "ethernet toggle" "nmcli" (Only_ $ sysExe "nmcli")
$ spawn
$ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
#!&& "a=connect"
@ -212,14 +212,16 @@ runToggleEthernet = sometimesIO "ethernet toggle" (Only_ $ sysExe "nmcli")
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: SometimesX
runStartISyncTimer = sometimesIO "isync timer" (Only_ $ sysdUser "mbsync.timer")
runStartISyncTimer = sometimesIO "isync timer" "mbsync timer"
(Only_ $ sysdUser "mbsync.timer")
$ spawn
$ "systemctl --user start mbsync.timer"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" }
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" }
runStartISyncService :: SometimesX
runStartISyncService = sometimesIO "isync" (Only_ $ sysdUser "mbsync.service")
runStartISyncService = sometimesIO "isync" "mbsync service"
(Only_ $ sysdUser "mbsync.service")
$ spawn
$ "systemctl --user start mbsync.service"
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@ -264,7 +266,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> SometimesX
runFlameshot n mode = sometimesIO n (Only_ $ sysExe myCapture)
runFlameshot n mode = sometimesIO n "flameshot" (Only_ $ sysExe myCapture)
$ spawnCmd myCapture [mode]
-- TODO this will steal focus from the current window (and puts it
@ -281,7 +283,7 @@ runScreenCapture :: SometimesX
runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: SometimesX
runCaptureBrowser =
sometimesIO "screen capture browser" (Only_ $ sysExe myImageBrowser) $ do
runCaptureBrowser = sometimesIO "screen capture browser" "feh"
(Only_ $ sysExe myImageBrowser) $ do
dir <- io getCaptureDir
spawnCmd myImageBrowser [dir]

View File

@ -49,7 +49,7 @@ myOptimusManager = "optimus-manager"
-- | Core commands
runScreenLock :: SometimesX
runScreenLock = sometimesExe "screen locker" True myScreenlock
runScreenLock = sometimesExe "screen locker" "i3lock script" True myScreenlock
runPowerOff :: X ()
runPowerOff = spawn "systemctl poweroff"
@ -104,8 +104,8 @@ runOptimusPrompt' = do
#!&& "killall xmonad"
runOptimusPrompt :: SometimesX
runOptimusPrompt = sometimesIO "graphics switcher" (Only_ $ localExe myOptimusManager)
runOptimusPrompt'
runOptimusPrompt = sometimesIO "graphics switcher" "optimus manager"
(Only_ $ localExe myOptimusManager) runOptimusPrompt'
--------------------------------------------------------------------------------
-- | Universal power prompt
@ -134,7 +134,7 @@ instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: AlwaysX
runPowerPrompt = always1 "power prompt" withLock powerPromptNoLock
runPowerPrompt = always1 "power prompt" "lock-enabled prompt" withLock powerPromptNoLock
where
withLock = IORoot powerPrompt (Only $ IOSometimes runScreenLock id)

View File

@ -113,9 +113,9 @@ handleACPI lock tag = do
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
-- and send ClientMessage events when it receives them
runPowermon :: SometimesIO
runPowermon = sometimesIO "ACPI event monitor" socketDep listenACPI
runPowermon = sometimesIO "ACPI event monitor" "acpid" socketDep listenACPI
runHandleACPI :: Always (String -> X ())
runHandleACPI = always1 "ACPI event handler" withLock $ handleACPI skip
runHandleACPI = always1 "ACPI event handler" "acpid" withLock $ handleACPI skip
where
withLock = IORoot handleACPI (Only $ IOSometimes runScreenLock id)

View File

@ -88,7 +88,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
brightnessExporter :: RealFrac b => [IODependency_] -> BrightnessConfig a b
-> Maybe Client -> SometimesIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)
sometimesDBus client n (n ++ " exporter") ds (exportBrightnessControls' bc)
where
ds = listToAnds (Bus xmonadBusName) $ fmap DBusIO deps
@ -132,7 +132,7 @@ callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
callBacklight client BrightnessConfig { bcPath = p
, bcInterface = i
, 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 [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

View File

@ -83,6 +83,6 @@ listenDevices client = do
runRemovableMon :: Maybe Client -> SometimesIO
runRemovableMon cl =
sometimesDBus cl "removeable device monitor" deps listenDevices
sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
where
deps = toAnd addedDep removedDep

View File

@ -96,7 +96,7 @@ bodyGetCurrentState _ = Nothing
exportScreensaver :: Maybe Client -> SometimesIO
exportScreensaver client =
sometimesDBus client "screensaver interface" (toAnd bus ssx) cmd
sometimesDBus client "screensaver toggle" "xset" (toAnd bus ssx) cmd
where
cmd cl = export cl ssPath defaultInterface
{ interfaceName = interface
@ -117,11 +117,11 @@ exportScreensaver client =
]
}
bus = Bus xmonadBusName
ssx = DBusIO $ IOSystem_ $ Executable True ssExecutable
ssx = DBusIO $ sysExe ssExecutable
callToggle :: Maybe Client -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" xmonadBusName ssPath
interface memToggle
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" xmonadBusName
ssPath interface memToggle
callQuery :: Client -> IO (Maybe SSState)
callQuery client = do

View File

@ -9,7 +9,9 @@ module XMonad.Internal.Dependency
-- feature types
( Feature
, Always(..)
, Sometimes
, Always_(..)
, Sometimes(..)
, Sometimes_
, AlwaysX
, AlwaysIO
, SometimesX
@ -137,26 +139,26 @@ dumpFeature = either dumpSometimes dumpAlways
-- | Dump the status of an Always to stdout
dumpAlways :: Always a -> IO JSONUnquotable
dumpAlways = go []
dumpAlways (Always n x) = go [] x
where
go failed (Option o os) = do
(s, r) <- dumpSubfeatureRoot o
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
go failed (Always _) = return $ jsonAlways (Just (UQ "true")) failed []
untested acc (Always _) = acc
go failed (Always_ _) = return $ jsonAlways (Q n) (Just (UQ "true")) failed []
untested acc (Always_ _) = acc
untested acc (Option o os) = untested (dataSubfeatureRoot o:acc) os
-- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> IO JSONUnquotable
dumpSometimes = go []
dumpSometimes (Sometimes n a) = go [] a
where
go failed [] = return $ jsonSometimes Nothing failed []
go failed [] = return $ jsonSometimes (Q n) Nothing failed []
go failed (x:xs) = do
(s, r) <- dumpSubfeatureRoot x
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
--------------------------------------------------------------------------------
@ -178,12 +180,18 @@ type Feature a = Either (Sometimes a) (Always a)
-- | Feature that is guaranteed to work
-- 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)
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
-- This is like an Always except it doesn't fall back on a guaranteed monadic
-- 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
-- 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)
-- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always a)
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail]
-- | Tested Sometimes feature
@ -287,20 +295,20 @@ data PostFail = PostFail [String] | PostMissing String
-- | Testing pipeline
evalSometimesMsg :: MonadIO m => Sometimes a -> m (Result a)
evalSometimesMsg x = io $ do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes x
evalSometimesMsg (Sometimes n xs) = io $ do
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
case s of
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False fs
_ -> Left <$> failedMsgs True fs
(Just (Subfeature { sfData = p })) -> Right . addMsgs p <$> failedMsgs False n fs
_ -> Left <$> failedMsgs True n fs
evalAlwaysMsg :: MonadIO m => Always a -> m (PostPass a)
evalAlwaysMsg x = io $ do
evalAlwaysMsg (Always n x) = io $ do
r <- testAlways x
case r of
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False fs
(Fallback act fs) -> PostPass act <$> failedMsgs False fs
(Primary (Subfeature { sfData = p }) fs _) -> addMsgs p <$> failedMsgs False n fs
(Fallback act fs) -> PostPass act <$> failedMsgs False n fs
testAlways :: Always a -> IO (PostAlways a)
testAlways :: Always_ a -> IO (PostAlways a)
testAlways = go []
where
go failed (Option fd next) = do
@ -308,9 +316,9 @@ testAlways = go []
case r of
(Left l) -> go (l: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 [])
where
go ts [] = return ts
@ -486,11 +494,14 @@ testDBusDependency_ _ (DBusIO i) = testIODependency_ i
-- | IO Lifting functions
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 (Always x) = Always $ io x
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
ioAlways (Always n x) = Always n $ ioAlways' x
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 sf = sf { sfData = ioRoot $ sfData sf }
@ -504,37 +515,39 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
--------------------------------------------------------------------------------
-- | Feature constructors
sometimes1_ :: LogLevel -> String -> Root a -> Sometimes a
sometimes1_ l n t = [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a
sometimes1_ l fn n t = Sometimes fn
[Subfeature{ sfData = t, sfName = n, sfLevel = l }]
always1_ :: LogLevel -> String -> Root a -> a -> Always a
always1_ l n t x =
Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always x)
always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a
always1_ l fn n t x = Always fn
$ 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
always1 :: String -> Root a -> a -> Always a
always1 :: String -> String -> Root a -> a -> Always a
always1 = always1_ Error
sometimesIO :: String -> Tree_ IODependency_ -> a -> Sometimes a
sometimesIO n t x = sometimes1 n $ IORoot_ x t
sometimesIO :: String -> String -> Tree_ IODependency_ -> a -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesExe :: MonadIO m => String -> Bool -> FilePath -> Sometimes (m ())
sometimesExe n sys path = sometimesExeArgs n sys path []
sometimesExe :: MonadIO m => String -> String -> Bool -> FilePath -> Sometimes (m ())
sometimesExe fn n sys path = sometimesExeArgs fn n sys path []
sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Sometimes (m ())
sometimesExeArgs n sys path args =
sometimesIO n (Only_ (IOSystem_ $ Executable sys path)) $ spawnCmd path args
sometimesExeArgs :: MonadIO m => String -> String -> Bool -> FilePath
-> [String] -> Sometimes (m ())
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
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 ())
sometimesEndpoint name busname path iface mem client =
sometimesDBus client name deps cmd
sometimesEndpoint fn name busname path iface mem client =
sometimesDBus client fn name deps cmd
where
deps = Only_ $ Endpoint busname path iface $ Method_ 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
jsonAlways :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
-> JSONUnquotable
jsonAlways :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
jsonAlways = jsonFeature True
jsonSometimes :: Maybe JSONUnquotable -> [JSONUnquotable] -> [JSONUnquotable]
-> JSONUnquotable
jsonSometimes :: JSONQuotable -> Maybe JSONUnquotable -> [JSONUnquotable]
-> [JSONUnquotable] -> JSONUnquotable
jsonSometimes = jsonFeature False
jsonFeature :: Bool -> Maybe JSONUnquotable -> [JSONUnquotable]
jsonFeature :: Bool -> JSONQuotable -> Maybe 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")
, ("name", JSON_Q name)
, ("success", JSON_UQ $ fromMaybe (UQ "null") success)
, ("failed", JSON_UQ $ jsonArray $ fmap JSON_UQ failed)
, ("untested", JSON_UQ $ jsonArray $ fmap JSON_UQ untested)
@ -826,16 +840,16 @@ curly s = "{" ++ s ++ "}"
--------------------------------------------------------------------------------
-- | Other random formatting
failedMsgs :: Bool -> [SubfeatureFail] -> IO [String]
failedMsgs err = fmap concat . mapM (failedMsg err)
failedMsgs :: Bool -> String -> [SubfeatureFail] -> IO [String]
failedMsgs err fn = fmap concat . mapM (failedMsg err fn)
failedMsg :: Bool -> SubfeatureFail -> IO [String]
failedMsg err Subfeature { sfData = d, sfName = n } = do
mapM (fmtMsg err n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
failedMsg :: Bool -> String -> SubfeatureFail -> IO [String]
failedMsg err fn Subfeature { sfData = d, sfName = n } = do
mapM (fmtMsg err fn n) $ case d of (PostMissing e) -> [e]; (PostFail es) -> es
fmtMsg :: Bool -> String -> String -> IO String
fmtMsg err n msg = do
fmtMsg :: Bool -> String -> String -> String -> IO String
fmtMsg err fn n msg = do
let e = if err then "ERROR" else "WARNING"
p <- getProgName
return $ unwords [bracket p, bracket e, bracket n, msg]
return $ unwords [bracket p, bracket e, bracket fn, bracket n, msg]