REF clean up dep module (again)

This commit is contained in:
Nathan Dwarshuis 2021-11-22 23:46:51 -05:00
parent 6417a832c5
commit db42b83d48
2 changed files with 78 additions and 68 deletions

View File

@ -79,7 +79,7 @@ main = do
sesClient <- startXMonadService sesClient <- startXMonadService
sysClient <- getDBusClient True sysClient <- getDBusClient True
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient] mapM_ (executeFeatureWith_ forkIO_) [runPowermon, runRemovableMon sysClient]
forkIO_ $ runWorkspaceMon allDWs forkIO_ $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
{ tsSessionClient = sesClient { tsSessionClient = sesClient

View File

@ -32,8 +32,8 @@ module XMonad.Internal.Dependency
, ifSatisfied , ifSatisfied
, executeFeature , executeFeature
, executeFeature_ , executeFeature_
, applyFeature , executeFeatureWith
, applyFeature_ , executeFeatureWith_
, callMethod , callMethod
) where ) where
@ -60,36 +60,22 @@ import XMonad.Internal.Shell
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Features -- | Features
-- --
-- A 'feature' is an 'action' (usually an IO ()) that requires one or more -- A 'feature' is composed of a 'dependency tree' which at the root has an
-- 'dependencies'. Features also have a useful name and an error logging -- 'action' to be performed with a number of 'dependencies' below it.
-- protocol.
-- --
-- NOTE: there is no way to make a feature depend on another feature. This is -- NOTE: there is no way to make a feature depend on another feature. This is
-- very complicated to implement and would only be applicable to a few instances -- very complicated to implement and would only be applicable to a few instances
-- (notable the dbus interfaces). In order to implement a dependency tree, use -- (notably the dbus interfaces). In order to implement a dependency tree, use
-- dependencies that target the output/state of another feature; this is more -- dependencies that target the output/state of another feature; this is more
-- robust anyways, at the cost of being a bit slower. -- robust anyways, at the cost of being a bit slower.
data Feature a = Feature data Feature a = Feature
{ ftrDepTree :: DepTree a { ftrDepTree :: DepTree a
, ftrName :: String , ftrName :: String
, ftrWarning :: Warning , ftrWarning :: Warning
} }
| ConstFeature a | ConstFeature a
data DepTree a = GenTree (Action a) [Dependency]
| DBusTree (Action (Client -> a)) (Maybe Client) [DBusDep] [Dependency]
data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
instance Functor Action where
fmap f (Single a) = Single (f a)
fmap f (Double a b) = Double (f . a) b
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
-- 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
data Warning = Silent | Default data Warning = Silent | Default
@ -131,6 +117,33 @@ featureEndpoint busname path iface mem client = Feature
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 = [Endpoint busname path iface $ Method_ mem]
--------------------------------------------------------------------------------
-- | Dependency Trees
--
-- Dependency trees have two subtypes: general and DBus. The latter require a
-- 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]
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
--------------------------------------------------------------------------------
-- | Actions
--
-- Actions have two subtypes: single and double. Single actions are just one
-- independent action. Double actions have one dependent pre-step which the
-- main action consumes (and fails if the pre-step fails).
data Action a = Single a | forall b. Double (b -> a) (IO (Either [String] b))
instance Functor Action where
fmap f (Single a) = Single (f a)
fmap f (Double a b) = Double (f . a) b
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature evaluation -- | Feature evaluation
-- --
@ -142,6 +155,27 @@ type MaybeAction a = Maybe a
type MaybeX = MaybeAction (X ()) type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Just x
evalFeature Feature
{ ftrDepTree = a
, ftrName = n
, ftrWarning = w
} = do
procName <- getProgName
res <- evalTree a
either (printWarnings procName) (return . Just) res
where
printWarnings procName es = do
case w of
Silent -> skip
Default -> let prefix = n ++ " disabled; "
es' = fmap (fmtMsg procName . (prefix ++)) es in
mapM_ putStrLn es'
return Nothing
fmtMsg procName msg = unwords [bracket procName, bracket "WARNING", msg]
bracket s = "[" ++ s ++ "]"
evalTree :: DepTree a -> IO (Either [String] a) evalTree :: DepTree a -> IO (Either [String] a)
evalTree (GenTree action ds) = do evalTree (GenTree action ds) = do
@ -170,32 +204,16 @@ evalAction :: Action a -> IO (Either [String] a)
evalAction (Single a) = return $ Right a evalAction (Single a) = return $ Right a
evalAction (Double a b) = fmap a <$> b evalAction (Double a b) = fmap a <$> b
evalFeature :: Feature a -> IO (MaybeAction a) executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
evalFeature (ConstFeature x) = return $ Just x executeFeatureWith iof def ftr = do
evalFeature Feature
{ ftrDepTree = a
, ftrName = n
, ftrWarning = w
} = do
procName <- getProgName
res <- evalTree a
either (\es -> printWarnings procName es >> return Nothing) (return . Just) res
where
printWarnings procName es = case w of
Silent -> return ()
Default -> mapM_ putStrLn $ fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
-- TODO this should be 'executeFeatureWith'
applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
applyFeature iof def ftr = do
a <- io $ evalFeature ftr a <- io $ evalFeature ftr
maybe (return def) (iof . io) a maybe (return def) (iof . io) a
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m () executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
applyFeature_ iof = applyFeature iof () executeFeatureWith_ iof = executeFeatureWith iof ()
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
executeFeature = applyFeature id executeFeature = executeFeatureWith id
executeFeature_ :: Feature (IO ()) -> IO () executeFeature_ :: Feature (IO ()) -> IO ()
executeFeature_ = executeFeature () executeFeature_ = executeFeature ()
@ -208,7 +226,7 @@ ifSatisfied (Just x) _ = x
ifSatisfied _ alt = alt ifSatisfied _ alt = alt
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependencies -- | Dependencies (General)
data Dependency = Executable String data Dependency = Executable String
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
@ -217,16 +235,6 @@ data Dependency = Executable String
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data DBusDep =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
deriving (Eq, Show)
pathR :: String -> Dependency pathR :: String -> Dependency
pathR n = AccessiblePath n True False pathR n = AccessiblePath n True False
@ -243,7 +251,20 @@ userUnit :: String -> Dependency
userUnit = Systemd UserUnit userUnit = Systemd UserUnit
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency evaluation -- | Dependencies (DBus)
data DBusMember = Method_ MemberName
| Signal_ MemberName
| Property_ String
deriving (Eq, Show)
data DBusDep =
Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember
deriving (Eq, Show)
--------------------------------------------------------------------------------
-- | Dependency evaluation (General)
-- --
-- Test the existence of dependencies and return either Nothing (which actually -- Test the existence of dependencies and return either Nothing (which actually
-- means success) or Just <error message>. -- means success) or Just <error message>.
@ -289,6 +310,9 @@ pathSatisfied p testread testwrite = do
(_, Just False) -> Just "file not writable" (_, Just False) -> Just "file not writable"
_ -> Nothing _ -> Nothing
--------------------------------------------------------------------------------
-- | Dependency evaluation (DBus)
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -349,17 +373,3 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
, "on bus" , "on bus"
, formatBusName busname , formatBusName busname
] ]
--------------------------------------------------------------------------------
-- | Logging functions
-- warnMissing :: [MaybeAction a] -> IO ()
-- warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
-- warnMissing' :: [String] -> IO ()
-- warnMissing' = mapM_ putStrLn
fmtMsg :: String -> String -> String -> String
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
where
bracket s = "[" ++ s ++ "]"