diff --git a/bin/xmobar.hs b/bin/xmobar.hs index f05f7fd..34b6313 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -283,7 +283,7 @@ rightPlugins sysClient sesClient = mapM evalFeature , always' "date indicator" dateCmd ] where - always' n = Right . Always n . Always_ + always' n = Right . Always n . Always_ . FallbackAlone getWireless :: BarFeature getWireless = sometimes1 "wireless status indicator" "sysfs path" diff --git a/bin/xmonad.hs b/bin/xmonad.hs index ab3f367..8a3ecda 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -629,7 +629,7 @@ externalBindings ts db = brightessControls ctl getter = (ioSometimes . getter . ctl) cl ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls - ftrAlways n = Right . Always n . Always_ + ftrAlways n = Right . Always n . Always_ . FallbackAlone quitf = ftrAlways "quit function" runQuitPrompt restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart) recompilef = ftrAlways "recompile function" runRecompile diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index d0ef3f7..cbaa902 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -127,7 +127,8 @@ runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr" -- | Shortcut menu runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) -runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback) +runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_ + $ FallbackAlone fallback where -- TODO this should technically depend on dunst fallback = const $ spawnNotify diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 1999caf..6fa536b 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -12,6 +12,8 @@ module XMonad.Internal.Dependency ( Feature , Always(..) , Always_(..) + , FallbackRoot(..) + , FallbackStack(..) , Sometimes(..) , Sometimes_ , AlwaysX @@ -185,7 +187,16 @@ type Feature a = Either (Sometimes a) (Always a) data Always a = Always String (Always_ a) -- | Feature that is guaranteed to work (inner data) -data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ a +data Always_ a = Option (SubfeatureRoot a) (Always_ a) | Always_ (FallbackRoot a) + +-- | Root of a fallback action for an always +-- This may either be a lone action or a function that depends on the results +-- from other Always features. +data FallbackRoot a = FallbackAlone a | forall p. FallbackTree (p -> a) (FallbackStack p) + +-- | Always features that are used as a payload for a fallback action +data FallbackStack p = FallbackBottom (Always p) + | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) -- | Feature that might not be present -- This is like an Always except it doesn't fall back on a guaranteed monadic @@ -223,7 +234,6 @@ data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p) -- | The dependency tree with rules to merge results data Tree d d_ p = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) - -- And12 (p -> p -> p) (Tree d d_ p) (Tree d d_ p) | And1 (Tree d d_ p) (Tree_ d_) | And2 (Tree_ d_) (Tree d d_ p) | Or (Tree d d_ p) (Tree d d_ p) @@ -319,7 +329,18 @@ testAlways = go [] case r of (Left l) -> go (l:failed) next (Right pass) -> return $ Primary pass failed next - go failed (Always_ a) = return $ Fallback a failed + go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar + +evalFallbackRoot :: FallbackRoot a -> IO a +evalFallbackRoot (FallbackAlone a) = return a +evalFallbackRoot (FallbackTree a s) = a <$> evalFallbackStack s + +evalFallbackStack :: FallbackStack p -> IO p +evalFallbackStack (FallbackBottom a) = evalAlways a +evalFallbackStack (FallbackStack f a as) = do + ps <- evalFallbackStack as + p <- evalAlways a + return $ f p ps testSometimes :: Sometimes_ a -> IO (PostSometimes a) testSometimes = go (PostSometimes Nothing []) @@ -506,9 +527,13 @@ ioAlways :: MonadIO m => Always (IO a) -> Always (m a) ioAlways (Always n x) = Always n $ ioAlways' x ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a) -ioAlways' (Always_ x) = Always_ $ io x +ioAlways' (Always_ ar) = Always_ $ ioFallbackRoot ar ioAlways' (Option sf a) = Option (ioSubfeature sf) $ ioAlways' a +ioFallbackRoot :: MonadIO m => FallbackRoot (IO a) -> FallbackRoot (m a) +ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a +ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s + ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) ioSubfeature sf = sf { sfData = ioRoot $ sfData sf } @@ -527,7 +552,7 @@ sometimes1_ l fn n t = Sometimes fn always1_ :: LogLevel -> String -> String -> Root a -> a -> Always a always1_ l fn n t x = Always fn - $ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ x) + $ Option (Subfeature{ sfData = t, sfName = n, sfLevel = l }) (Always_ $ FallbackAlone x) sometimes1 :: String -> String -> Root a -> Sometimes a sometimes1 = sometimes1_ Error