ENH use a bunch of nested feature stuff

This commit is contained in:
Nathan Dwarshuis 2022-06-17 00:37:12 -04:00
parent 01e991f182
commit 5907035e9d
12 changed files with 221 additions and 116 deletions

View File

@ -292,46 +292,47 @@ rightPlugins sysClient sesClient = mapM evalFeature
getWireless :: BarFeature getWireless :: BarFeature
getWireless = feature "wireless status indicator" Default 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 :: Maybe Client -> BarFeature
getEthernet client = feature "ethernet status indicator" Default getEthernet client = feature "ethernet status indicator" Default
$ DBusTree action client [devDep] [] $ DBusTree action client (Only $ fullDep devDep)
where where
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet) action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
getBattery :: BarFeature getBattery :: BarFeature
getBattery = feature "battery level indicator" Default getBattery = feature "battery level indicator" Default
$ GenTree (Single batteryCmd) [IOTest desc hasBattery] $ GenTree (Single batteryCmd) (Only $ fullDep $ IOTest desc hasBattery)
where where
desc = "Test if battery is present" desc = "Test if battery is present"
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN client = feature "VPN status indicator" Default 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 where
dp = IOTest desc vpnPresent dp = fullDep $ DBusGenDep $ IOTest desc vpnPresent
desc = "Use nmcli to test if VPN is present" desc = "Use nmcli to test if VPN is present"
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = feature "bluetooth status indicator" Default getBt client = feature "bluetooth status indicator" Default
$ DBusTree (Single (const btCmd)) client [btDep] [] $ DBusTree (Single (const btCmd)) client (Only $ fullDep btDep)
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = feature "volume level indicator" Default getAlsa = feature "volume level indicator" Default
$ GenTree (Single alsaCmd) [Executable "alsactl"] $ GenTree (Single alsaCmd) (Only $ exe "alsactl")
getBl :: Maybe Client -> BarFeature getBl :: Maybe Client -> BarFeature
getBl client = feature "Intel backlight indicator" Default 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 :: Maybe Client -> BarFeature
getCk client = feature "Clevo keyboard indicator" Default 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 :: Maybe Client -> BarFeature
getSs client = feature "screensaver indicator" Default 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 :: [MaybeAction CmdSpec] -> IO BarRegions
getAllCommands right = do getAllCommands right = do

View File

@ -122,32 +122,32 @@ run = do
forkIO_ = void . forkIO forkIO_ = void . forkIO
printDeps :: IO () printDeps :: IO ()
printDeps = do printDeps = skip
(i, x) <- allFeatures -- (i, x) <- allFeatures
mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x -- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
where -- where
extractFeatures (Feature f) = dtDeps $ ftrDepTree f -- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
extractFeatures (ConstFeature _) = [] -- extractFeatures (ConstFeature _) = []
dtDeps (GenTree _ ds) = ds -- dtDeps (GenTree _ ds) = ds
dtDeps (DBusTree _ _ _ ds) = ds -- dtDeps (DBusTree _ _ ds) = ds
printDep = putStrLn . depName -- printDep (FullDep d) = putStrLn . depName d
allFeatures :: IO ([FeatureIO], [FeatureX]) -- allFeatures :: IO ([FeatureIO], [FeatureX])
allFeatures = do -- allFeatures = do
ses <- getDBusClient False -- ses <- getDBusClient False
sys <- getDBusClient True -- sys <- getDBusClient True
let db = DBusState ses sys -- let db = DBusState ses sys
lockRes <- evalFeature runScreenLock -- lockRes <- evalFeature runScreenLock
let lock = whenSatisfied lockRes -- let lock = whenSatisfied lockRes
let bfs = concatMap (fmap kbMaybeAction . kgBindings) -- let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db lock -- $ externalBindings ts db lock
let dbus = fmap (\f -> f ses) dbusExporters -- let dbus = fmap (\f -> f ses) dbusExporters
let others = [runRemovableMon sys, runPowermon] -- let others = [runRemovableMon sys, runPowermon]
forM_ ses disconnect -- forM_ ses disconnect
forM_ sys disconnect -- forM_ sys disconnect
return (dbus ++ others, bfs) -- return (dbus ++ others, bfs)
where -- where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] } -- ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage = putStrLn $ intercalate "\n"

View File

@ -72,7 +72,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
-- | Exported Commands -- | Exported Commands
runDevMenu :: FeatureX runDevMenu :: FeatureX
runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do runDevMenu = featureDefault "device manager" (Only $ exe myDmenuDevices) $ do
c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
spawnCmd myDmenuDevices spawnCmd myDmenuDevices
$ ["-c", c] $ ["-c", c]
@ -84,11 +84,11 @@ runBTMenu = featureExeArgs "bluetooth selector" myDmenuBluetooth
$ "-c":themeArgs "#0044bb" $ "-c":themeArgs "#0044bb"
runBwMenu :: FeatureX runBwMenu :: FeatureX
runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $ runBwMenu = featureDefault "password manager" (Only $ exe myDmenuPasswords) $
spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
runVPNMenu :: FeatureX runVPNMenu :: FeatureX
runVPNMenu = featureDefault "VPN selector" [Executable myDmenuVPN] $ runVPNMenu = featureDefault "VPN selector" (Only $ exe myDmenuVPN) $
spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs spawnCmd myDmenuVPN $ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
-- TODO this is weirdly inverted -- TODO this is weirdly inverted
@ -101,7 +101,7 @@ runShowKeys x = addName "Show Keybindings" $ do
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
runDMenuShowKeys kbs = 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 } (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
where where
@ -116,7 +116,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
runClipMenu :: FeatureX runClipMenu :: FeatureX
runClipMenu = runClipMenu =
featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"] featureDefault "clipboard manager" (And (Only $ exe myDmenuCmd) (Only $ exe "greenclip"))
$ spawnCmd myDmenuCmd args $ spawnCmd myDmenuCmd args
where where
args = [ "-modi", "\"clipboard:greenclip print\"" args = [ "-modi", "\"clipboard:greenclip print\""

View File

@ -97,7 +97,7 @@ runTerm = featureExe "terminal" myTerm
runTMux :: FeatureX runTMux :: FeatureX
runTMux = featureDefault "terminal multiplexer" deps cmd runTMux = featureDefault "terminal multiplexer" deps cmd
where where
deps = [Executable myTerm, Executable "tmux", Executable "bash"] deps = listToAnds (exe myTerm) $ fmap exe ["tmux", "bash"]
cmd = spawn cmd = spawn
$ "tmux has-session" $ "tmux has-session"
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
@ -106,7 +106,7 @@ runTMux = featureDefault "terminal multiplexer" deps cmd
msg = "could not connect to tmux session" msg = "could not connect to tmux session"
runCalc :: FeatureX runCalc :: FeatureX
runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"] runCalc = featureDefault "calculator" (And (Only $ exe myTerm) (Only $ exe "R"))
$ spawnCmd myTerm ["-e", "R"] $ spawnCmd myTerm ["-e", "R"]
runBrowser :: FeatureX runBrowser :: FeatureX
@ -153,7 +153,7 @@ playSound file = do
featureSound :: String -> FilePath -> X () -> X () -> FeatureX featureSound :: String -> FilePath -> X () -> X () -> FeatureX
featureSound n file pre post = featureSound n file pre post =
featureDefault ("volume " ++ n ++ " control") [Executable "paplay"] featureDefault ("volume " ++ n ++ " control") (Only $ exe "paplay")
$ pre >> playSound file >> post $ pre >> playSound file >> post
runVolumeDown :: FeatureX runVolumeDown :: FeatureX
@ -192,7 +192,7 @@ runNotificationContext =
runToggleBluetooth :: FeatureX runToggleBluetooth :: FeatureX
runToggleBluetooth = runToggleBluetooth =
featureDefault "bluetooth toggle" [Executable myBluetooth] featureDefault "bluetooth toggle" (Only $ exe myBluetooth)
$ spawn $ spawn
$ myBluetooth ++ " show | grep -q \"Powered: no\"" $ myBluetooth ++ " show | grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
@ -201,7 +201,7 @@ runToggleBluetooth =
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
runToggleEthernet :: FeatureX runToggleEthernet :: FeatureX
runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"] runToggleEthernet = featureDefault "ethernet toggle" (Only $ exe "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"
@ -210,14 +210,14 @@ runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
runStartISyncTimer :: FeatureX runStartISyncTimer :: FeatureX
runStartISyncTimer = featureDefault "isync timer" [userUnit "mbsync.timer"] runStartISyncTimer = featureDefault "isync timer" (Only $ userUnit "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 :: FeatureX runStartISyncService :: FeatureX
runStartISyncService = featureDefault "isync" [userUnit "mbsync.service"] runStartISyncService = featureDefault "isync" (Only $ userUnit "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" }
@ -262,7 +262,7 @@ getCaptureDir = do
fallback = (</> ".local/share") <$> getHomeDirectory fallback = (</> ".local/share") <$> getHomeDirectory
runFlameshot :: String -> String -> FeatureX runFlameshot :: String -> String -> FeatureX
runFlameshot n mode = featureDefault n [Executable myCapture] runFlameshot n mode = featureDefault n (Only $ exe 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
@ -280,6 +280,6 @@ runScreenCapture = runFlameshot "screen capture" "screen"
runCaptureBrowser :: FeatureX runCaptureBrowser :: FeatureX
runCaptureBrowser = runCaptureBrowser =
featureDefault "screen capture browser" [Executable myImageBrowser] $ do featureDefault "screen capture browser" (Only $ exe myImageBrowser) $ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [dir] spawnCmd myImageBrowser [dir]

View File

@ -101,7 +101,7 @@ runOptimusPrompt' = do
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: FeatureX runOptimusPrompt :: FeatureX
runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager] runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager)
runOptimusPrompt' runOptimusPrompt'
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View File

@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket"
-- | 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 :: FeatureIO 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 -- | Handle ClientMessage event containing and ACPI event (to be used in
-- Xmonad's event hook) -- Xmonad's event hook)

View File

@ -107,10 +107,10 @@ clevoKeyboardConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
stateFileDep :: Dependency stateFileDep :: FullDep Dependency
stateFileDep = pathRW stateFile stateFileDep = pathRW stateFile
brightnessFileDep :: Dependency brightnessFileDep :: FullDep Dependency
brightnessFileDep = pathR brightnessFile brightnessFileDep = pathR brightnessFile
clevoKeyboardSignalDep :: DBusDep clevoKeyboardSignalDep :: DBusDep

View File

@ -85,11 +85,14 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal DBus Crap -- | Internal DBus Crap
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b brightnessExporter :: RealFrac b => [FullDep Dependency] -> BrightnessConfig a b
-> Maybe Client -> FeatureIO -> Maybe Client -> FeatureIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
(n ++ " exporter") Default (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' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
exportBrightnessControls' bc client = do exportBrightnessControls' bc client = do

View File

@ -89,10 +89,10 @@ intelBacklightConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
curFileDep :: Dependency curFileDep :: FullDep Dependency
curFileDep = pathRW curFile curFileDep = pathRW curFile
maxFileDep :: Dependency maxFileDep :: FullDep Dependency
maxFileDep = pathR maxFile maxFileDep = pathR maxFile
intelBacklightSignalDep :: DBusDep intelBacklightSignalDep :: DBusDep

View File

@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> DBusDep dbusDep :: MemberName -> FullDep DBusDep
dbusDep m = Endpoint bus path interface $ Signal_ m dbusDep m = fullDep $ Endpoint bus path interface $ Signal_ m
addedDep :: DBusDep addedDep :: FullDep DBusDep
addedDep = dbusDep memAdded addedDep = dbusDep memAdded
removedDep :: DBusDep removedDep :: FullDep DBusDep
removedDep = dbusDep memRemoved removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath driveInsertedSound :: FilePath
@ -83,4 +83,4 @@ listenDevices client = do
runRemovableMon :: Maybe Client -> FeatureIO runRemovableMon :: Maybe Client -> FeatureIO
runRemovableMon client = feature "removeable device monitor" Default runRemovableMon client = feature "removeable device monitor" Default
$ DBusTree (Single listenDevices) client [addedDep, removedDep] [] $ DBusTree (Single listenDevices) client $ And (Only addedDep) (Only removedDep)

View File

@ -95,11 +95,8 @@ bodyGetCurrentState _ = Nothing
-- | Exported haskell API -- | Exported haskell API
exportScreensaver :: Maybe Client -> FeatureIO exportScreensaver :: Maybe Client -> FeatureIO
exportScreensaver client = Feature $ Feature_ exportScreensaver client = feature "screensaver interface" Default
{ ftrDepTree = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable] $ DBusTree (Single cmd) client (And (Only bus) (Only ssx))
, ftrName = "screensaver interface"
, ftrWarning = Default
}
where where
cmd cl = export cl ssPath defaultInterface cmd cl = export cl ssPath defaultInterface
{ interfaceName = interface { interfaceName = interface
@ -119,6 +116,8 @@ exportScreensaver client = Feature $ Feature_
} }
] ]
} }
bus = fullDep $ Bus xmonadBusName
ssx = fullDep $ DBusGenDep $ Executable ssExecutable
callToggle :: Maybe Client -> FeatureIO callToggle :: Maybe Client -> FeatureIO
callToggle = callToggle =

View File

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -6,7 +7,10 @@
module XMonad.Internal.Dependency module XMonad.Internal.Dependency
( MaybeAction ( MaybeAction
, AnyFeature(..)
, DepChoice(..)
, MaybeX , MaybeX
, FullDep(..)
, DepTree(..) , DepTree(..)
, Action(..) , Action(..)
, DBusDep(..) , DBusDep(..)
@ -37,6 +41,9 @@ module XMonad.Internal.Dependency
, executeFeatureWith , executeFeatureWith
, executeFeatureWith_ , executeFeatureWith_
, depName , depName
, fullDep
, exe
, listToAnds
) where ) where
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -44,7 +51,7 @@ import Control.Monad.Identity
-- import Data.Aeson -- import Data.Aeson
import Data.List (find) import Data.List (find)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Maybe
-- import qualified Data.Text as T -- import qualified Data.Text as T
import DBus import DBus
@ -90,7 +97,9 @@ data Feature_ a = Feature_
, ftrWarning :: Warning , 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 -- TODO this is silly as is, and could be made more useful by representing
-- loglevels -- loglevels
@ -100,8 +109,12 @@ type FeatureX = Feature (X ())
type FeatureIO = Feature (IO ()) type FeatureIO = Feature (IO ())
data AnyFeature = FX FeatureX | FIO FeatureIO
feature :: String -> Warning -> DepTree a -> Feature a feature :: String -> Warning -> DepTree a -> Feature a
feature n w t = Feature $ Feature_ feature n w t = Feature f NoFeature
where
f = Feature_
{ ftrDepTree = t { ftrDepTree = t
, ftrName = n , ftrName = n
, ftrWarning = w , ftrWarning = w
@ -109,9 +122,11 @@ feature n w t = Feature $ Feature_
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b) ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
ioFeature (ConstFeature a) = ConstFeature $ liftIO a 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 featureDefault n ds x = feature n Default $ GenTree (Single x) ds
featureExe :: MonadIO m => String -> String -> Feature (m ()) 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 :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args = 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 featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> Maybe Client -> FeatureIO -> MemberName -> Maybe Client -> FeatureIO
featureEndpoint name busname path iface mem client = feature name Default featureEndpoint name busname path iface mem client = feature name Default
$ DBusTree (Single cmd) client deps [] $ DBusTree (Single cmd) client deps
where where
cmd c = void $ callMethod c busname path iface mem 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 -- | 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). -- DBus client to evaluate (and will automatically fail if this is missing).
-- The former can be evaluated independently. -- The former can be evaluated independently.
data DepTree a = GenTree (Action a) [Dependency] data DepChoice a = And (DepChoice a) (DepChoice a)
| DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency] | 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 instance Functor DepTree where
fmap f (GenTree a ds) = GenTree (f <$> a) ds 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 (DBusTree a c ds) = DBusTree (fmap (fmap f) a) c ds
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Actions -- | Actions
@ -169,9 +191,11 @@ type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a) evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Just x 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 procName <- getProgName
res <- evalTree a res <- evalTree =<< evalTree' a
either (printWarnings procName) (return . Just) res either (printWarnings procName) (return . Just) res
where where
printWarnings procName es = do 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] fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
bracket s = "[" ++ s ++ "]" 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 :: 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 fullDepMsg :: FullDep a -> Maybe String
es <- catMaybes <$> mapM evalDependency ds fullDepMsg (FullDep e _) = either Just (const Nothing) e
case es of
[] -> do evalTree' :: DepTree a -> IO (DepTree a)
action' <- evalAction action
return $ case action' of evalTree' (GenTree a ds) = GenTree a <$> mapMDepChoice eval pass ds
Right f -> Right f where
Left es' -> Left es' eval (FullDep _ d) = do
es' -> return $ Left es' 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 :: Action a -> IO (Either [String] a)
evalAction (Single a) = return $ Right a evalAction (Single a) = return $ Right a
@ -236,27 +323,36 @@ ifSatisfied _ alt = alt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependencies (General) -- | Dependencies (General)
data FullDep a = FullDep (Either String Bool) a deriving (Functor)
fullDep :: a -> FullDep a
fullDep = FullDep (Right True)
data Dependency = Executable String data Dependency = Executable String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String)) | IOTest String (IO (Maybe String))
| Systemd UnitType String | Systemd UnitType String
| DepFeature AnyFeature
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
pathR :: String -> Dependency exe :: String -> FullDep Dependency
pathR n = AccessiblePath n True False exe = fullDep . Executable
pathW :: String -> Dependency pathR :: String -> FullDep Dependency
pathW n = AccessiblePath n False True pathR n = fullDep $ AccessiblePath n True False
pathRW :: String -> Dependency pathW :: String -> FullDep Dependency
pathRW n = AccessiblePath n True True pathW n = fullDep $ AccessiblePath n False True
systemUnit :: String -> Dependency pathRW :: String -> FullDep Dependency
systemUnit = Systemd SystemUnit pathRW n = fullDep $ AccessiblePath n True True
userUnit :: String -> Dependency systemUnit :: String -> FullDep Dependency
userUnit = Systemd UserUnit systemUnit = fullDep . Systemd SystemUnit
userUnit :: String -> FullDep Dependency
userUnit = fullDep . Systemd UserUnit
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependencies (DBus) -- | Dependencies (DBus)
@ -269,7 +365,7 @@ data DBusMember = Method_ MemberName
data DBusDep = data DBusDep =
Bus BusName Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember | Endpoint BusName ObjectPath InterfaceName DBusMember
deriving (Eq, Show) | DBusGenDep Dependency
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency evaluation (General) -- | Dependency evaluation (General)
@ -282,6 +378,9 @@ evalDependency (Executable n) = exeSatisfied n
evalDependency (IOTest _ t) = t evalDependency (IOTest _ t) = t
evalDependency (Systemd t n) = unitSatisfied t n evalDependency (Systemd t n) = unitSatisfied t n
evalDependency (AccessiblePath p r w) = pathSatisfied p r w 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 :: String -> IO (Maybe String)
exeSatisfied x = do exeSatisfied x = do
@ -374,6 +473,8 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
, formatBusName busname , formatBusName busname
] ]
dbusDepSatisfied _ (DBusGenDep d) = evalDependency d
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing dependencies -- | Printing dependencies
@ -410,4 +511,5 @@ depName (Systemd t n) = "systemd (" ++ tp t ++ "): " ++ n
tp SystemUnit = "sys" tp SystemUnit = "sys"
tp UserUnit = "user" tp UserUnit = "user"
depName (AccessiblePath p _ _) = "path: " ++ p depName (AccessiblePath p _ _) = "path: " ++ p
depName (DepFeature _) = "feature: blablabla"