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