REF clean up dep module (again)
This commit is contained in:
parent
6417a832c5
commit
db42b83d48
|
|
@ -79,7 +79,7 @@ main = do
|
|||
sesClient <- startXMonadService
|
||||
sysClient <- getDBusClient True
|
||||
(h, p) <- spawnPipe "xmobar"
|
||||
mapM_ (applyFeature_ forkIO_) [runPowermon, runRemovableMon sysClient]
|
||||
mapM_ (executeFeatureWith_ forkIO_) [runPowermon, runRemovableMon sysClient]
|
||||
forkIO_ $ runWorkspaceMon allDWs
|
||||
let ts = ThreadState
|
||||
{ tsSessionClient = sesClient
|
||||
|
|
|
|||
|
|
@ -32,8 +32,8 @@ module XMonad.Internal.Dependency
|
|||
, ifSatisfied
|
||||
, executeFeature
|
||||
, executeFeature_
|
||||
, applyFeature
|
||||
, applyFeature_
|
||||
, executeFeatureWith
|
||||
, executeFeatureWith_
|
||||
, callMethod
|
||||
) where
|
||||
|
||||
|
|
@ -60,13 +60,12 @@ import XMonad.Internal.Shell
|
|||
--------------------------------------------------------------------------------
|
||||
-- | Features
|
||||
--
|
||||
-- A 'feature' is an 'action' (usually an IO ()) that requires one or more
|
||||
-- 'dependencies'. Features also have a useful name and an error logging
|
||||
-- protocol.
|
||||
-- A 'feature' is composed of a 'dependency tree' which at the root has an
|
||||
-- 'action' to be performed with a number of 'dependencies' below it.
|
||||
--
|
||||
-- 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
|
||||
-- (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
|
||||
-- robust anyways, at the cost of being a bit slower.
|
||||
|
||||
|
|
@ -77,19 +76,6 @@ data Feature a = Feature
|
|||
}
|
||||
| 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
|
||||
-- loglevels
|
||||
data Warning = Silent | Default
|
||||
|
|
@ -131,6 +117,33 @@ featureEndpoint busname path iface mem client = Feature
|
|||
cmd = \c -> void $ callMethod c busname path iface 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
|
||||
--
|
||||
|
|
@ -142,6 +155,27 @@ type MaybeAction a = Maybe a
|
|||
|
||||
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 (GenTree action ds) = do
|
||||
|
|
@ -170,32 +204,16 @@ evalAction :: Action a -> IO (Either [String] a)
|
|||
evalAction (Single a) = return $ Right a
|
||||
evalAction (Double a b) = fmap a <$> b
|
||||
|
||||
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 (\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
|
||||
executeFeatureWith :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
|
||||
executeFeatureWith iof def ftr = do
|
||||
a <- io $ evalFeature ftr
|
||||
maybe (return def) (iof . io) a
|
||||
|
||||
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
|
||||
applyFeature_ iof = applyFeature iof ()
|
||||
executeFeatureWith_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
|
||||
executeFeatureWith_ iof = executeFeatureWith iof ()
|
||||
|
||||
executeFeature :: MonadIO m => a -> Feature (IO a) -> m a
|
||||
executeFeature = applyFeature id
|
||||
executeFeature = executeFeatureWith id
|
||||
|
||||
executeFeature_ :: Feature (IO ()) -> IO ()
|
||||
executeFeature_ = executeFeature ()
|
||||
|
|
@ -208,7 +226,7 @@ ifSatisfied (Just x) _ = x
|
|||
ifSatisfied _ alt = alt
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Dependencies
|
||||
-- | Dependencies (General)
|
||||
|
||||
data Dependency = Executable String
|
||||
| AccessiblePath FilePath Bool Bool
|
||||
|
|
@ -217,16 +235,6 @@ data Dependency = Executable String
|
|||
|
||||
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 n = AccessiblePath n True False
|
||||
|
||||
|
|
@ -243,7 +251,20 @@ userUnit :: String -> Dependency
|
|||
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
|
||||
-- means success) or Just <error message>.
|
||||
|
|
@ -289,6 +310,9 @@ pathSatisfied p testread testwrite = do
|
|||
(_, Just False) -> Just "file not writable"
|
||||
_ -> Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Dependency evaluation (DBus)
|
||||
|
||||
introspectInterface :: InterfaceName
|
||||
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
|
||||
|
||||
|
|
@ -349,17 +373,3 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
|
|||
, "on bus"
|
||||
, 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 ++ "]"
|
||||
|
|
|
|||
Loading…
Reference in New Issue