ENH print warnings/errors immediately for dependencies

This commit is contained in:
Nathan Dwarshuis 2021-11-22 23:26:59 -05:00
parent 010b612b93
commit b4380695d0
3 changed files with 20 additions and 31 deletions

View File

@ -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

View File

@ -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 =

View File

@ -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]