REF use common feature structure
This commit is contained in:
parent
f82e1bd032
commit
05c0b6a116
135
bin/xmonad.hs
135
bin/xmonad.hs
|
|
@ -8,10 +8,6 @@ module Main (main) where
|
|||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
( forM_
|
||||
, unless
|
||||
, void
|
||||
)
|
||||
|
||||
import Data.List
|
||||
( intercalate
|
||||
|
|
@ -85,70 +81,110 @@ parse _ = usage
|
|||
|
||||
run :: IO ()
|
||||
run = do
|
||||
db <- connectXDBus
|
||||
(h, p) <- spawnPipe "xmobar"
|
||||
ps <- catMaybes <$> mapM executeSometimes [ runNetAppDaemon
|
||||
conf <- evalConf =<< connectDBusX
|
||||
ds <- getDirectories
|
||||
-- IDK why this is necessary; nothing prior to this will print if missing
|
||||
hFlush stdout
|
||||
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
|
||||
]
|
||||
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
|
||||
let conf = ewmh
|
||||
$ addKeymap dws sk (filterExternal ext)
|
||||
|
||||
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 fb
|
||||
, layoutHook = myLayouts tt
|
||||
, manageHook = myManageHook dws
|
||||
, handleEventHook = myEventHook ha
|
||||
, startupHook = myStartupHook
|
||||
, workspaces = myWorkspaces
|
||||
, logHook = myLoghook h
|
||||
, logHook = myLoghook xmobarHandle
|
||||
, clickJustFocuses = False
|
||||
, focusFollowsMouse = False
|
||||
, normalBorderColor = T.bordersColor
|
||||
, focusedBorderColor = T.selectedBordersColor
|
||||
}
|
||||
launch conf ds
|
||||
where
|
||||
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 = do
|
||||
ses <- getDBusClient False
|
||||
sys <- getDBusClient True
|
||||
let db = DBusState ses sys
|
||||
db <- connectDBus
|
||||
(i, f, d) <- allFeatures db
|
||||
is <- mapM dumpSometimes i
|
||||
fs <- mapM dumpFeature f
|
||||
ds <- mapM dumpSometimes d
|
||||
let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds
|
||||
putStrLn u
|
||||
forM_ ses disconnect
|
||||
forM_ sys disconnect
|
||||
disconnectDBus db
|
||||
|
||||
allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||
allFeatures db = do
|
||||
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
|
||||
$ externalBindings ts db
|
||||
let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters
|
||||
let others = [runRemovableMon $ dbSystemClient db, runPowermon]
|
||||
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
||||
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
||||
return (dbus ++ others, Left runScreenLock:bfs, allDWs')
|
||||
where
|
||||
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
|
||||
|
|
@ -159,26 +195,9 @@ usage = putStrLn $ intercalate "\n"
|
|||
, "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
|
||||
|
||||
data DBusState = DBusState
|
||||
{ dbSessionClient :: Maybe Client
|
||||
, dbSystemClient :: Maybe Client
|
||||
}
|
||||
|
||||
data ThreadState = ThreadState
|
||||
{ tsChildPIDs :: [ProcessHandle]
|
||||
, tsChildHandles :: [Handle]
|
||||
|
|
@ -188,8 +207,7 @@ data ThreadState = ThreadState
|
|||
runCleanup :: ThreadState -> DBusState -> X ()
|
||||
runCleanup ts db = io $ do
|
||||
mapM_ killHandle $ tsChildPIDs ts
|
||||
forM_ (dbSessionClient db) stopXMonadService
|
||||
forM_ (dbSystemClient db) disconnect
|
||||
disconnectDBusX db
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Startuphook configuration
|
||||
|
|
@ -300,21 +318,18 @@ allDWs' = [xsaneDynamicWorkspace
|
|||
, f5vpnDynamicWorkspace
|
||||
]
|
||||
|
||||
allDWs :: IO [DynWorkspace]
|
||||
allDWs = catMaybes <$> mapM evalSometimes allDWs'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Layout configuration
|
||||
|
||||
-- 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
|
||||
-- make a new type :/
|
||||
myLayouts fb = onWorkspace vmTag vmLayout
|
||||
myLayouts tt = onWorkspace vmTag vmLayout
|
||||
$ onWorkspace gimpTag gimpLayout
|
||||
$ mkToggle (single HIDE)
|
||||
$ tall ||| fulltab ||| full
|
||||
where
|
||||
addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb
|
||||
addTopBar = noFrillsDeco shrinkText tt
|
||||
tall = renamed [Replace "Tall"]
|
||||
$ avoidStruts
|
||||
$ addTopBar
|
||||
|
|
@ -323,7 +338,7 @@ myLayouts fb = onWorkspace vmTag vmLayout
|
|||
fulltab = renamed [Replace "Tabbed"]
|
||||
$ avoidStruts
|
||||
$ noBorders
|
||||
$ tabbedAlways shrinkText $ T.tabbedTheme fb
|
||||
$ tabbedAlways shrinkText tt
|
||||
full = renamed [Replace "Full"]
|
||||
$ noBorders Full
|
||||
vmLayout = noBorders Full
|
||||
|
|
@ -656,7 +671,7 @@ externalBindings ts db =
|
|||
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec
|
||||
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
|
||||
, 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-<Delete>" "lock screen" $ Left runScreenLock
|
||||
-- M-<F1> reserved for showing the keymap
|
||||
|
|
@ -672,7 +687,7 @@ externalBindings ts db =
|
|||
]
|
||||
]
|
||||
where
|
||||
cl = dbSessionClient db
|
||||
cl = dbSesClient db
|
||||
brightessControls ctl getter = (ioSometimes . getter . ctl) cl
|
||||
ib = Left . brightessControls intelBacklightControls
|
||||
ck = Left . brightessControls clevoKeyboardControls
|
||||
|
|
|
|||
|
|
@ -96,8 +96,7 @@ quitPrompt :: T.FontBuilder -> X ()
|
|||
quitPrompt = confirmPrompt' "quit?" $ io exitSuccess
|
||||
|
||||
sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX
|
||||
sometimesPrompt n = sometimesIO n (n ++ " command")
|
||||
$ Only $ IOAlways T.defFont id
|
||||
sometimesPrompt n = sometimesIO n (n ++ " command") T.defFontTree
|
||||
|
||||
-- TODO doesn't this need to also lock the screen?
|
||||
runSuspendPrompt :: SometimesX
|
||||
|
|
@ -141,7 +140,7 @@ runOptimusPrompt = Sometimes "graphics switcher" [s]
|
|||
where
|
||||
s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error }
|
||||
r = IORoot runOptimusPrompt' t
|
||||
t = And1 (Only $ IOAlways T.defFont id)
|
||||
t = And1 T.defFontTree
|
||||
$ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -170,16 +169,13 @@ data PowerPrompt = PowerPrompt
|
|||
instance XPrompt PowerPrompt where
|
||||
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
||||
|
||||
runPowerPrompt :: AlwaysX
|
||||
runPowerPrompt = Always "power prompt" $ Option sf fallback
|
||||
runPowerPrompt :: SometimesX
|
||||
runPowerPrompt = Sometimes "power prompt" [sf]
|
||||
where
|
||||
sf = Subfeature withLock "lock-enabled prompt" Error
|
||||
sf = Subfeature withLock "prompt with lock" Error
|
||||
withLock = IORoot (uncurry powerPrompt) tree
|
||||
tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id)
|
||||
fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont
|
||||
|
||||
powerPromptNoLock :: T.FontBuilder -> X ()
|
||||
powerPromptNoLock = powerPrompt skip
|
||||
tree = And12 (,) lockTree T.defFontTree
|
||||
lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip)
|
||||
|
||||
powerPrompt :: X () -> T.FontBuilder -> X ()
|
||||
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.Dependency
|
||||
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
|
||||
|
|
@ -120,6 +123,6 @@ runHandleACPI :: Always (String -> X ())
|
|||
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
||||
where
|
||||
sf = Subfeature withLock "acpid prompt" Error
|
||||
withLock = IORoot (uncurry handleACPI)
|
||||
$ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id)
|
||||
fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont
|
||||
withLock = IORoot (uncurry handleACPI) $ And12 (,) defFontTree $ Only
|
||||
$ IOSometimes runScreenLock id
|
||||
fallback = Always_ $ FallbackAlone $ const skip
|
||||
|
|
|
|||
|
|
@ -5,16 +5,19 @@
|
|||
|
||||
module XMonad.Internal.DBus.Control
|
||||
( Client
|
||||
, startXMonadService
|
||||
, DBusState(..)
|
||||
, connectDBus
|
||||
, connectDBusX
|
||||
, disconnectDBus
|
||||
, disconnectDBusX
|
||||
, getDBusClient
|
||||
, withDBusClient
|
||||
, withDBusClient_
|
||||
, stopXMonadService
|
||||
, disconnect
|
||||
, dbusExporters
|
||||
) where
|
||||
|
||||
import Control.Monad (forM_, void)
|
||||
import Control.Monad
|
||||
|
||||
import DBus
|
||||
import DBus.Client
|
||||
|
|
@ -26,17 +29,42 @@ import XMonad.Internal.DBus.Common
|
|||
import XMonad.Internal.DBus.Screensaver
|
||||
import XMonad.Internal.Dependency
|
||||
|
||||
startXMonadService :: IO (Maybe Client)
|
||||
startXMonadService = do
|
||||
client <- getDBusClient False
|
||||
forM_ client requestXMonadName
|
||||
mapM_ (\f -> executeSometimes $ f client) dbusExporters
|
||||
return client
|
||||
-- | Current connections to the DBus (session and system buses)
|
||||
data DBusState = DBusState
|
||||
{ dbSesClient :: Maybe Client
|
||||
, dbSysClient :: Maybe Client
|
||||
}
|
||||
|
||||
stopXMonadService :: Client -> IO ()
|
||||
stopXMonadService client = do
|
||||
void $ releaseName client xmonadBusName
|
||||
disconnect client
|
||||
-- | Connect to the DBus
|
||||
connectDBus :: IO DBusState
|
||||
connectDBus = do
|
||||
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 = do
|
||||
|
|
@ -51,5 +79,5 @@ requestXMonadName client = do
|
|||
where
|
||||
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||
|
||||
dbusExporters :: [Maybe Client -> SometimesIO]
|
||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||
-- executeExporters :: Maybe Client -> IO ()
|
||||
-- executeExporters cl = mapM_ (\f -> executeSometimes $ f cl) dbusExporters
|
||||
|
|
|
|||
|
|
@ -74,7 +74,6 @@ module XMonad.Internal.Dependency
|
|||
-- dependency construction
|
||||
, sysExe
|
||||
, localExe
|
||||
, fontFam
|
||||
, sysdSystem
|
||||
, sysdUser
|
||||
, listToAnds
|
||||
|
|
@ -83,6 +82,9 @@ module XMonad.Internal.Dependency
|
|||
, pathRW
|
||||
, pathW
|
||||
, sysTest
|
||||
|
||||
-- misc
|
||||
, shellTest
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
|
|
@ -255,9 +257,15 @@ type DBusTree p = Tree IODependency DBusDependency_ p
|
|||
type IOTree_ = Tree_ IODependency_
|
||||
type DBusTree_ = Tree_ DBusDependency_
|
||||
|
||||
-- | A dependency that only requires IO to evaluate
|
||||
data IODependency p = IORead String (IO (Result p))
|
||||
-- | A dependency that only requires IO to evaluate (with payload)
|
||||
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)
|
||||
-- a sometimes that yields a payload
|
||||
| forall a. IOSometimes (Sometimes a) (a -> p)
|
||||
|
||||
-- | A dependency pertaining to the DBus
|
||||
|
|
@ -269,8 +277,10 @@ data DBusDependency_ = Bus BusName
|
|||
data IODependency_ = IOSystem_ SystemDependency
|
||||
| forall a. IOSometimes_ (Sometimes a)
|
||||
|
||||
data SystemDependency = Executable Bool FilePath
|
||||
| FontFamily String
|
||||
-- | A system component to an IODependency
|
||||
-- This name is dumb, but most constructors should be obvious
|
||||
data SystemDependency =
|
||||
Executable Bool FilePath
|
||||
| AccessiblePath FilePath Bool Bool
|
||||
| IOTest String (IO (Maybe String))
|
||||
| Systemd UnitType String
|
||||
|
|
@ -411,6 +421,7 @@ testTree test_ test = go
|
|||
|
||||
testIODependency :: IODependency p -> IO (Result p)
|
||||
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
|
||||
-- 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
|
||||
|
|
@ -445,10 +456,6 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing)
|
|||
where
|
||||
msg = unwords [e, "executable", singleQuote bin, "not found"]
|
||||
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
|
||||
where
|
||||
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 b = IOSystem_ . Executable b
|
||||
|
||||
fontFam :: String -> IODependency_
|
||||
fontFam = IOSystem_ . FontFamily
|
||||
|
||||
sysExe :: String -> IODependency_
|
||||
sysExe = exe True
|
||||
|
||||
|
|
@ -750,9 +754,9 @@ dataTree_ f_ = go
|
|||
dataIODependency :: IODependency p -> DependencyData
|
||||
dataIODependency d = first Q $ case d of
|
||||
(IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)])
|
||||
-- TODO make this actually useful (I actually need to name my features)
|
||||
(IOSometimes _ _) -> ("sometimes", [])
|
||||
(IOAlways _ _) -> ("always", [])
|
||||
(IOConst _) -> ("const", [])
|
||||
(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
|
||||
|
|
@ -766,7 +770,6 @@ dataSysDependency d = first Q $
|
|||
, ("path", JSON_Q $ Q path)
|
||||
])
|
||||
(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)
|
||||
, ("readable", JSON_UQ $ jsonBool r)
|
||||
, ("writable", JSON_UQ $ jsonBool w)
|
||||
|
|
|
|||
|
|
@ -22,9 +22,12 @@ module XMonad.Internal.Theme
|
|||
, FontBuilder
|
||||
, buildFont
|
||||
, defFontData
|
||||
, defFont
|
||||
, defFontDep
|
||||
, defFontTree
|
||||
, fontFeature
|
||||
, fontDependency
|
||||
, tabbedTheme
|
||||
, tabbedFeature
|
||||
, promptTheme
|
||||
) where
|
||||
|
||||
|
|
@ -33,7 +36,11 @@ import Data.Colour
|
|||
import Data.Colour.SRGB
|
||||
import Data.List
|
||||
|
||||
import System.Exit
|
||||
|
||||
import XMonad.Internal.Dependency
|
||||
import XMonad.Internal.Process
|
||||
import XMonad.Internal.Shell
|
||||
import qualified XMonad.Layout.Decoration as D
|
||||
import qualified XMonad.Prompt as P
|
||||
|
||||
|
|
@ -130,11 +137,32 @@ buildFont (Just fam) FontData { weight = w
|
|||
showLower :: Show a => Maybe a -> Maybe String
|
||||
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 n fam = always1 n sfn root def
|
||||
where
|
||||
sfn = "Font family for " ++ fam
|
||||
root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam
|
||||
root = IORoot id $ fontTree fam
|
||||
def = buildFont Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -149,8 +177,11 @@ defFontData = FontData
|
|||
, pixelsize = Nothing
|
||||
}
|
||||
|
||||
defFont :: Always FontBuilder
|
||||
defFont = fontFeature "Default Font" "DejaVu Sans"
|
||||
defFontDep :: IODependency FontBuilder
|
||||
defFontDep = fontDependency "DejaVu Sans"
|
||||
|
||||
defFontTree :: IOTree FontBuilder
|
||||
defFontTree = fontTree "DejaVu Sans"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Complete themes
|
||||
|
|
@ -181,6 +212,13 @@ tabbedTheme fb = D.def
|
|||
, 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 fb = P.def
|
||||
{ P.font = fb $ defFontData { size = Just 12 }
|
||||
|
|
|
|||
Loading…
Reference in New Issue