ENH print warnings/errors immediately for dependencies
This commit is contained in:
parent
010b612b93
commit
b4380695d0
|
@ -55,9 +55,7 @@ main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
sysClient <- getDBusClient True
|
sysClient <- getDBusClient True
|
||||||
sesClient <- getDBusClient False
|
sesClient <- getDBusClient False
|
||||||
rs <- rightPlugins sysClient sesClient
|
cs <- getAllCommands =<< rightPlugins sysClient sesClient
|
||||||
warnMissing rs
|
|
||||||
cs <- getAllCommands rs
|
|
||||||
d <- getXMonadDir
|
d <- getXMonadDir
|
||||||
-- this is needed to see any printed messages
|
-- this is needed to see any printed messages
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
|
@ -364,11 +362,8 @@ getAllCommands right = do
|
||||||
return $ BarRegions
|
return $ BarRegions
|
||||||
{ brLeft = left
|
{ brLeft = left
|
||||||
, brCenter = []
|
, brCenter = []
|
||||||
, brRight = mapMaybe eval right
|
, brRight = catMaybes right
|
||||||
}
|
}
|
||||||
where
|
|
||||||
eval (Right x) = Just x
|
|
||||||
eval _ = Nothing
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | various formatting things
|
-- | various formatting things
|
||||||
|
|
|
@ -90,7 +90,6 @@ main = do
|
||||||
lockRes <- evalFeature runScreenLock
|
lockRes <- evalFeature runScreenLock
|
||||||
let lock = whenSatisfied lockRes
|
let lock = whenSatisfied lockRes
|
||||||
ext <- evalExternal $ externalBindings ts lock
|
ext <- evalExternal $ externalBindings ts lock
|
||||||
warnMissing $ externalToMissing ext
|
|
||||||
-- IDK why this is necessary; nothing prior to this line will print if missing
|
-- IDK why this is necessary; nothing prior to this line will print if missing
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
launch
|
launch
|
||||||
|
@ -497,15 +496,10 @@ filterExternal = fmap go
|
||||||
where
|
where
|
||||||
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
|
go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
|
||||||
|
|
||||||
externalToMissing :: [KeyGroup (MaybeAction a)] -> [MaybeAction a]
|
|
||||||
externalToMissing = concatMap go
|
|
||||||
where
|
|
||||||
go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs
|
|
||||||
|
|
||||||
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
|
flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ()))
|
||||||
flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
|
flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
|
||||||
(Right x) -> Just $ k{ kbMaybeAction = x }
|
(Just x) -> Just $ k{ kbMaybeAction = x }
|
||||||
(Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
|
Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
|
||||||
|
|
||||||
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
|
externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX]
|
||||||
externalBindings ts lock =
|
externalBindings ts lock =
|
||||||
|
|
|
@ -28,7 +28,6 @@ module XMonad.Internal.Dependency
|
||||||
, featureExeArgs
|
, featureExeArgs
|
||||||
, featureExe
|
, featureExe
|
||||||
, featureEndpoint
|
, featureEndpoint
|
||||||
, warnMissing
|
|
||||||
, whenSatisfied
|
, whenSatisfied
|
||||||
, ifSatisfied
|
, ifSatisfied
|
||||||
, executeFeature
|
, executeFeature
|
||||||
|
@ -41,7 +40,7 @@ module XMonad.Internal.Dependency
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
|
|
||||||
import Data.Bifunctor (bimap, first)
|
import Data.Bifunctor (bimap)
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
|
||||||
|
|
||||||
|
@ -139,11 +138,11 @@ featureEndpoint busname path iface mem client = Feature
|
||||||
-- either the action of the feature or 0 or more error messages that signify
|
-- either the action of the feature or 0 or more error messages that signify
|
||||||
-- what dependencies are missing and why.
|
-- what dependencies are missing and why.
|
||||||
|
|
||||||
type MaybeAction a = Either [String] a
|
type MaybeAction a = Maybe a
|
||||||
|
|
||||||
type MaybeX = MaybeAction (X ())
|
type MaybeX = MaybeAction (X ())
|
||||||
|
|
||||||
evalTree :: DepTree a -> IO (MaybeAction a)
|
evalTree :: DepTree a -> IO (Either [String] a)
|
||||||
|
|
||||||
evalTree (GenTree action ds) = do
|
evalTree (GenTree action ds) = do
|
||||||
es <- catMaybes <$> mapM evalDependency ds
|
es <- catMaybes <$> mapM evalDependency ds
|
||||||
|
@ -172,7 +171,7 @@ 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)
|
evalFeature :: Feature a -> IO (MaybeAction a)
|
||||||
evalFeature (ConstFeature x) = return $ Right x
|
evalFeature (ConstFeature x) = return $ Just x
|
||||||
evalFeature Feature
|
evalFeature Feature
|
||||||
{ ftrAction = a
|
{ ftrAction = a
|
||||||
, ftrName = n
|
, ftrName = n
|
||||||
|
@ -180,16 +179,17 @@ evalFeature Feature
|
||||||
} = do
|
} = do
|
||||||
procName <- getProgName
|
procName <- getProgName
|
||||||
res <- evalTree a
|
res <- evalTree a
|
||||||
return $ first (fmtWarnings procName) res
|
either (\es -> printWarnings procName es >> return Nothing) (return . Just) res
|
||||||
where
|
where
|
||||||
fmtWarnings procName es = case w of
|
printWarnings procName es = case w of
|
||||||
Silent -> []
|
Silent -> return ()
|
||||||
Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es
|
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 :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a
|
||||||
applyFeature iof def ftr = do
|
applyFeature iof def ftr = do
|
||||||
a <- io $ evalFeature ftr
|
a <- io $ evalFeature ftr
|
||||||
either (\es -> io $ warnMissing' es >> return def) (iof . io) a
|
maybe (return def) (iof . io) a
|
||||||
|
|
||||||
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
|
applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m ()
|
||||||
applyFeature_ iof = applyFeature iof ()
|
applyFeature_ iof = applyFeature iof ()
|
||||||
|
@ -204,7 +204,7 @@ whenSatisfied :: Monad m => MaybeAction (m ()) -> m ()
|
||||||
whenSatisfied = flip ifSatisfied skip
|
whenSatisfied = flip ifSatisfied skip
|
||||||
|
|
||||||
ifSatisfied :: MaybeAction a -> a -> a
|
ifSatisfied :: MaybeAction a -> a -> a
|
||||||
ifSatisfied (Right x) _ = x
|
ifSatisfied (Just x) _ = x
|
||||||
ifSatisfied _ alt = alt
|
ifSatisfied _ alt = alt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -353,11 +353,11 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Logging functions
|
-- | Logging functions
|
||||||
|
|
||||||
warnMissing :: [MaybeAction a] -> IO ()
|
-- warnMissing :: [MaybeAction a] -> IO ()
|
||||||
warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
|
-- warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ]
|
||||||
|
|
||||||
warnMissing' :: [String] -> IO ()
|
-- warnMissing' :: [String] -> IO ()
|
||||||
warnMissing' = mapM_ putStrLn
|
-- warnMissing' = mapM_ putStrLn
|
||||||
|
|
||||||
fmtMsg :: String -> String -> String -> String
|
fmtMsg :: String -> String -> String -> String
|
||||||
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
|
fmtMsg procName level msg = unwords [bracket procName, bracket level, msg]
|
||||||
|
|
Loading…
Reference in New Issue