From 3e6f4c7e2754aa262170d40427d9df4778a59de2 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Tue, 28 Jun 2022 23:27:55 -0400 Subject: [PATCH] ENH give all features an overall name --- bin/xmobar.hs | 39 +++--- bin/xmonad.hs | 15 +- lib/XMonad/Internal/Command/DMenu.hs | 43 +++--- lib/XMonad/Internal/Command/Desktop.hs | 36 ++--- lib/XMonad/Internal/Command/Power.hs | 8 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 4 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- lib/XMonad/Internal/DBus/Removable.hs | 2 +- lib/XMonad/Internal/DBus/Screensaver.hs | 8 +- lib/XMonad/Internal/Dependency.hs | 128 ++++++++++-------- 10 files changed, 156 insertions(+), 131 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 0e48291..62348b5 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -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 diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 64020e9..ab3f367 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -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-" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5 + , KeyBinding "M-" "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-" "power menu" $ Right runPowerPrompt - , KeyBinding "M-" "quit xmonad" $ ftrAlways runQuitPrompt + , KeyBinding "M-" "quit xmonad" quitf , KeyBinding "M-" "lock screen" $ Left runScreenLock -- M- reserved for showing the keymap - , KeyBinding "M-" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart) - , KeyBinding "M-" "recompile xmonad" $ ftrAlways runRecompile + , KeyBinding "M-" "restart xmonad" restartf + , KeyBinding "M-" "recompile xmonad" recompilef , KeyBinding "M-" "start Isync Service" $ Left runStartISyncService , KeyBinding "M-C-" "start Isync Timer" $ Left runStartISyncTimer , KeyBinding "M-" "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 ()) diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 8428b5c..d0ef3f7 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -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,24 +72,29 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity -- | Exported Commands runDevMenu :: SometimesX -runDevMenu = sometimesIO "device manager" (Only_ $ localExe myDmenuDevices) $ do - c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" - spawnCmd myDmenuDevices - $ ["-c", c] - ++ "--" : themeArgs "#999933" - ++ myDmenuMatchingArgs +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] + ++ "--" : themeArgs "#999933" + ++ 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 diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index e23f982..f37c1bc 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -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] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 366f1f5..daf51c4 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -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) diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index 7a2dae2..b3de6c2 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -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) diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 9414087..f1e4c97 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -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) diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 301afc8..85b3a0b 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index be34ebe..c353891 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index e3e3ae3..e91cc57 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -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]