ADD switch functions to disable Sometimes features

This commit is contained in:
Nathan Dwarshuis 2022-07-08 18:57:12 -04:00
parent 4eb88d5169
commit 60a386ea73
3 changed files with 84 additions and 32 deletions

View File

@ -244,7 +244,7 @@ iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature -> (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 icon "icon indicator" Error
, Subfeature text "text indicator" Error , Subfeature text "text indicator" Error
] ]

View File

@ -136,7 +136,7 @@ runOptimusPrompt' fb = do
#!&& "killall xmonad" #!&& "killall xmonad"
runOptimusPrompt :: SometimesX runOptimusPrompt :: SometimesX
runOptimusPrompt = Sometimes "graphics switcher" [s] runOptimusPrompt = Sometimes "graphics switcher" xpfOptimus [s]
where where
s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error } s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
r = IORoot runOptimusPrompt' t r = IORoot runOptimusPrompt' t
@ -172,7 +172,7 @@ instance XPrompt PowerPrompt where
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
runPowerPrompt :: SometimesX runPowerPrompt :: SometimesX
runPowerPrompt = Sometimes "power prompt" [sf] runPowerPrompt = Sometimes "power prompt" (const True) [sf]
where where
sf = Subfeature withLock "prompt with lock" Error sf = Subfeature withLock "prompt with lock" Error
withLock = IORoot (uncurry powerPrompt) tree withLock = IORoot (uncurry powerPrompt) tree

View File

@ -27,6 +27,10 @@ module XMonad.Internal.Dependency
, Msg(..) , Msg(..)
, LogLevel(..) , LogLevel(..)
-- configuration
, XParams(..)
, XPFeatures(..)
-- dependency tree types -- dependency tree types
, Root(..) , Root(..)
, Tree(..) , Tree(..)
@ -183,10 +187,11 @@ printMsg :: FMsg -> FIO ()
printMsg (FMsg fn n (Msg ll m)) = do printMsg (FMsg fn n (Msg ll m)) = do
xl <- asks xpLogLevel xl <- asks xpLogLevel
p <- io getProgName p <- io getProgName
io $ when (ll >= xl) $ putStrLn $ unwords [ bracket p io $ when (ll <= xl) $ putStrLn $ unwords [ bracket p
, bracket $ show ll , bracket $ show ll
, bracket fn , bracket fn
, bracket n, m , bracket $ fromMaybe "<toplevel>" n
, m
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -211,7 +216,7 @@ dumpAlways (Always n x) = go [] x
-- | Dump the status of a Sometimes to stdout -- | Dump the status of a Sometimes to stdout
dumpSometimes :: Sometimes a -> FIO JSONUnquotable dumpSometimes :: Sometimes a -> FIO JSONUnquotable
dumpSometimes (Sometimes n a) = go [] a dumpSometimes (Sometimes n _ a) = go [] a
where where
go failed [] = return $ jsonSometimes (Q n) Nothing failed [] go failed [] = return $ jsonSometimes (Q n) Nothing failed []
go failed (x:xs) = do go failed (x:xs) = do
@ -258,7 +263,7 @@ data FallbackStack p = FallbackBottom (Always p)
-- | Feature that might not be present -- | Feature that might not be present
-- This is like an Always except it doesn't fall back on a guaranteed monadic -- This is like an Always except it doesn't fall back on a guaranteed monadic
-- action -- 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) -- | Feature that might not be present (inner data)
type Sometimes_ a = [SubfeatureRoot a] type Sometimes_ a = [SubfeatureRoot a]
@ -343,7 +348,7 @@ instance Eq IODependency_ where
instance Hashable IODependency_ where instance Hashable IODependency_ where
hashWithSalt s (IOSystem_ y) = hashWithSalt s y hashWithSalt s (IOSystem_ y) = hashWithSalt s y
hashWithSalt s (IOTest_ n _) = hashWithSalt s n hashWithSalt s (IOTest_ n _) = hashWithSalt s n
hashWithSalt s (IOSometimes_ (Sometimes n _)) = hashWithSalt s n hashWithSalt s (IOSometimes_ (Sometimes n _ _)) = hashWithSalt s n
-- | A system component to an IODependency -- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious -- This name is dumb, but most constructors should be obvious
@ -382,7 +387,7 @@ instance Hashable DBusMember where
data Msg = Msg LogLevel String data Msg = Msg LogLevel String
-- | A message annotated with subfeature and feature name -- | A message annotated with subfeature and feature name
data FMsg = FMsg String String Msg data FMsg = FMsg String (Maybe String) Msg
-- | Tested Always feature -- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) 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 data XParams = XParams
{ xpLogLevel :: LogLevel { 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
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 data Cache = Cache
{ --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p) { --cIO :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
@ -495,17 +545,18 @@ getParamFile = do
where where
fallback = (</> ".config") <$> getHomeDirectory fallback = (</> ".config") <$> getHomeDirectory
instance FromJSON XParams where (.:+) :: Object -> String -> Parser Bool
parseJSON = withObject "parameters" $ \o -> XParams (.:+) o n = o .:? fromString n .!= False
<$> o .: fromString "loglevel"
instance FromJSON LogLevel infix .:+
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Testing pipeline -- | Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n xs) = do 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 PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
let fs' = failedMsgs n fs let fs' = failedMsgs n fs
return $ case s of return $ case s of
@ -520,7 +571,7 @@ evalAlwaysMsg (Always n x) = do
(Fallback act fs) -> (act, failedMsgs n fs) (Fallback act fs) -> (act, failedMsgs n fs)
passActMsg :: String -> SubfeaturePass a -> (a, [FMsg]) 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 :: String -> [SubfeatureFail] -> [FMsg]
failedMsgs n = concatMap (failedMsg n) failedMsgs n = concatMap (failedMsg n)
@ -530,7 +581,7 @@ failedMsg fn Subfeature { sfData = d, sfName = n } = case d of
(PostFail es) -> f es (PostFail es) -> f es
(PostMissing e) -> f [e] (PostMissing e) -> f [e]
where where
f = fmap (FMsg fn n) f = fmap (FMsg fn (Just n))
testAlways :: Always_ a -> FIO (PostAlways a) testAlways :: Always_ a -> FIO (PostAlways a)
testAlways = go [] testAlways = go []
@ -857,7 +908,7 @@ testDBusDependency'_ _ (DBusIO i) = testIODependency_ i
-- | IO Lifting functions -- | IO Lifting functions
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) 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 :: MonadIO m => Always (IO a) -> Always (m a)
ioAlways (Always n x) = Always n $ ioAlways' x ioAlways (Always n x) = Always n $ ioAlways' x
@ -882,8 +933,8 @@ ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature constructors -- | Feature constructors
sometimes1_ :: LogLevel -> String -> String -> Root a -> Sometimes a sometimes1_ :: (XPFeatures -> Bool) -> LogLevel -> String -> String -> Root a -> Sometimes a
sometimes1_ l fn n t = Sometimes fn sometimes1_ x l fn n t = Sometimes fn x
[Subfeature{ sfData = t, sfName = n, sfLevel = l }] [Subfeature{ sfData = t, sfName = n, sfLevel = l }]
always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a 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) $ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ $ FallbackAlone x)
sometimes1 :: String -> String -> Root a -> Sometimes a sometimes1 :: String -> String -> Root a -> Sometimes a
sometimes1 = sometimes1_ Error sometimes1 = sometimes1_ (const True) Error
always1 :: String -> String -> Root a -> a -> Always a always1 :: String -> String -> Root a -> a -> Always a
always1 = always1_ Error always1 = always1_ Error
@ -1081,7 +1132,8 @@ dataIODependency :: IODependency p -> DependencyData
dataIODependency d = first Q $ case d of dataIODependency d = first Q $ case d of
(IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)])
(IOConst _) -> ("const", []) (IOConst _) -> ("const", [])
(IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)]) -- 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)]) (IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)])
dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ :: IODependency_ -> DependencyData