xmonad-config/bin/xmobar.hs

594 lines
15 KiB
Haskell
Raw Normal View History

-- | Xmobar binary
--
-- Features:
-- * Uses the 'UnsafeStdinReader' to receive the current workspace/layout config
-- from xmonad
-- * FontAwesome and Symbol fonts for icons
-- * Some custom plugins (imported below)
-- * Theme integration with xmonad (shared module imported below)
-- * A custom Locks plugin from my own forked repo
2022-12-30 14:58:23 -05:00
module Main (main) where
2022-12-30 14:58:23 -05:00
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2023-10-25 21:55:59 -04:00
import GHC.Enum (enumFrom)
2023-01-01 11:44:36 -05:00
import Options.Applicative
2022-12-30 14:58:23 -05:00
import RIO hiding (hFlush)
2024-01-07 09:52:44 -05:00
import RIO.FilePath
2022-12-31 19:47:02 -05:00
import RIO.List
2023-09-30 18:51:07 -04:00
import qualified RIO.NonEmpty as NE
2022-12-30 14:58:23 -05:00
import qualified RIO.Text as T
import XMonad.Core hiding (config)
import XMonad.Internal.Command.Power
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import qualified XMonad.Internal.Theme as XT
import Xmobar hiding
( iconOffset
, run
)
import Xmobar.Plugins.ActiveConnection
2022-12-30 14:58:23 -05:00
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
2022-08-01 16:16:08 -04:00
2021-06-23 23:08:50 -04:00
main :: IO ()
2023-01-01 11:44:36 -05:00
main = parse >>= xio
2022-08-01 16:16:08 -04:00
2023-01-01 11:44:36 -05:00
parse :: IO XOpts
parse = execParser opts
where
parseOpts = parseDeps <|> parseTest <|> pure XRun
opts =
info (parseOpts <**> helper) $
fullDesc <> header "xmobar: the best taskbar ever"
2022-08-01 16:16:08 -04:00
2023-01-01 11:44:36 -05:00
data XOpts = XDeps | XTest | XRun
parseDeps :: Parser XOpts
parseDeps =
flag'
XDeps
(long "deps" <> short 'd' <> help "print dependencies")
parseTest :: Parser XOpts
parseTest =
flag'
XTest
(long "test" <> short 't' <> help "test dependencies without running")
xio :: XOpts -> IO ()
xio o = case o of
XDeps -> hRunXIO False stderr printDeps
2023-10-27 23:12:22 -04:00
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
XRun -> runXIO "xmobar.log" run
2023-01-01 11:44:36 -05:00
2023-01-01 15:00:40 -05:00
run :: XIO ()
2022-12-31 23:18:41 -05:00
run = do
-- IDK why this is needed, I thought this was default
2023-01-01 11:44:36 -05:00
liftIO $ hSetBuffering stdout LineBuffering
2023-01-01 18:06:48 -05:00
-- this isn't totally necessary except for the fact that killing xmobar
-- will make it print something about catching SIGTERM, and without
-- linebuffering it usually only prints the first few characters (even then
-- it only prints 10-20% of the time)
liftIO $ hSetBuffering stderr LineBuffering
2023-10-27 23:12:22 -04:00
-- TODO do these dbus things really need to remain connected?
c <- withDBus Nothing Nothing evalConfig
liftIO $ xmobar c
2023-01-01 15:00:40 -05:00
evalConfig :: DBusState -> XIO Config
evalConfig db = do
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
(ifs, ios) <- getIconFonts
d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d
2023-01-01 15:00:40 -05:00
printDeps :: XIO ()
2023-10-27 23:12:22 -04:00
printDeps = withDBus_ Nothing Nothing $ \db ->
mapM_ logInfo $
fmap showFulfillment $
sort $
nub $
2022-12-31 22:33:33 -05:00
concatMap dumpFeature $
allFeatures db
2022-08-01 16:16:08 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- toplevel configuration
-- | The text font family
textFont :: Always XT.FontBuilder
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono" defFontPkgs
-- | Offset of the text in the bar
textFontOffset :: Int
textFontOffset = 16
-- | Attributes for the bar font (size, weight, etc)
textFontData :: XT.FontData
2022-12-30 14:58:23 -05:00
textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
-- | The icon font family
iconFont :: Sometimes XT.FontBuilder
2022-12-30 14:58:23 -05:00
iconFont =
fontSometimes
"XMobar Icon Font"
"Symbols Nerd Font"
2023-05-08 12:15:20 -04:00
[Package Official "ttf-nerd-fonts-symbols"]
-- | Offsets for the icons in the bar (relative to the text offset)
iconOffset :: BarFont -> Int
2022-12-30 14:58:23 -05:00
iconOffset IconSmall = 0
iconOffset IconMedium = 1
2022-12-30 14:58:23 -05:00
iconOffset IconLarge = 1
iconOffset IconXLarge = 2
-- | Sizes (in pixels) for the icon fonts
iconSize :: BarFont -> Int
2022-12-30 14:58:23 -05:00
iconSize IconSmall = 13
iconSize IconMedium = 15
2022-12-30 14:58:23 -05:00
iconSize IconLarge = 18
iconSize IconXLarge = 20
-- | Attributes for icon fonts
iconFontData :: Int -> XT.FontData
2022-12-30 14:58:23 -05:00
iconFontData s = XT.defFontData {XT.pixelsize = Just s, XT.size = Nothing}
-- | Global configuration
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
-- only one) text font, and all other fonts are icon fonts. If this assumption
-- changes the code will need to change significantly
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
2022-12-30 14:58:23 -05:00
config bf ifs ios br confDir =
defaultConfig
{ font = T.unpack bf
, additionalFonts = fmap T.unpack ifs
, textOffset = textFontOffset
, textOffsets = ios
, bgColor = T.unpack XT.bgColor
, fgColor = T.unpack XT.fgColor
, position = BottomSize C 100 24
, border = NoBorder
, borderColor = T.unpack XT.bordersColor
, sepChar = T.unpack pSep
, alignSep = [lSep, rSep]
, template = T.unpack $ fmtRegions br
, lowerOnStart = False
, hideOnStart = False
, allDesktops = True
, overrideRedirect = True
, pickBroadest = False
, persistent = True
, -- store the icons with the xmonad/xmobar stack project
2024-01-07 09:52:44 -05:00
iconRoot = confDir </> "assets" </> "icons"
2022-12-30 14:58:23 -05:00
, commands = csRunnable <$> concatRegions br
}
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- plugin features
--
-- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here
getAllCommands :: [Maybe CmdSpec] -> BarRegions
2022-12-30 14:58:23 -05:00
getAllCommands right =
BarRegions
{ brLeft =
[ CmdSpec
{ csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader
}
]
, brCenter = []
, brRight = catMaybes right
}
2023-01-01 15:00:40 -05:00
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
2022-12-30 14:58:23 -05:00
rightPlugins db =
mapM evalFeature $
allFeatures db
++ [always' "date indicator" dateCmd]
2022-08-01 16:16:08 -04:00
where
always' n = Right . Always n . Always_ . FallbackAlone
allFeatures :: DBusState -> [Feature CmdSpec]
2022-12-30 14:58:23 -05:00
allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
[ Left getWireless
, Left $ getEthernet sys
, Left $ getVPN sys
, Left $ getBt sys
, Left getAlsa
, Left getBattery
, Left $ getBl ses
, Left $ getCk ses
, Left $ getSs ses
, Right getLock
]
type BarFeature = Sometimes CmdSpec
2022-07-07 01:05:17 -04:00
-- TODO what if I don't have a wireless card?
getWireless :: BarFeature
2022-12-30 14:58:23 -05:00
getWireless =
Sometimes
"wireless status indicator"
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
2023-10-27 23:12:22 -04:00
getEthernet :: Maybe NamedSysConnection -> BarFeature
2023-09-30 18:51:07 -04:00
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
where
2023-09-30 18:51:07 -04:00
root useIcon tree' =
DBusRoot_ (const $ ethernetCmd useIcon) tree' cl
getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
2022-12-30 14:58:23 -05:00
tree =
Only_ $
IOTest_ "Test if battery is present" [] $
io $
fmap (Msg LevelError) <$> hasBattery
2023-10-27 23:12:22 -04:00
getVPN :: Maybe NamedSysConnection -> BarFeature
2023-10-01 00:24:33 -04:00
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
2023-10-27 23:12:22 -04:00
getBt :: Maybe NamedSysConnection -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
getAlsa :: BarFeature
2022-12-30 14:58:23 -05:00
getAlsa =
iconIO_ "volume level indicator" (const True) root $
Only_ $
sysExe [Package Official "alsa-utils"] "alsactl"
where
root useIcon = IORoot_ (alsaCmd useIcon)
2023-10-27 23:12:22 -04:00
getBl :: Maybe NamedSesConnection -> BarFeature
2022-12-30 14:58:23 -05:00
getBl =
xmobarDBus
"Intel backlight indicator"
xpfIntelBacklight
intelBacklightSignalDep
blCmd
2023-10-27 23:12:22 -04:00
getCk :: Maybe NamedSesConnection -> BarFeature
2022-12-30 14:58:23 -05:00
getCk =
xmobarDBus
"Clevo keyboard indicator"
xpfClevoBacklight
clevoKeyboardSignalDep
ckCmd
2023-10-27 23:12:22 -04:00
getSs :: Maybe NamedSesConnection -> BarFeature
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
getLock :: Always CmdSpec
getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
where
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- bar feature constructors
xmobarDBus
:: SafeClient c
=> T.Text
-> XPQuery
-> DBusDependency_ c
-> (Fontifier -> CmdSpec)
2023-10-27 23:12:22 -04:00
-> Maybe (NamedConnection c)
2022-12-30 14:58:23 -05:00
-> BarFeature
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
2022-12-30 14:58:23 -05:00
iconIO_
:: T.Text
-> XPQuery
-> (Fontifier -> IOTree_ -> Root CmdSpec)
-> IOTree_
-> BarFeature
iconIO_ = iconSometimes' And_ Only_
2023-09-30 18:51:07 -04:00
-- iconDBus
-- :: T.Text
-- -> XPQuery
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
-- -> DBusTree c p
-- -> BarFeature
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
2022-12-30 14:58:23 -05:00
iconDBus_
2023-02-12 23:08:05 -05:00
:: T.Text
2022-12-30 14:58:23 -05:00
-> XPQuery
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
-> DBusTree_ c
-> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
2022-12-30 14:58:23 -05:00
iconSometimes'
:: (t -> t_ -> t)
-> (IODependency_ -> t_)
-> T.Text
-> XPQuery
-> (Fontifier -> t -> Root CmdSpec)
-> t
-> BarFeature
iconSometimes' c d n q r t =
Sometimes
n
q
[ Subfeature icon "icon indicator"
, Subfeature text "text indicator"
]
where
icon = r fontifyIcon $ c t $ d iconDependency
text = r fontifyAlt t
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- command specifications
data BarRegions = BarRegions
2022-12-30 14:58:23 -05:00
{ brLeft :: [CmdSpec]
, brCenter :: [CmdSpec]
2022-12-30 14:58:23 -05:00
, brRight :: [CmdSpec]
}
deriving (Show)
data CmdSpec = CmdSpec
2022-12-30 14:58:23 -05:00
{ csAlias :: T.Text
, csRunnable :: Runnable
2022-12-30 14:58:23 -05:00
}
deriving (Show)
concatRegions :: BarRegions -> [CmdSpec]
concatRegions (BarRegions l c r) = l ++ c ++ r
wirelessCmd :: T.Text -> CmdSpec
2022-12-30 14:58:23 -05:00
wirelessCmd iface =
CmdSpec
{ csAlias = T.append iface "wi"
, csRunnable = Run $ Wireless (T.unpack iface) args 5
}
where
2022-12-30 14:58:23 -05:00
args =
fmap
T.unpack
[ "-t"
, "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern"
, "<icon=wifi_%%.xpm/>"
]
ethernetCmd :: Fontifier -> CmdSpec
ethernetCmd = connCmd "\xf0e8" "ETH" ("vlan" :| ["802-3-ethernet"])
vpnCmd :: Fontifier -> CmdSpec
vpnCmd = connCmd "\xf023" "VPN" ("tun" :| [])
connCmd :: T.Text -> T.Text -> NE.NonEmpty T.Text -> Fontifier -> CmdSpec
connCmd icon abbr contypes fontify =
2022-12-30 14:58:23 -05:00
CmdSpec
{ csAlias = connAlias contypes
2022-12-30 14:58:23 -05:00
, csRunnable =
Run $
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
2022-12-30 14:58:23 -05:00
}
batteryCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
batteryCmd fontify =
CmdSpec
{ csAlias = "battery"
, csRunnable = Run $ Battery args 50
}
2021-06-30 23:04:00 -04:00
where
fontify' = fontify IconSmall
2022-12-30 14:58:23 -05:00
args =
fmap
T.unpack
[ "--template"
, "<acstatus><left>"
, "--Low"
, "10"
, "--High"
, "80"
, "--low"
, "red"
, "--normal"
, XT.fgColor
, "--high"
, XT.fgColor
, "--"
, "-P"
, "-o"
, fontify' "\xf0e7" "BAT"
, "-O"
, fontify' "\xf1e6" "AC"
, "-i"
, fontify' "\xf1e6" "AC"
]
btCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
btCmd fontify =
CmdSpec
{ csAlias = btAlias
, csRunnable =
Run $
2023-05-08 23:00:58 -04:00
Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
2022-12-30 14:58:23 -05:00
}
2021-11-27 17:33:02 -05:00
where
fontify' i = fontify IconLarge i . T.append "BT"
alsaCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
alsaCmd fontify =
CmdSpec
{ csAlias = "alsa:default:Master"
, csRunnable =
Run $
Alsa "default" "Master" $
fmap
T.unpack
[ "-t"
, "<status><volume>%"
, "--"
, "-O"
, fontify' "\xf028" "+"
, "-o"
, T.append (fontify' "\xf026" "-") " "
, "-c"
, XT.fgColor
, "-C"
, XT.fgColor
]
}
where
fontify' i = fontify IconSmall i . T.append "VOL"
blCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
blCmd fontify =
CmdSpec
{ csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
}
ckCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
ckCmd fontify =
CmdSpec
{ csAlias = ckAlias
2023-05-08 23:00:58 -04:00
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
2022-12-30 14:58:23 -05:00
}
ssCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
ssCmd fontify =
CmdSpec
{ csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
}
lockCmd :: Fontifier -> CmdSpec
2022-12-30 14:58:23 -05:00
lockCmd fontify =
CmdSpec
{ csAlias = "locks"
, csRunnable =
Run $
Locks $
fmap
T.unpack
[ "-N"
, numIcon
, "-n"
, disabledColor numIcon
, "-C"
, capIcon
, "-c"
, disabledColor capIcon
, "-s"
, ""
, "-S"
, ""
, "-d"
, " "
]
}
2021-11-27 17:33:02 -05:00
where
2023-05-08 12:15:20 -04:00
numIcon = fontify' "\x0f03a6" "N"
capIcon = fontify' "\x0f0bf1" "C"
fontify' = fontify IconXLarge
disabledColor = xmobarFGColor XT.backdropFgColor
2021-06-23 23:08:50 -04:00
dateCmd :: CmdSpec
2022-12-30 14:58:23 -05:00
dateCmd =
CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- text font
--
-- ASSUME there is only one text font for this entire configuration. This
-- will correspond to the first font/offset parameters in the config record.
2023-01-01 15:00:40 -05:00
getTextFont :: XIO T.Text
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- icon fonts
2021-06-23 23:08:50 -04:00
2023-01-01 15:00:40 -05:00
getIconFonts :: XIO ([T.Text], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb
2021-11-21 23:55:19 -05:00
where
2022-12-30 14:58:23 -05:00
apply fb =
unzip $
(\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
2021-06-23 23:08:50 -04:00
2022-12-30 14:58:23 -05:00
data BarFont
= IconSmall
2021-11-27 17:33:02 -05:00
| IconMedium
| IconLarge
| IconXLarge
deriving (Eq, Enum, Bounded, Show)
2021-06-23 23:08:50 -04:00
iconFonts :: [BarFont]
iconFonts = enumFrom minBound
2022-07-02 17:09:21 -04:00
iconString :: XT.FontBuilder -> BarFont -> T.Text
iconString fb i = fb $ iconFontData $ iconSize i
iconDependency :: IODependency_
iconDependency = IOSometimes_ iconFont
2022-07-02 17:09:21 -04:00
fontifyText :: BarFont -> T.Text -> T.Text
fontifyText fnt txt =
T.concat ["<fn=", T.pack $ show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
type Fontifier = BarFont -> T.Text -> T.Text -> T.Text
fontifyAlt :: Fontifier
fontifyAlt _ _ alt = alt
fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i
2021-11-27 17:33:02 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- various formatting things
2021-11-27 17:33:02 -05:00
colors :: Colors
2022-12-30 14:58:23 -05:00
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
2021-11-27 17:33:02 -05:00
sep :: T.Text
sep = xmobarFGColor XT.backdropFgColor " : "
2021-11-27 17:33:02 -05:00
lSep :: Char
lSep = '}'
rSep :: Char
rSep = '{'
2020-03-22 17:17:57 -04:00
pSep :: T.Text
2021-11-27 17:33:02 -05:00
pSep = "%"
fmtSpecs :: [CmdSpec] -> T.Text
fmtSpecs = T.intercalate sep . fmap go
2021-11-27 17:33:02 -05:00
where
2022-12-30 14:58:23 -05:00
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
2021-11-27 17:33:02 -05:00
fmtRegions :: BarRegions -> T.Text
2022-12-30 14:58:23 -05:00
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
T.concat
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]