ADD switch functions to disable Sometimes features
This commit is contained in:
parent
4eb88d5169
commit
60a386ea73
|
@ -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
|
||||||
]
|
]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue