REF use common feature structure

This commit is contained in:
Nathan Dwarshuis 2022-07-03 18:23:32 -04:00
parent f82e1bd032
commit 05c0b6a116
6 changed files with 211 additions and 128 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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 }