594 lines
15 KiB
Haskell
594 lines
15 KiB
Haskell
-- | 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
|
|
module Main (main) where
|
|
|
|
import Data.Internal.DBus
|
|
import Data.Internal.XIO
|
|
import GHC.Enum (enumFrom)
|
|
import Options.Applicative
|
|
import RIO hiding (hFlush)
|
|
import RIO.FilePath
|
|
import RIO.List
|
|
import qualified RIO.NonEmpty as NE
|
|
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
|
|
import Xmobar.Plugins.Bluetooth
|
|
import Xmobar.Plugins.ClevoKeyboard
|
|
import Xmobar.Plugins.Common
|
|
import Xmobar.Plugins.IntelBacklight
|
|
import Xmobar.Plugins.Screensaver
|
|
|
|
main :: IO ()
|
|
main = parse >>= xio
|
|
|
|
parse :: IO XOpts
|
|
parse = execParser opts
|
|
where
|
|
parseOpts = parseDeps <|> parseTest <|> pure XRun
|
|
opts =
|
|
info (parseOpts <**> helper) $
|
|
fullDesc <> header "xmobar: the best taskbar ever"
|
|
|
|
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
|
|
XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
|
|
XRun -> runXIO "xmobar.log" run
|
|
|
|
run :: XIO ()
|
|
run = do
|
|
-- IDK why this is needed, I thought this was default
|
|
liftIO $ hSetBuffering stdout LineBuffering
|
|
-- 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
|
|
-- TODO do these dbus things really need to remain connected?
|
|
c <- withDBus Nothing Nothing evalConfig
|
|
liftIO $ xmobar c
|
|
|
|
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
|
|
|
|
printDeps :: XIO ()
|
|
printDeps = withDBus_ Nothing Nothing $ \db ->
|
|
mapM_ logInfo $
|
|
fmap showFulfillment $
|
|
sort $
|
|
nub $
|
|
concatMap dumpFeature $
|
|
allFeatures db
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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
|
|
textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
|
|
|
|
-- | The icon font family
|
|
iconFont :: Sometimes XT.FontBuilder
|
|
iconFont =
|
|
fontSometimes
|
|
"XMobar Icon Font"
|
|
"Symbols Nerd Font"
|
|
[Package Official "ttf-nerd-fonts-symbols"]
|
|
|
|
-- | Offsets for the icons in the bar (relative to the text offset)
|
|
iconOffset :: BarFont -> Int
|
|
iconOffset IconSmall = 0
|
|
iconOffset IconMedium = 1
|
|
iconOffset IconLarge = 1
|
|
iconOffset IconXLarge = 2
|
|
|
|
-- | Sizes (in pixels) for the icon fonts
|
|
iconSize :: BarFont -> Int
|
|
iconSize IconSmall = 13
|
|
iconSize IconMedium = 15
|
|
iconSize IconLarge = 18
|
|
iconSize IconXLarge = 20
|
|
|
|
-- | Attributes for icon fonts
|
|
iconFontData :: Int -> XT.FontData
|
|
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
|
|
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
|
|
iconRoot = confDir </> "assets" </> "icons"
|
|
, commands = csRunnable <$> concatRegions br
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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
|
|
getAllCommands right =
|
|
BarRegions
|
|
{ brLeft =
|
|
[ CmdSpec
|
|
{ csAlias = "UnsafeStdinReader"
|
|
, csRunnable = Run UnsafeStdinReader
|
|
}
|
|
]
|
|
, brCenter = []
|
|
, brRight = catMaybes right
|
|
}
|
|
|
|
rightPlugins :: DBusState -> XIO [Maybe CmdSpec]
|
|
rightPlugins db =
|
|
mapM evalFeature $
|
|
allFeatures db
|
|
++ [always' "date indicator" dateCmd]
|
|
where
|
|
always' n = Right . Always n . Always_ . FallbackAlone
|
|
|
|
allFeatures :: DBusState -> [Feature CmdSpec]
|
|
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
|
|
|
|
-- TODO what if I don't have a wireless card?
|
|
getWireless :: BarFeature
|
|
getWireless =
|
|
Sometimes
|
|
"wireless status indicator"
|
|
xpfWireless
|
|
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
|
|
|
getEthernet :: Maybe NamedSysConnection -> BarFeature
|
|
getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
|
|
where
|
|
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)
|
|
tree =
|
|
Only_ $
|
|
IOTest_ "Test if battery is present" [] $
|
|
io $
|
|
fmap (Msg LevelError) <$> hasBattery
|
|
|
|
getVPN :: Maybe NamedSysConnection -> BarFeature
|
|
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
|
|
where
|
|
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
|
|
|
getBt :: Maybe NamedSysConnection -> BarFeature
|
|
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
|
|
|
getAlsa :: BarFeature
|
|
getAlsa =
|
|
iconIO_ "volume level indicator" (const True) root $
|
|
Only_ $
|
|
sysExe [Package Official "alsa-utils"] "alsactl"
|
|
where
|
|
root useIcon = IORoot_ (alsaCmd useIcon)
|
|
|
|
getBl :: Maybe NamedSesConnection -> BarFeature
|
|
getBl =
|
|
xmobarDBus
|
|
"Intel backlight indicator"
|
|
xpfIntelBacklight
|
|
intelBacklightSignalDep
|
|
blCmd
|
|
|
|
getCk :: Maybe NamedSesConnection -> BarFeature
|
|
getCk =
|
|
xmobarDBus
|
|
"Clevo keyboard indicator"
|
|
xpfClevoBacklight
|
|
clevoKeyboardSignalDep
|
|
ckCmd
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- bar feature constructors
|
|
|
|
xmobarDBus
|
|
:: SafeClient c
|
|
=> T.Text
|
|
-> XPQuery
|
|
-> DBusDependency_ c
|
|
-> (Fontifier -> CmdSpec)
|
|
-> Maybe (NamedConnection c)
|
|
-> BarFeature
|
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
|
where
|
|
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
|
|
|
iconIO_
|
|
:: T.Text
|
|
-> XPQuery
|
|
-> (Fontifier -> IOTree_ -> Root CmdSpec)
|
|
-> IOTree_
|
|
-> BarFeature
|
|
iconIO_ = iconSometimes' And_ Only_
|
|
|
|
-- iconDBus
|
|
-- :: T.Text
|
|
-- -> XPQuery
|
|
-- -> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
|
-- -> DBusTree c p
|
|
-- -> BarFeature
|
|
-- iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
|
|
|
iconDBus_
|
|
:: T.Text
|
|
-> XPQuery
|
|
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
|
-> DBusTree_ c
|
|
-> BarFeature
|
|
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- command specifications
|
|
|
|
data BarRegions = BarRegions
|
|
{ brLeft :: [CmdSpec]
|
|
, brCenter :: [CmdSpec]
|
|
, brRight :: [CmdSpec]
|
|
}
|
|
deriving (Show)
|
|
|
|
data CmdSpec = CmdSpec
|
|
{ csAlias :: T.Text
|
|
, csRunnable :: Runnable
|
|
}
|
|
deriving (Show)
|
|
|
|
concatRegions :: BarRegions -> [CmdSpec]
|
|
concatRegions (BarRegions l c r) = l ++ c ++ r
|
|
|
|
wirelessCmd :: T.Text -> CmdSpec
|
|
wirelessCmd iface =
|
|
CmdSpec
|
|
{ csAlias = T.append iface "wi"
|
|
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
|
}
|
|
where
|
|
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 =
|
|
CmdSpec
|
|
{ csAlias = connAlias contypes
|
|
, csRunnable =
|
|
Run $
|
|
ActiveConnection (contypes, fontify IconMedium icon abbr, colors)
|
|
}
|
|
|
|
batteryCmd :: Fontifier -> CmdSpec
|
|
batteryCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = "battery"
|
|
, csRunnable = Run $ Battery args 50
|
|
}
|
|
where
|
|
fontify' = fontify IconSmall
|
|
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
|
|
btCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = btAlias
|
|
, csRunnable =
|
|
Run $
|
|
Bluetooth (fontify' "\x0f00b1" "+", fontify' "\x0f00af" "-") colors
|
|
}
|
|
where
|
|
fontify' i = fontify IconLarge i . T.append "BT"
|
|
|
|
alsaCmd :: Fontifier -> CmdSpec
|
|
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
|
|
blCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = blAlias
|
|
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
|
|
}
|
|
|
|
ckCmd :: Fontifier -> CmdSpec
|
|
ckCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = ckAlias
|
|
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf11c" "KB: "
|
|
}
|
|
|
|
ssCmd :: Fontifier -> CmdSpec
|
|
ssCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = ssAlias
|
|
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
|
|
}
|
|
|
|
lockCmd :: Fontifier -> CmdSpec
|
|
lockCmd fontify =
|
|
CmdSpec
|
|
{ csAlias = "locks"
|
|
, csRunnable =
|
|
Run $
|
|
Locks $
|
|
fmap
|
|
T.unpack
|
|
[ "-N"
|
|
, numIcon
|
|
, "-n"
|
|
, disabledColor numIcon
|
|
, "-C"
|
|
, capIcon
|
|
, "-c"
|
|
, disabledColor capIcon
|
|
, "-s"
|
|
, ""
|
|
, "-S"
|
|
, ""
|
|
, "-d"
|
|
, " "
|
|
]
|
|
}
|
|
where
|
|
numIcon = fontify' "\x0f03a6" "N"
|
|
capIcon = fontify' "\x0f0bf1" "C"
|
|
fontify' = fontify IconXLarge
|
|
disabledColor = xmobarFGColor XT.backdropFgColor
|
|
|
|
dateCmd :: CmdSpec
|
|
dateCmd =
|
|
CmdSpec
|
|
{ csAlias = "date"
|
|
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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.
|
|
|
|
getTextFont :: XIO T.Text
|
|
getTextFont = do
|
|
fb <- evalAlways textFont
|
|
return $ fb textFontData
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- icon fonts
|
|
|
|
getIconFonts :: XIO ([T.Text], [Int])
|
|
getIconFonts = do
|
|
fb <- evalSometimes iconFont
|
|
return $ maybe ([], []) apply fb
|
|
where
|
|
apply fb =
|
|
unzip $
|
|
(\i -> (iconString fb i, iconOffset i + textFontOffset))
|
|
<$> iconFonts
|
|
|
|
data BarFont
|
|
= IconSmall
|
|
| IconMedium
|
|
| IconLarge
|
|
| IconXLarge
|
|
deriving (Eq, Enum, Bounded, Show)
|
|
|
|
iconFonts :: [BarFont]
|
|
iconFonts = enumFrom minBound
|
|
|
|
iconString :: XT.FontBuilder -> BarFont -> T.Text
|
|
iconString fb i = fb $ iconFontData $ iconSize i
|
|
|
|
iconDependency :: IODependency_
|
|
iconDependency = IOSometimes_ iconFont
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- various formatting things
|
|
|
|
colors :: Colors
|
|
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
|
|
|
|
sep :: T.Text
|
|
sep = xmobarFGColor XT.backdropFgColor " : "
|
|
|
|
lSep :: Char
|
|
lSep = '}'
|
|
|
|
rSep :: Char
|
|
rSep = '{'
|
|
|
|
pSep :: T.Text
|
|
pSep = "%"
|
|
|
|
fmtSpecs :: [CmdSpec] -> T.Text
|
|
fmtSpecs = T.intercalate sep . fmap go
|
|
where
|
|
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
|
|
|
|
fmtRegions :: BarRegions -> T.Text
|
|
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
|
|
T.concat
|
|
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|