REF use common feature structure
This commit is contained in:
parent
f82e1bd032
commit
05c0b6a116
169
bin/xmonad.hs
169
bin/xmonad.hs
|
@ -8,10 +8,6 @@ module Main (main) where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( forM_
|
|
||||||
, unless
|
|
||||||
, void
|
|
||||||
)
|
|
||||||
|
|
||||||
import Data.List
|
import Data.List
|
||||||
( intercalate
|
( intercalate
|
||||||
|
@ -85,70 +81,110 @@ parse _ = usage
|
||||||
|
|
||||||
run :: IO ()
|
run :: IO ()
|
||||||
run = do
|
run = do
|
||||||
db <- connectXDBus
|
conf <- evalConf =<< connectDBusX
|
||||||
(h, p) <- spawnPipe "xmobar"
|
|
||||||
ps <- catMaybes <$> mapM executeSometimes [ runNetAppDaemon
|
|
||||||
, runFlameshotDaemon
|
|
||||||
, runNotificationDaemon
|
|
||||||
, runBwDaemon
|
|
||||||
, runClipManager
|
|
||||||
, runAutolock
|
|
||||||
]
|
|
||||||
void $ executeSometimes $ runRemovableMon $ dbSystemClient db
|
|
||||||
dws <- allDWs
|
|
||||||
forkIO_ $ void $ executeSometimes runPowermon
|
|
||||||
forkIO_ $ runWorkspaceMon dws
|
|
||||||
let ts = ThreadState
|
|
||||||
{ tsChildPIDs = p:ps
|
|
||||||
, tsChildHandles = [h]
|
|
||||||
}
|
|
||||||
fb <- evalAlways T.defFont
|
|
||||||
ext <- evalExternal $ externalBindings ts db
|
|
||||||
sk <- evalAlways runShowKeys
|
|
||||||
ha <- evalAlways runHandleACPI
|
|
||||||
-- IDK why this is necessary; nothing prior to this line will print if missing
|
|
||||||
hFlush stdout
|
|
||||||
ds <- getDirectories
|
ds <- getDirectories
|
||||||
let conf = ewmh
|
-- IDK why this is necessary; nothing prior to this will print if missing
|
||||||
$ addKeymap dws sk (filterExternal ext)
|
hFlush stdout
|
||||||
$ docks
|
|
||||||
$ def { terminal = myTerm
|
|
||||||
, modMask = myModMask
|
|
||||||
, layoutHook = myLayouts fb
|
|
||||||
, manageHook = myManageHook dws
|
|
||||||
, handleEventHook = myEventHook ha
|
|
||||||
, startupHook = myStartupHook
|
|
||||||
, workspaces = myWorkspaces
|
|
||||||
, logHook = myLoghook h
|
|
||||||
, clickJustFocuses = False
|
|
||||||
, focusFollowsMouse = False
|
|
||||||
, normalBorderColor = T.bordersColor
|
|
||||||
, focusedBorderColor = T.selectedBordersColor
|
|
||||||
}
|
|
||||||
launch conf ds
|
launch conf ds
|
||||||
|
|
||||||
|
data FeatureSet = FeatureSet
|
||||||
|
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
|
, fsDBusExporters :: [Maybe Client -> SometimesIO]
|
||||||
|
, fsPowerMon :: SometimesIO
|
||||||
|
, fsRemovableMon :: Maybe Client -> SometimesIO
|
||||||
|
, fsDaemons :: [Sometimes (IO ProcessHandle)]
|
||||||
|
, fsACPIHandler :: Always (String -> X ())
|
||||||
|
, fsTabbedTheme :: Always Theme
|
||||||
|
, fsDynWorkspaces :: [Sometimes DynWorkspace]
|
||||||
|
, fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
|
}
|
||||||
|
|
||||||
|
features :: FeatureSet
|
||||||
|
features = FeatureSet
|
||||||
|
{ fsKeys = externalBindings
|
||||||
|
, fsDBusExporters = dbusExporters
|
||||||
|
, fsPowerMon = runPowermon
|
||||||
|
, fsRemovableMon = runRemovableMon
|
||||||
|
, fsACPIHandler = runHandleACPI
|
||||||
|
, fsDynWorkspaces = allDWs'
|
||||||
|
, fsTabbedTheme = T.tabbedFeature
|
||||||
|
, fsShowKeys = runShowKeys
|
||||||
|
, fsDaemons = [ runNetAppDaemon
|
||||||
|
, runFlameshotDaemon
|
||||||
|
-- TODO the problem with launching
|
||||||
|
-- dunst here is that the history
|
||||||
|
-- will get nuked on each restart
|
||||||
|
, runNotificationDaemon
|
||||||
|
, runBwDaemon
|
||||||
|
-- TODO does this have a lag when
|
||||||
|
-- spawned within the WM?
|
||||||
|
, runClipManager
|
||||||
|
, runAutolock
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
evalConf db = do
|
||||||
|
-- start DBus interfaces first since many features after this test these
|
||||||
|
-- interfaces as dependencies
|
||||||
|
startDBusInterfaces
|
||||||
|
(xmobarHandle, ts) <- startChildDaemons
|
||||||
|
startRemovableMon
|
||||||
|
startPowerMon
|
||||||
|
dws <- startDynWorkspaces
|
||||||
|
tt <- evalAlways $ fsTabbedTheme features
|
||||||
|
-- fb <- evalAlways $ fsFontBuilder features
|
||||||
|
kbs <- filterExternal <$> evalExternal (fsKeys features ts db)
|
||||||
|
sk <- evalAlways $ fsShowKeys features
|
||||||
|
ha <- evalAlways $ fsACPIHandler features
|
||||||
|
return $ ewmh
|
||||||
|
$ addKeymap dws sk kbs
|
||||||
|
$ docks
|
||||||
|
$ def { terminal = myTerm
|
||||||
|
, modMask = myModMask
|
||||||
|
, layoutHook = myLayouts tt
|
||||||
|
, manageHook = myManageHook dws
|
||||||
|
, handleEventHook = myEventHook ha
|
||||||
|
, startupHook = myStartupHook
|
||||||
|
, workspaces = myWorkspaces
|
||||||
|
, logHook = myLoghook xmobarHandle
|
||||||
|
, clickJustFocuses = False
|
||||||
|
, focusFollowsMouse = False
|
||||||
|
, normalBorderColor = T.bordersColor
|
||||||
|
, focusedBorderColor = T.selectedBordersColor
|
||||||
|
}
|
||||||
where
|
where
|
||||||
forkIO_ = void . forkIO
|
forkIO_ = void . forkIO
|
||||||
|
startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db)
|
||||||
|
$ fsDBusExporters features
|
||||||
|
startChildDaemons = do
|
||||||
|
(h, p) <- spawnPipe "xmobar"
|
||||||
|
ps <- catMaybes <$> mapM executeSometimes (fsDaemons features)
|
||||||
|
return (h, ThreadState (p:ps) [h])
|
||||||
|
startRemovableMon = void $ executeSometimes $ fsRemovableMon features
|
||||||
|
$ dbSysClient db
|
||||||
|
startPowerMon = forkIO_ $ void $ executeSometimes $ fsPowerMon features
|
||||||
|
startDynWorkspaces = do
|
||||||
|
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features)
|
||||||
|
forkIO_ $ runWorkspaceMon dws
|
||||||
|
return dws
|
||||||
|
|
||||||
printDeps :: IO ()
|
printDeps :: IO ()
|
||||||
printDeps = do
|
printDeps = do
|
||||||
ses <- getDBusClient False
|
db <- connectDBus
|
||||||
sys <- getDBusClient True
|
|
||||||
let db = DBusState ses sys
|
|
||||||
(i, f, d) <- allFeatures db
|
(i, f, d) <- allFeatures db
|
||||||
is <- mapM dumpSometimes i
|
is <- mapM dumpSometimes i
|
||||||
fs <- mapM dumpFeature f
|
fs <- mapM dumpFeature f
|
||||||
ds <- mapM dumpSometimes d
|
ds <- mapM dumpSometimes d
|
||||||
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds
|
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds
|
||||||
putStrLn u
|
putStrLn u
|
||||||
forM_ ses disconnect
|
disconnectDBus db
|
||||||
forM_ sys disconnect
|
|
||||||
|
|
||||||
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||||
allFeatures db = do
|
allFeatures db = do
|
||||||
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||||
$ externalBindings ts db
|
$ externalBindings ts db
|
||||||
let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters
|
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
||||||
let others = [runRemovableMon $ dbSystemClient db, runPowermon]
|
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
||||||
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
|
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
|
||||||
where
|
where
|
||||||
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||||
|
@ -159,26 +195,9 @@ usage = putStrLn $ intercalate "\n"
|
||||||
, "xmonad --deps: print dependencies"
|
, "xmonad --deps: print dependencies"
|
||||||
]
|
]
|
||||||
|
|
||||||
connectXDBus :: IO DBusState
|
|
||||||
connectXDBus = connectDBus_ startXMonadService
|
|
||||||
|
|
||||||
connectDBus_ :: IO (Maybe Client) -> IO DBusState
|
|
||||||
connectDBus_ getSes = do
|
|
||||||
ses <- getSes
|
|
||||||
sys <- getDBusClient True
|
|
||||||
return DBusState
|
|
||||||
{ dbSessionClient = ses
|
|
||||||
, dbSystemClient = sys
|
|
||||||
}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Concurrency configuration
|
-- | Concurrency configuration
|
||||||
|
|
||||||
data DBusState = DBusState
|
|
||||||
{ dbSessionClient :: Maybe Client
|
|
||||||
, dbSystemClient :: Maybe Client
|
|
||||||
}
|
|
||||||
|
|
||||||
data ThreadState = ThreadState
|
data ThreadState = ThreadState
|
||||||
{ tsChildPIDs :: [ProcessHandle]
|
{ tsChildPIDs :: [ProcessHandle]
|
||||||
, tsChildHandles :: [Handle]
|
, tsChildHandles :: [Handle]
|
||||||
|
@ -188,8 +207,7 @@ data ThreadState = ThreadState
|
||||||
runCleanup :: ThreadState -> DBusState -> X ()
|
runCleanup :: ThreadState -> DBusState -> X ()
|
||||||
runCleanup ts db = io $ do
|
runCleanup ts db = io $ do
|
||||||
mapM_ killHandle $ tsChildPIDs ts
|
mapM_ killHandle $ tsChildPIDs ts
|
||||||
forM_ (dbSessionClient db) stopXMonadService
|
disconnectDBusX db
|
||||||
forM_ (dbSystemClient db) disconnect
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Startuphook configuration
|
-- | Startuphook configuration
|
||||||
|
@ -300,21 +318,18 @@ allDWs' = [xsaneDynamicWorkspace
|
||||||
, f5vpnDynamicWorkspace
|
, f5vpnDynamicWorkspace
|
||||||
]
|
]
|
||||||
|
|
||||||
allDWs :: IO [DynWorkspace]
|
|
||||||
allDWs = catMaybes <$> mapM evalSometimes allDWs'
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Layout configuration
|
-- | Layout configuration
|
||||||
|
|
||||||
-- NOTE this will have all available layouts, even those that may be for
|
-- NOTE this will have all available layouts, even those that may be for
|
||||||
-- features that failed. Trying to dynamically take out a layout seems to
|
-- features that failed. Trying to dynamically take out a layout seems to
|
||||||
-- make a new type :/
|
-- make a new type :/
|
||||||
myLayouts fb = onWorkspace vmTag vmLayout
|
myLayouts tt = onWorkspace vmTag vmLayout
|
||||||
$ onWorkspace gimpTag gimpLayout
|
$ onWorkspace gimpTag gimpLayout
|
||||||
$ mkToggle (single HIDE)
|
$ mkToggle (single HIDE)
|
||||||
$ tall ||| fulltab ||| full
|
$ tall ||| fulltab ||| full
|
||||||
where
|
where
|
||||||
addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb
|
addTopBar = noFrillsDeco shrinkText tt
|
||||||
tall = renamed [Replace "Tall"]
|
tall = renamed [Replace "Tall"]
|
||||||
$ avoidStruts
|
$ avoidStruts
|
||||||
$ addTopBar
|
$ addTopBar
|
||||||
|
@ -323,7 +338,7 @@ myLayouts fb = onWorkspace vmTag vmLayout
|
||||||
fulltab = renamed [Replace "Tabbed"]
|
fulltab = renamed [Replace "Tabbed"]
|
||||||
$ avoidStruts
|
$ avoidStruts
|
||||||
$ noBorders
|
$ noBorders
|
||||||
$ tabbedAlways shrinkText $ T.tabbedTheme fb
|
$ tabbedAlways shrinkText tt
|
||||||
full = renamed [Replace "Full"]
|
full = renamed [Replace "Full"]
|
||||||
$ noBorders Full
|
$ noBorders Full
|
||||||
vmLayout = noBorders Full
|
vmLayout = noBorders Full
|
||||||
|
@ -656,7 +671,7 @@ externalBindings ts db =
|
||||||
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec
|
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec
|
||||||
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
||||||
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
|
||||||
, KeyBinding "M-<End>" "power menu" $ Right runPowerPrompt
|
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
|
||||||
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
|
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
|
||||||
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
|
||||||
-- M-<F1> reserved for showing the keymap
|
-- M-<F1> reserved for showing the keymap
|
||||||
|
@ -672,7 +687,7 @@ externalBindings ts db =
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
cl = dbSessionClient db
|
cl = dbSesClient 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
|
||||||
|
|
|
@ -96,8 +96,7 @@ quitPrompt :: T.FontBuilder -> X ()
|
||||||
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
||||||
|
|
||||||
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
|
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
|
||||||
sometimesPrompt n = sometimesIO n (n ++ " command")
|
sometimesPrompt n = sometimesIO n (n ++ " command") T.defFontTree
|
||||||
$ Only $ IOAlways T.defFont id
|
|
||||||
|
|
||||||
-- TODO doesn't this need to also lock the screen?
|
-- TODO doesn't this need to also lock the screen?
|
||||||
runSuspendPrompt :: SometimesX
|
runSuspendPrompt :: SometimesX
|
||||||
|
@ -141,7 +140,7 @@ runOptimusPrompt = Sometimes "graphics switcher" [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
|
||||||
t = And1 (Only $ IOAlways T.defFont id)
|
t = And1 T.defFontTree
|
||||||
$ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
|
$ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -170,16 +169,13 @@ data PowerPrompt = PowerPrompt
|
||||||
instance XPrompt PowerPrompt where
|
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 :: AlwaysX
|
runPowerPrompt :: SometimesX
|
||||||
runPowerPrompt = Always "power prompt" $ Option sf fallback
|
runPowerPrompt = Sometimes "power prompt" [sf]
|
||||||
where
|
where
|
||||||
sf = Subfeature withLock "lock-enabled prompt" Error
|
sf = Subfeature withLock "prompt with lock" Error
|
||||||
withLock = IORoot (uncurry powerPrompt) tree
|
withLock = IORoot (uncurry powerPrompt) tree
|
||||||
tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id)
|
tree = And12 (,) lockTree T.defFontTree
|
||||||
fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont
|
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
|
||||||
|
|
||||||
powerPromptNoLock :: T.FontBuilder -> X ()
|
|
||||||
powerPromptNoLock = powerPrompt skip
|
|
||||||
|
|
||||||
powerPrompt :: X () -> T.FontBuilder -> X ()
|
powerPrompt :: X () -> T.FontBuilder -> X ()
|
||||||
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||||
|
|
|
@ -27,7 +27,10 @@ import XMonad.Internal.Command.Power
|
||||||
import XMonad.Internal.Concurrent.ClientMessage
|
import XMonad.Internal.Concurrent.ClientMessage
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
import XMonad.Internal.Theme (FontBuilder, defFont)
|
import XMonad.Internal.Theme
|
||||||
|
( FontBuilder
|
||||||
|
, defFontTree
|
||||||
|
)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Data structure to hold the ACPI events I care about
|
-- | Data structure to hold the ACPI events I care about
|
||||||
|
@ -120,6 +123,6 @@ runHandleACPI :: Always (String -> X ())
|
||||||
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
||||||
where
|
where
|
||||||
sf = Subfeature withLock "acpid prompt" Error
|
sf = Subfeature withLock "acpid prompt" Error
|
||||||
withLock = IORoot (uncurry handleACPI)
|
withLock = IORoot (uncurry handleACPI) $ And12 (,) defFontTree $ Only
|
||||||
$ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id)
|
$ IOSometimes runScreenLock id
|
||||||
fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont
|
fallback = Always_ $ FallbackAlone $ const skip
|
||||||
|
|
|
@ -5,16 +5,19 @@
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Control
|
module XMonad.Internal.DBus.Control
|
||||||
( Client
|
( Client
|
||||||
, startXMonadService
|
, DBusState(..)
|
||||||
|
, connectDBus
|
||||||
|
, connectDBusX
|
||||||
|
, disconnectDBus
|
||||||
|
, disconnectDBusX
|
||||||
, getDBusClient
|
, getDBusClient
|
||||||
, withDBusClient
|
, withDBusClient
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
, stopXMonadService
|
|
||||||
, disconnect
|
, disconnect
|
||||||
, dbusExporters
|
, dbusExporters
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad (forM_, void)
|
import Control.Monad
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
@ -26,17 +29,42 @@ import XMonad.Internal.DBus.Common
|
||||||
import XMonad.Internal.DBus.Screensaver
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
|
|
||||||
startXMonadService :: IO (Maybe Client)
|
-- | Current connections to the DBus (session and system buses)
|
||||||
startXMonadService = do
|
data DBusState = DBusState
|
||||||
client <- getDBusClient False
|
{ dbSesClient :: Maybe Client
|
||||||
forM_ client requestXMonadName
|
, dbSysClient :: Maybe Client
|
||||||
mapM_ (\f -> executeSometimes $ f client) dbusExporters
|
}
|
||||||
return client
|
|
||||||
|
|
||||||
stopXMonadService :: Client -> IO ()
|
-- | Connect to the DBus
|
||||||
stopXMonadService client = do
|
connectDBus :: IO DBusState
|
||||||
void $ releaseName client xmonadBusName
|
connectDBus = do
|
||||||
disconnect client
|
ses <- getDBusClient False
|
||||||
|
sys <- getDBusClient True
|
||||||
|
return DBusState { dbSesClient = ses, dbSysClient = sys }
|
||||||
|
|
||||||
|
-- | Disconnect from the DBus
|
||||||
|
disconnectDBus :: DBusState -> IO ()
|
||||||
|
disconnectDBus db = forM_ (dbSysClient db) disconnect
|
||||||
|
|
||||||
|
-- | Connect to the DBus and request the XMonad name
|
||||||
|
connectDBusX :: IO DBusState
|
||||||
|
connectDBusX = do
|
||||||
|
db <- connectDBus
|
||||||
|
forM_ (dbSesClient db) requestXMonadName
|
||||||
|
return db
|
||||||
|
|
||||||
|
-- | Disconnect from DBus and release the XMonad name
|
||||||
|
disconnectDBusX :: DBusState -> IO ()
|
||||||
|
disconnectDBusX db = do
|
||||||
|
forM_ (dbSesClient db) releaseXMonadName
|
||||||
|
disconnectDBus db
|
||||||
|
|
||||||
|
-- | All exporter features to be assigned to the DBus
|
||||||
|
dbusExporters :: [Maybe Client -> SometimesIO]
|
||||||
|
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
|
|
||||||
|
releaseXMonadName :: Client -> IO ()
|
||||||
|
releaseXMonadName cl = void $ releaseName cl xmonadBusName
|
||||||
|
|
||||||
requestXMonadName :: Client -> IO ()
|
requestXMonadName :: Client -> IO ()
|
||||||
requestXMonadName client = do
|
requestXMonadName client = do
|
||||||
|
@ -51,5 +79,5 @@ requestXMonadName client = do
|
||||||
where
|
where
|
||||||
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||||
|
|
||||||
dbusExporters :: [Maybe Client -> SometimesIO]
|
-- executeExporters :: Maybe Client -> IO ()
|
||||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
-- executeExporters cl = mapM_ (\f -> executeSometimes $ f cl) dbusExporters
|
||||||
|
|
|
@ -74,7 +74,6 @@ module XMonad.Internal.Dependency
|
||||||
-- dependency construction
|
-- dependency construction
|
||||||
, sysExe
|
, sysExe
|
||||||
, localExe
|
, localExe
|
||||||
, fontFam
|
|
||||||
, sysdSystem
|
, sysdSystem
|
||||||
, sysdUser
|
, sysdUser
|
||||||
, listToAnds
|
, listToAnds
|
||||||
|
@ -83,6 +82,9 @@ module XMonad.Internal.Dependency
|
||||||
, pathRW
|
, pathRW
|
||||||
, pathW
|
, pathW
|
||||||
, sysTest
|
, sysTest
|
||||||
|
|
||||||
|
-- misc
|
||||||
|
, shellTest
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -255,9 +257,15 @@ type DBusTree p = Tree IODependency DBusDependency_ p
|
||||||
type IOTree_ = Tree_ IODependency_
|
type IOTree_ = Tree_ IODependency_
|
||||||
type DBusTree_ = Tree_ DBusDependency_
|
type DBusTree_ = Tree_ DBusDependency_
|
||||||
|
|
||||||
-- | A dependency that only requires IO to evaluate
|
-- | A dependency that only requires IO to evaluate (with payload)
|
||||||
data IODependency p = IORead String (IO (Result p))
|
data IODependency p =
|
||||||
|
-- an IO action that yields a payload
|
||||||
|
IORead String (IO (Result p))
|
||||||
|
-- always yields a payload
|
||||||
|
| IOConst p
|
||||||
|
-- an always that yields a payload
|
||||||
| forall a. IOAlways (Always a) (a -> p)
|
| forall a. IOAlways (Always a) (a -> p)
|
||||||
|
-- a sometimes that yields a payload
|
||||||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||||
|
|
||||||
-- | A dependency pertaining to the DBus
|
-- | A dependency pertaining to the DBus
|
||||||
|
@ -269,8 +277,10 @@ data DBusDependency_ = Bus BusName
|
||||||
data IODependency_ = IOSystem_ SystemDependency
|
data IODependency_ = IOSystem_ SystemDependency
|
||||||
| forall a. IOSometimes_ (Sometimes a)
|
| forall a. IOSometimes_ (Sometimes a)
|
||||||
|
|
||||||
data SystemDependency = Executable Bool FilePath
|
-- | A system component to an IODependency
|
||||||
| FontFamily String
|
-- This name is dumb, but most constructors should be obvious
|
||||||
|
data SystemDependency =
|
||||||
|
Executable Bool FilePath
|
||||||
| AccessiblePath FilePath Bool Bool
|
| AccessiblePath FilePath Bool Bool
|
||||||
| IOTest String (IO (Maybe String))
|
| IOTest String (IO (Maybe String))
|
||||||
| Systemd UnitType String
|
| Systemd UnitType String
|
||||||
|
@ -411,6 +421,7 @@ testTree test_ test = go
|
||||||
|
|
||||||
testIODependency :: IODependency p -> IO (Result p)
|
testIODependency :: IODependency p -> IO (Result p)
|
||||||
testIODependency (IORead _ t) = t
|
testIODependency (IORead _ t) = t
|
||||||
|
testIODependency (IOConst c) = return $ Right $ PostPass c []
|
||||||
-- TODO this is a bit odd because this is a dependency that will always
|
-- TODO this is a bit odd because this is a dependency that will always
|
||||||
-- succeed, which kinda makes this pointless. The only reason I would want this
|
-- succeed, which kinda makes this pointless. The only reason I would want this
|
||||||
-- is if I want to have a built-in logic to "choose" a payload to use in
|
-- is if I want to have a built-in logic to "choose" a payload to use in
|
||||||
|
@ -445,10 +456,6 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
||||||
where
|
where
|
||||||
msg = unwords [e, "executable", singleQuote bin, "not found"]
|
msg = unwords [e, "executable", singleQuote bin, "not found"]
|
||||||
e = if sys then "system" else "local"
|
e = if sys then "system" else "local"
|
||||||
testSysDependency (FontFamily fam) = shellTest cmd msg
|
|
||||||
where
|
|
||||||
msg = unwords ["font family", singleQuote fam, "not found"]
|
|
||||||
cmd = fmtCmd "fc-list" ["-q", singleQuote fam]
|
|
||||||
testSysDependency (Systemd t n) = shellTest cmd msg
|
testSysDependency (Systemd t n) = shellTest cmd msg
|
||||||
where
|
where
|
||||||
msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
|
||||||
|
@ -620,9 +627,6 @@ toAnd a b = And_ (Only_ a) (Only_ b)
|
||||||
exe :: Bool -> String -> IODependency_
|
exe :: Bool -> String -> IODependency_
|
||||||
exe b = IOSystem_ . Executable b
|
exe b = IOSystem_ . Executable b
|
||||||
|
|
||||||
fontFam :: String -> IODependency_
|
|
||||||
fontFam = IOSystem_ . FontFamily
|
|
||||||
|
|
||||||
sysExe :: String -> IODependency_
|
sysExe :: String -> IODependency_
|
||||||
sysExe = exe True
|
sysExe = exe True
|
||||||
|
|
||||||
|
@ -749,10 +753,10 @@ dataTree_ f_ = go
|
||||||
|
|
||||||
dataIODependency :: IODependency p -> DependencyData
|
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)])
|
||||||
-- TODO make this actually useful (I actually need to name my features)
|
(IOConst _) -> ("const", [])
|
||||||
(IOSometimes _ _) -> ("sometimes", [])
|
(IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)])
|
||||||
(IOAlways _ _) -> ("always", [])
|
(IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)])
|
||||||
|
|
||||||
dataIODependency_ :: IODependency_ -> DependencyData
|
dataIODependency_ :: IODependency_ -> DependencyData
|
||||||
dataIODependency_ d = case d of
|
dataIODependency_ d = case d of
|
||||||
|
@ -766,7 +770,6 @@ dataSysDependency d = first Q $
|
||||||
, ("path", JSON_Q $ Q path)
|
, ("path", JSON_Q $ Q path)
|
||||||
])
|
])
|
||||||
(IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
|
(IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)])
|
||||||
(FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)])
|
|
||||||
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
|
(AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p)
|
||||||
, ("readable", JSON_UQ $ jsonBool r)
|
, ("readable", JSON_UQ $ jsonBool r)
|
||||||
, ("writable", JSON_UQ $ jsonBool w)
|
, ("writable", JSON_UQ $ jsonBool w)
|
||||||
|
|
|
@ -22,9 +22,12 @@ module XMonad.Internal.Theme
|
||||||
, FontBuilder
|
, FontBuilder
|
||||||
, buildFont
|
, buildFont
|
||||||
, defFontData
|
, defFontData
|
||||||
, defFont
|
, defFontDep
|
||||||
|
, defFontTree
|
||||||
, fontFeature
|
, fontFeature
|
||||||
|
, fontDependency
|
||||||
, tabbedTheme
|
, tabbedTheme
|
||||||
|
, tabbedFeature
|
||||||
, promptTheme
|
, promptTheme
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -33,7 +36,11 @@ import Data.Colour
|
||||||
import Data.Colour.SRGB
|
import Data.Colour.SRGB
|
||||||
import Data.List
|
import Data.List
|
||||||
|
|
||||||
|
import System.Exit
|
||||||
|
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
|
import XMonad.Internal.Process
|
||||||
|
import XMonad.Internal.Shell
|
||||||
import qualified XMonad.Layout.Decoration as D
|
import qualified XMonad.Layout.Decoration as D
|
||||||
import qualified XMonad.Prompt as P
|
import qualified XMonad.Prompt as P
|
||||||
|
|
||||||
|
@ -130,11 +137,32 @@ buildFont (Just fam) FontData { weight = w
|
||||||
showLower :: Show a => Maybe a -> Maybe String
|
showLower :: Show a => Maybe a -> Maybe String
|
||||||
showLower = fmap (fmap toLower . show)
|
showLower = fmap (fmap toLower . show)
|
||||||
|
|
||||||
|
fallbackFont :: FontBuilder
|
||||||
|
fallbackFont = buildFont Nothing
|
||||||
|
|
||||||
|
testFont :: String -> IO (Result FontBuilder)
|
||||||
|
testFont fam = do
|
||||||
|
(rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) ""
|
||||||
|
return $ case rc of
|
||||||
|
ExitSuccess -> Right $ PostPass (buildFont $ Just fam) []
|
||||||
|
_ -> Left [msg]
|
||||||
|
where
|
||||||
|
msg = unwords ["font family", qFam, "not found"]
|
||||||
|
cmd = fmtCmd "fc-list" ["-q", qFam]
|
||||||
|
qFam = singleQuote fam
|
||||||
|
|
||||||
|
fontDependency :: String -> IODependency FontBuilder
|
||||||
|
fontDependency fam =
|
||||||
|
IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam
|
||||||
|
|
||||||
|
fontTree :: String -> IOTree FontBuilder
|
||||||
|
fontTree fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont)
|
||||||
|
|
||||||
fontFeature :: String -> String -> Always FontBuilder
|
fontFeature :: String -> String -> Always FontBuilder
|
||||||
fontFeature n fam = always1 n sfn root def
|
fontFeature n fam = always1 n sfn root def
|
||||||
where
|
where
|
||||||
sfn = "Font family for " ++ fam
|
sfn = "Font family for " ++ fam
|
||||||
root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam
|
root = IORoot id $ fontTree fam
|
||||||
def = buildFont Nothing
|
def = buildFont Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -149,8 +177,11 @@ defFontData = FontData
|
||||||
, pixelsize = Nothing
|
, pixelsize = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
defFont :: Always FontBuilder
|
defFontDep :: IODependency FontBuilder
|
||||||
defFont = fontFeature "Default Font" "DejaVu Sans"
|
defFontDep = fontDependency "DejaVu Sans"
|
||||||
|
|
||||||
|
defFontTree :: IOTree FontBuilder
|
||||||
|
defFontTree = fontTree "DejaVu Sans"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Complete themes
|
-- | Complete themes
|
||||||
|
@ -181,6 +212,13 @@ tabbedTheme fb = D.def
|
||||||
, D.windowTitleIcons = []
|
, D.windowTitleIcons = []
|
||||||
}
|
}
|
||||||
|
|
||||||
|
tabbedFeature :: Always D.Theme
|
||||||
|
tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
|
||||||
|
where
|
||||||
|
sf = Subfeature niceTheme "theme with nice font" Error
|
||||||
|
niceTheme = IORoot tabbedTheme $ Only defFontDep
|
||||||
|
fallback = Always_ $ FallbackAlone $ tabbedTheme fallbackFont
|
||||||
|
|
||||||
promptTheme :: FontBuilder -> P.XPConfig
|
promptTheme :: FontBuilder -> P.XPConfig
|
||||||
promptTheme fb = P.def
|
promptTheme fb = P.def
|
||||||
{ P.font = fb $ defFontData { size = Just 12 }
|
{ P.font = fb $ defFontData { size = Just 12 }
|
||||||
|
|
Loading…
Reference in New Issue