ENH use a bunch of nested feature stuff
This commit is contained in:
parent
01e991f182
commit
5907035e9d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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\""
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ runOptimusPrompt' = do
|
|||
#!&& "killall xmonad"
|
||||
|
||||
runOptimusPrompt :: FeatureX
|
||||
runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager]
|
||||
runOptimusPrompt = featureDefault "graphics switcher" (Only $ exe myOptimusManager)
|
||||
runOptimusPrompt'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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,8 +109,12 @@ 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_
|
||||
feature n w t = Feature f NoFeature
|
||||
where
|
||||
f = Feature_
|
||||
{ ftrDepTree = t
|
||||
, ftrName = n
|
||||
, ftrWarning = w
|
||||
|
|
@ -109,9 +122,11 @@ feature n w t = Feature $ Feature_
|
|||
|
||||
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 (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"
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue