ADD stack to feed the always fallback action
This commit is contained in:
parent
0a0a734817
commit
43d5c446bb
|
@ -283,7 +283,7 @@ rightPlugins sysClient sesClient = mapM evalFeature
|
||||||
, always' "date indicator" dateCmd
|
, always' "date indicator" dateCmd
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
always' n = Right . Always n . Always_
|
always' n = Right . Always n . Always_ . FallbackAlone
|
||||||
|
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = sometimes1 "wireless status indicator" "sysfs path"
|
getWireless = sometimes1 "wireless status indicator" "sysfs path"
|
||||||
|
|
|
@ -629,7 +629,7 @@ externalBindings ts db =
|
||||||
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
||||||
ib = Left . brightessControls intelBacklightControls
|
ib = Left . brightessControls intelBacklightControls
|
||||||
ck = Left . brightessControls clevoKeyboardControls
|
ck = Left . brightessControls clevoKeyboardControls
|
||||||
ftrAlways n = Right . Always n . Always_
|
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
||||||
quitf = ftrAlways "quit function" runQuitPrompt
|
quitf = ftrAlways "quit function" runQuitPrompt
|
||||||
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
||||||
recompilef = ftrAlways "recompile function" runRecompile
|
recompilef = ftrAlways "recompile function" runRecompile
|
||||||
|
|
|
@ -127,7 +127,8 @@ runAutorandrMenu = sometimesExeArgs "autorandr menu" "rofi autorandr"
|
||||||
-- | Shortcut menu
|
-- | Shortcut menu
|
||||||
|
|
||||||
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu (Always_ fallback)
|
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
|
||||||
|
$ FallbackAlone fallback
|
||||||
where
|
where
|
||||||
-- TODO this should technically depend on dunst
|
-- TODO this should technically depend on dunst
|
||||||
fallback = const $ spawnNotify
|
fallback = const $ spawnNotify
|
||||||
|
|
|
@ -12,6 +12,8 @@ module XMonad.Internal.Dependency
|
||||||
( Feature
|
( Feature
|
||||||
, Always(..)
|
, Always(..)
|
||||||
, Always_(..)
|
, Always_(..)
|
||||||
|
, FallbackRoot(..)
|
||||||
|
, FallbackStack(..)
|
||||||
, Sometimes(..)
|
, Sometimes(..)
|
||||||
, Sometimes_
|
, Sometimes_
|
||||||
, AlwaysX
|
, AlwaysX
|
||||||
|
@ -185,7 +187,16 @@ type Feature a = Either (Sometimes a) (Always a)
|
||||||
data Always a = Always String (Always_ a)
|
data Always a = Always String (Always_ a)
|
||||||
|
|
||||||
-- | Feature that is guaranteed to work (inner data)
|
-- | 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
|
-- | 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
|
||||||
|
@ -223,7 +234,6 @@ data Root a = forall p. IORoot (p -> a) (Tree IODependency IODependency_ p)
|
||||||
-- | The dependency tree with rules to merge results
|
-- | The dependency tree with rules to merge results
|
||||||
data Tree d d_ p =
|
data Tree d d_ p =
|
||||||
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
|
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_)
|
| And1 (Tree d d_ p) (Tree_ d_)
|
||||||
| And2 (Tree_ d_) (Tree d d_ p)
|
| And2 (Tree_ d_) (Tree d d_ p)
|
||||||
| Or (Tree d d_ p) (Tree d d_ p)
|
| Or (Tree d d_ p) (Tree d d_ p)
|
||||||
|
@ -319,7 +329,18 @@ testAlways = go []
|
||||||
case r of
|
case r of
|
||||||
(Left l) -> go (l:failed) next
|
(Left l) -> go (l:failed) next
|
||||||
(Right pass) -> return $ Primary pass 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 :: Sometimes_ a -> IO (PostSometimes a)
|
||||||
testSometimes = go (PostSometimes Nothing [])
|
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 (Always n x) = Always n $ ioAlways' x
|
||||||
|
|
||||||
ioAlways' :: MonadIO m => Always_ (IO a) -> Always_ (m a)
|
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
|
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 :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||||
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf }
|
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_ :: LogLevel -> String -> String -> Root a -> a -> Always a
|
||||||
always1_ l fn n t x = Always fn
|
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 :: String -> String -> Root a -> Sometimes a
|
||||||
sometimes1 = sometimes1_ Error
|
sometimes1 = sometimes1_ Error
|
||||||
|
|
Loading…
Reference in New Issue