ADD switch functions to disable Sometimes features

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
   ]

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

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 "<toplevel>" 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 (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
 -- 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
+(.:+) :: Object -> String -> Parser Bool
-  parseJSON = withObject "parameters" $ \o -> XParams
+(.:+) o n = o .:? fromString n .!= False
-    <$> o .: fromString "loglevel"
 
-instance FromJSON LogLevel
+infix .:+
 
 --------------------------------------------------------------------------------
 -- | Testing pipeline
 
 evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
-evalSometimesMsg (Sometimes n xs) = do
+evalSometimesMsg (Sometimes n u xs) = do
-  PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
+  r <- asks (u . xpFeatures)
-  let fs' = failedMsgs n fs
+  if not r then return $ Left [FMsg n Nothing (Msg Debug "disabled")] else do
-  return $ case s of
+    PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs
-    (Just p) -> Right $ second (++ fs') $ passActMsg n p
+    let fs' = failedMsgs n fs
-    _        -> Left 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_ :: (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 }]
 
 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)])
+  (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?
-  (IOAlways (Always n _) _)       -> ("always", [("name", JSON_Q $ Q n)])
+  (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