From 60a386ea7330a754c4e97c4fe6827cb3abc010b7 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 8 Jul 2022 18:57:12 -0400 Subject: [PATCH] ADD switch functions to disable Sometimes features --- bin/xmobar.hs | 2 +- lib/XMonad/Internal/Command/Power.hs | 4 +- lib/XMonad/Internal/Dependency.hs | 110 ++++++++++++++++++++------- 3 files changed, 84 insertions(+), 32 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 26fa57f..ed45be2 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -244,7 +244,7 @@ iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature -iconSometimes' c d n r t = Sometimes n +iconSometimes' c d n r t = Sometimes n (const True) [ Subfeature icon "icon indicator" Error , Subfeature text "text indicator" Error ] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index e63e337..643940c 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -136,7 +136,7 @@ runOptimusPrompt' fb = do #!&& "killall xmonad" runOptimusPrompt :: SometimesX -runOptimusPrompt = Sometimes "graphics switcher" [s] +runOptimusPrompt = Sometimes "graphics switcher" xpfOptimus [s] where s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error } r = IORoot runOptimusPrompt' t @@ -172,7 +172,7 @@ instance XPrompt PowerPrompt where showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" runPowerPrompt :: SometimesX -runPowerPrompt = Sometimes "power prompt" [sf] +runPowerPrompt = Sometimes "power prompt" (const True) [sf] where sf = Subfeature withLock "prompt with lock" Error withLock = IORoot (uncurry powerPrompt) tree diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 094806d..df8a37d 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -27,6 +27,10 @@ module XMonad.Internal.Dependency , Msg(..) , LogLevel(..) + -- configuration + , XParams(..) + , XPFeatures(..) + -- dependency tree types , Root(..) , Tree(..) @@ -183,10 +187,11 @@ printMsg :: FMsg -> FIO () printMsg (FMsg fn n (Msg ll m)) = do xl <- asks xpLogLevel p <- io getProgName - io $ when (ll >= xl) $ putStrLn $ unwords [ bracket p + io $ when (ll <= xl) $ putStrLn $ unwords [ bracket p , bracket $ show ll , bracket fn - , bracket n, m + , bracket $ fromMaybe "" n + , m ] -------------------------------------------------------------------------------- @@ -211,7 +216,7 @@ dumpAlways (Always n x) = go [] x -- | Dump the status of a Sometimes to stdout dumpSometimes :: Sometimes a -> FIO JSONUnquotable -dumpSometimes (Sometimes n a) = go [] a +dumpSometimes (Sometimes n _ a) = go [] a where go failed [] = return $ jsonSometimes (Q n) Nothing failed [] go failed (x:xs) = do @@ -258,7 +263,7 @@ data FallbackStack p = FallbackBottom (Always p) -- | Feature that might not be present -- This is like an Always except it doesn't fall back on a guaranteed monadic -- action -data Sometimes a = Sometimes String (Sometimes_ a) +data Sometimes a = Sometimes String (XPFeatures -> Bool) (Sometimes_ a) -- | Feature that might not be present (inner data) type Sometimes_ a = [SubfeatureRoot a] @@ -341,9 +346,9 @@ instance Eq IODependency_ where (==) _ _ = False instance Hashable IODependency_ where - hashWithSalt s (IOSystem_ y) = hashWithSalt s y - hashWithSalt s (IOTest_ n _) = hashWithSalt s n - hashWithSalt s (IOSometimes_ (Sometimes n _)) = hashWithSalt s n + hashWithSalt s (IOSystem_ y) = hashWithSalt s y + hashWithSalt s (IOTest_ n _) = hashWithSalt s n + hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n -- | A system component to an IODependency -- This name is dumb, but most constructors should be obvious @@ -382,7 +387,7 @@ instance Hashable DBusMember where data Msg = Msg LogLevel String -- | A message annotated with subfeature and feature name -data FMsg = FMsg String String Msg +data FMsg = FMsg String (Maybe String) Msg -- | Tested Always feature data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) @@ -462,10 +467,55 @@ type FIO a = ReaderT XParams (StateT Cache IO) a data XParams = XParams { xpLogLevel :: LogLevel + , xpFeatures :: XPFeatures } +instance FromJSON XParams where + parseJSON = withObject "parameters" $ \o -> XParams + <$> o .: fromString "loglevel" + <*> o .: fromString "features" + +instance FromJSON LogLevel + +data XPFeatures = XPFeatures + { xpfOptimus :: Bool + , xpfVirtualBox :: Bool + , xpfXSANE :: Bool + , xpfWireless :: Bool + , xpfVPN :: Bool + , xpfBluetooth :: Bool + , xpfIntelBacklight :: Bool + , xpfClevoBacklight :: Bool + } + +instance FromJSON XPFeatures where + parseJSON = withObject "features" $ \o -> XPFeatures + <$> o .:+ "optimus" + <*> o .:+ "virtualbox" + <*> o .:+ "xsane" + <*> o .:+ "wireless" + <*> o .:+ "vpn" + <*> o .:+ "bluetooth" + <*> o .:+ "intel_backlight" + <*> o .:+ "clevo_backlight" + defParams :: XParams -defParams = XParams { xpLogLevel = Error } +defParams = XParams + { xpLogLevel = Error + , xpFeatures = defXPFeatures + } + +defXPFeatures :: XPFeatures +defXPFeatures = XPFeatures + { xpfOptimus = False + , xpfVirtualBox = False + , xpfXSANE = False + , xpfWireless = False + , xpfVPN = False + , xpfBluetooth = False + , xpfIntelBacklight = False + , xpfClevoBacklight = False + } data Cache = Cache { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p) @@ -495,22 +545,23 @@ getParamFile = do where fallback = ( ".config") <$> getHomeDirectory -instance FromJSON XParams where - parseJSON = withObject "parameters" $ \o -> XParams - <$> o .: fromString "loglevel" +(.:+) :: Object -> String -> Parser Bool +(.:+) o n = o .:? fromString n .!= False -instance FromJSON LogLevel +infix .:+ -------------------------------------------------------------------------------- -- | Testing pipeline evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) -evalSometimesMsg (Sometimes n xs) = do - PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs - let fs' = failedMsgs n fs - return $ case s of - (Just p) -> Right $ second (++ fs') $ passActMsg n p - _ -> Left fs' +evalSometimesMsg (Sometimes n u xs) = do + r <- asks (u . xpFeatures) + if not r then return $ Left [FMsg n Nothing (Msg Debug "disabled")] else do + PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs + let fs' = failedMsgs n fs + return $ case s of + (Just p) -> Right $ second (++ fs') $ passActMsg n p + _ -> Left fs' evalAlwaysMsg :: Always a -> FIO (a, [FMsg]) evalAlwaysMsg (Always n x) = do @@ -520,7 +571,7 @@ evalAlwaysMsg (Always n x) = do (Fallback act fs) -> (act, failedMsgs n fs) passActMsg :: String -> SubfeaturePass a -> (a, [FMsg]) -passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn n) ws) +passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws) failedMsgs :: String -> [SubfeatureFail] -> [FMsg] failedMsgs n = concatMap (failedMsg n) @@ -530,7 +581,7 @@ failedMsg fn Subfeature { sfData = d, sfName = n } = case d of (PostFail es) -> f es (PostMissing e) -> f [e] where - f = fmap (FMsg fn n) + f = fmap (FMsg fn (Just n)) testAlways :: Always_ a -> FIO (PostAlways a) testAlways = go [] @@ -857,7 +908,7 @@ testDBusDependency'_ _ (DBusIO i) = testIODependency_ i -- | IO Lifting functions ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) -ioSometimes (Sometimes n xs) = Sometimes n $ fmap ioSubfeature xs +ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs ioAlways :: MonadIO m => Always (IO a) -> Always (m a) ioAlways (Always n x) = Always n $ ioAlways' x @@ -882,8 +933,8 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl -------------------------------------------------------------------------------- -- | Feature constructors -sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a -sometimes1_ l fn n t = Sometimes fn +sometimes1_ :: (XPFeatures -> Bool) -> LogLevel -> String -> String -> Root a -> Sometimes a +sometimes1_ x l fn n t = Sometimes fn x [Subfeature{ sfData = t, sfName = n, sfLevel = l }] always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a @@ -891,7 +942,7 @@ always1_ l fn n t x = Always fn $ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ $ FallbackAlone x) sometimes1 :: String -> String -> Root a -> Sometimes a -sometimes1 = sometimes1_ Error +sometimes1 = sometimes1_ (const True) Error always1 :: String -> String -> Root a -> a -> Always a always1 = always1_ Error @@ -1079,10 +1130,11 @@ dataTree_ f_ = go dataIODependency :: IODependency p -> DependencyData dataIODependency d = first Q $ case d of - (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) - (IOConst _) -> ("const", []) - (IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)]) - (IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)]) + (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) + (IOConst _) -> ("const", []) + -- TODO what if this isn't required? + (IOSometimes (Sometimes n _ _) _) -> ("sometimes", [("name", JSON_Q $ Q n)]) + (IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)]) dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of