Compare commits
2 Commits
27b32fb03e
...
9ec24b63a0
Author | SHA1 | Date |
---|---|---|
Nathan Dwarshuis | 9ec24b63a0 | |
Nathan Dwarshuis | b64742b925 |
|
@ -123,7 +123,7 @@ run = do
|
|||
dws <- startDynWorkspaces fs
|
||||
runIO <- askRunInIO
|
||||
let cleanup = runCleanup runIO toClean db
|
||||
kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
|
||||
kbs <- filterExternal <$> evalExternal (fsKeys fs runIO cleanup db)
|
||||
sk <- evalAlways $ fsShowKeys fs
|
||||
ha <- evalAlways $ fsACPIHandler fs
|
||||
tt <- evalAlways $ fsTabbedTheme fs
|
||||
|
@ -171,7 +171,7 @@ getCreateDirectories = do
|
|||
_ -> return ()
|
||||
|
||||
data FeatureSet = FeatureSet
|
||||
{ fsKeys :: X () -> DBusState -> [KeyGroup FeatureX]
|
||||
{ fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
||||
, fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
||||
, fsPowerMon :: SometimesIO
|
||||
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
||||
|
@ -262,7 +262,7 @@ printDeps = withDBus_ $ \db -> do
|
|||
let mockCleanup = runCleanup runIO mockClean db
|
||||
let bfs =
|
||||
concatMap (fmap kbMaybeAction . kgBindings) $
|
||||
externalBindings mockCleanup db
|
||||
externalBindings runIO mockCleanup db
|
||||
let dbus =
|
||||
fmap (\f -> f $ dbSesClient db) dbusExporters
|
||||
:: [Sometimes (XIO (), XIO ())]
|
||||
|
@ -794,8 +794,8 @@ filterExternal = fmap go
|
|||
]
|
||||
}
|
||||
|
||||
externalBindings :: X () -> DBusState -> [KeyGroup FeatureX]
|
||||
externalBindings cleanup db =
|
||||
externalBindings :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
|
||||
externalBindings runIO cleanup db =
|
||||
[ KeyGroup
|
||||
"Launchers"
|
||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||
|
@ -860,7 +860,7 @@ externalBindings cleanup db =
|
|||
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
|
||||
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
|
||||
, KeyBinding "M-<F10>" "toggle bluetooth" $ Left $ runToggleBluetooth sys
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ callToggle ses
|
||||
, KeyBinding "M-<F11>" "toggle screensaver" $ Left $ (liftIO . runIO) <$> callToggle ses
|
||||
, KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
|
||||
]
|
||||
]
|
||||
|
|
|
@ -221,12 +221,13 @@ type Feature a = Either (Sometimes a) (Always a)
|
|||
-- | Feature that is guaranteed to work
|
||||
-- This is composed of sub-features that are tested in order, and if all fail
|
||||
-- the fallback is a monadic action (eg a plain haskell function)
|
||||
data Always a = Always T.Text (Always_ a)
|
||||
data Always a = Always T.Text (Always_ a) deriving (Functor)
|
||||
|
||||
-- | Feature that is guaranteed to work (inner data)
|
||||
data Always_ a
|
||||
= Option (SubfeatureRoot a) (Always_ a)
|
||||
| Always_ (FallbackRoot a)
|
||||
deriving (Functor)
|
||||
|
||||
-- | Root of a fallback action for an always
|
||||
-- This may either be a lone action or a function that depends on the results
|
||||
|
@ -235,15 +236,23 @@ data FallbackRoot a
|
|||
= FallbackAlone a
|
||||
| forall p. FallbackTree (p -> a) (FallbackStack p)
|
||||
|
||||
instance Functor FallbackRoot where
|
||||
fmap f (FallbackAlone a) = FallbackAlone (f a)
|
||||
fmap f (FallbackTree g s) = FallbackTree (f . g) s
|
||||
|
||||
-- | 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)
|
||||
|
||||
instance Functor FallbackStack where
|
||||
fmap f (FallbackBottom a) = FallbackBottom $ fmap f a
|
||||
fmap f (FallbackStack g a s) = FallbackStack (\x -> f . g x) a s
|
||||
|
||||
-- | 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 T.Text XPQuery (Sometimes_ a)
|
||||
data Sometimes a = Sometimes T.Text XPQuery (Sometimes_ a) deriving (Functor)
|
||||
|
||||
-- | Feature that might not be present (inner data)
|
||||
type Sometimes_ a = [SubfeatureRoot a]
|
||||
|
@ -256,6 +265,7 @@ data Subfeature f = Subfeature
|
|||
{ sfData :: f
|
||||
, sfName :: T.Text
|
||||
}
|
||||
deriving (Functor)
|
||||
|
||||
type SubfeatureRoot a = Subfeature (Root a)
|
||||
|
||||
|
@ -268,6 +278,12 @@ data Root a
|
|||
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
|
||||
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
|
||||
|
||||
instance Functor Root where
|
||||
fmap f (IORoot a t) = IORoot (f . a) t
|
||||
fmap f (IORoot_ a t) = IORoot_ (f a) t
|
||||
fmap f (DBusRoot a t cl) = DBusRoot (\p c -> f $ a p c) t cl
|
||||
fmap f (DBusRoot_ a t cl) = DBusRoot_ (f . a) t cl
|
||||
|
||||
-- | The dependency tree with rule to merge results when needed
|
||||
data Tree d d_ p
|
||||
= forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
|
||||
|
@ -927,12 +943,6 @@ testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
|
|||
-- ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
|
||||
-- ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
|
||||
|
||||
-- ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
|
||||
-- ioRoot (IORoot a t) = IORoot (io . a) t
|
||||
-- ioRoot (IORoot_ a t) = IORoot_ (io a) t
|
||||
-- ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
|
||||
-- ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Feature constructors
|
||||
|
||||
|
|
|
@ -124,7 +124,7 @@ exportScreensaver ses =
|
|||
bus = Bus [] xmonadBusName
|
||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||
|
||||
callToggle :: Maybe SesClient -> SometimesX
|
||||
callToggle :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
|
||||
callToggle =
|
||||
sometimesEndpoint
|
||||
"screensaver toggle"
|
||||
|
|
Loading…
Reference in New Issue