xmonad-config/bin/xmobar.hs

475 lines
14 KiB
Haskell
Raw Normal View History

2020-04-01 20:17:47 -04:00
module Main (main) where
--------------------------------------------------------------------------------
-- | 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
2020-04-01 20:17:47 -04:00
import Data.List
import Data.Maybe
2020-04-01 20:17:47 -04:00
import DBus.Client
import System.Exit
2021-06-23 23:08:50 -04:00
import System.IO
import System.IO.Error
2020-03-25 18:55:52 -04:00
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
2020-05-28 23:17:17 -04:00
import Xmobar.Plugins.Device
2020-03-25 18:55:52 -04:00
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
2020-03-15 15:10:25 -04:00
2022-07-02 18:22:26 -04:00
import System.Posix.Signals
2022-03-05 18:18:16 -05:00
import XMonad.Core
( cfgDir
, getDirectories
, io
2022-03-05 18:18:16 -05:00
)
2021-11-27 17:33:02 -05:00
import XMonad.Hooks.DynamicLog (wrap)
import XMonad.Internal.Command.Power (hasBattery)
2021-11-21 17:54:00 -05:00
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
2021-11-08 00:27:39 -05:00
import XMonad.Internal.Dependency
2022-07-02 18:22:26 -04:00
import XMonad.Internal.Process
( proc'
, readCreateProcessWithExitCode'
)
import qualified XMonad.Internal.Theme as T
import Xmobar hiding
( iconOffset
)
2021-11-27 17:33:02 -05:00
import Xmobar.Plugins.Common
2020-03-15 13:12:01 -04:00
2021-06-23 23:08:50 -04:00
main :: IO ()
main = do
db <- connectDBus
c <- withCache $ evalConfig db
disconnectDBus db
2022-07-02 18:22:26 -04:00
-- this is needed to prevent waitForProcess error when forking in plugins (eg
-- alsacmd)
_ <- installHandler sigCHLD Default Nothing
-- this is needed to see any printed messages
hFlush stdout
xmobar c
evalConfig :: DBusState -> FIO Config
evalConfig db = do
cs <- getAllCommands <$> rightPlugins db
bf <- getTextFont
(ifs, ios) <- getIconFonts
d <- io $ cfgDir <$> getDirectories
return $ config bf ifs ios cs d
--------------------------------------------------------------------------------
-- | toplevel configuration
-- | The text font family
textFont :: Always T.FontBuilder
textFont = fontAlways "XMobar Text Font" "DejaVu Sans Mono"
-- | Offset of the text in the bar
textFontOffset :: Int
textFontOffset = 16
-- | Attributes for the bar font (size, weight, etc)
textFontData :: T.FontData
textFontData = T.defFontData { T.weight = Just T.Bold, T.size = Just 11 }
-- | The icon font family
iconFont :: Sometimes T.FontBuilder
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
-- | 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 -> T.FontData
iconFontData s = T.defFontData { T.pixelsize = Just s, T.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 :: String -> [String] -> [Int] -> BarRegions -> FilePath -> Config
config bf ifs ios br confDir = defaultConfig
{ font = bf
, additionalFonts = ifs
, textOffset = textFontOffset
, textOffsets = ios
2021-06-23 23:08:50 -04:00
, bgColor = T.bgColor
, fgColor = T.fgColor
, position = BottomSize C 100 24
, border = NoBorder
, borderColor = T.bordersColor
2021-06-23 23:08:50 -04:00
, sepChar = pSep
, alignSep = [lSep, rSep]
, template = fmtRegions br
2021-06-23 23:08:50 -04:00
, lowerOnStart = False
, hideOnStart = False
, allDesktops = True
, overrideRedirect = True
, pickBroadest = False
, persistent = True
-- store the icons with the xmonad/xmobar stack project
, iconRoot = confDir ++ "/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 -> FIO [Maybe CmdSpec]
rightPlugins DBusState { dbSesClient = ses, dbSysClient = sys }
= mapM evalFeature
[ 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
, always' "date indicator" dateCmd
]
where
always' n = Right . Always n . Always_ . FallbackAlone
type BarFeature = Sometimes CmdSpec
2022-07-07 01:05:17 -04:00
-- TODO what if I don't have a wireless card?
getWireless :: BarFeature
getWireless = sometimes1 "wireless status indicator" "sysfs path"
$ IORoot wirelessCmd $ Only readWireless
getEthernet :: Maybe Client -> BarFeature
getEthernet cl = iconDBus "ethernet status indicator" root tree
where
root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
tree = And1 (Only readEthernet) (Only_ devDep)
getBattery :: BarFeature
getBattery = iconIO_ "battery level indicator" root tree
where
root useIcon = IORoot_ (batteryCmd useIcon)
2022-07-07 01:05:17 -04:00
tree = Only_ $ IOTest_ "Test if battery is present" $ fmap (Msg Error) <$> hasBattery
getVPN :: Maybe Client -> BarFeature
getVPN cl = iconDBus_ "VPN status indicator" root $ toAnd_ vpnDep test
where
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present" vpnPresent
getBt :: Maybe Client -> BarFeature
getBt = xmobarDBus "bluetooth status indicator" btDep btCmd
getAlsa :: BarFeature
getAlsa = iconIO_ "volume level indicator" root $ Only_ $ sysExe "alsactl"
where
root useIcon = IORoot_ (alsaCmd useIcon)
getBl :: Maybe Client -> BarFeature
getBl = xmobarDBus "Intel backlight indicator" intelBacklightSignalDep blCmd
getCk :: Maybe Client -> BarFeature
getCk = xmobarDBus "Clevo keyboard indicator" clevoKeyboardSignalDep ckCmd
getSs :: Maybe Client -> BarFeature
getSs = xmobarDBus "screensaver indicator" 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 :: String -> DBusDependency_ -> (Fontifier -> CmdSpec)
-> Maybe Client -> BarFeature
xmobarDBus n dep cmd cl = iconDBus_ n root (Only_ dep)
where
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
iconIO_ :: String -> (Fontifier -> IOTree_ -> Root CmdSpec) -> IOTree_
-> BarFeature
iconIO_ = iconSometimes' And_ Only_
iconDBus :: String -> (Fontifier -> DBusTree p -> Root CmdSpec)
-> DBusTree p -> BarFeature
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
iconDBus_ :: String -> (Fontifier -> DBusTree_ -> Root CmdSpec) -> DBusTree_
-> BarFeature
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
iconSometimes' c d n r t = Sometimes n
[ Subfeature icon "icon indicator" Error
, Subfeature text "text indicator" Error
]
where
icon = r fontifyIcon $ c t $ d iconDependency
text = r fontifyAlt t
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
-- | command specifications
data BarRegions = BarRegions
{ brLeft :: [CmdSpec]
, brCenter :: [CmdSpec]
, brRight :: [CmdSpec]
} deriving Show
data CmdSpec = CmdSpec
{ csAlias :: String
, csRunnable :: Runnable
} deriving Show
concatRegions :: BarRegions -> [CmdSpec]
concatRegions (BarRegions l c r) = l ++ c ++ r
wirelessCmd :: String -> CmdSpec
wirelessCmd iface = CmdSpec
{ csAlias = iface ++ "wi"
, csRunnable = Run
$ Wireless iface
[ "-t", "<qualityipat><essid>"
, "--"
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
] 5
}
ethernetCmd :: Fontifier -> String -> CmdSpec
ethernetCmd fontify iface = CmdSpec
{ csAlias = iface
, csRunnable = Run
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
}
batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = CmdSpec
{ csAlias = "battery"
, csRunnable = Run
$ Battery
[ "--template", "<acstatus><left>"
, "--Low", "10"
, "--High", "80"
, "--low", "red"
, "--normal", T.fgColor
, "--high", T.fgColor
, "--"
, "-P"
, "-o" , fontify' "\xf0e7" "BAT"
, "-O" , fontify' "\xf1e6" "AC"
, "-i" , fontify' "\xf1e6" "AC"
] 50
}
2021-06-30 23:04:00 -04:00
where
fontify' = fontify IconSmall
vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec
{ csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
}
btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec
2021-06-23 23:08:50 -04:00
{ csAlias = btAlias
, csRunnable = Run
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
2021-06-23 23:08:50 -04:00
}
2021-11-27 17:33:02 -05:00
where
2022-07-06 19:10:28 -04:00
fontify' i = fontify IconLarge i . ("BT" ++)
alsaCmd :: Fontifier -> CmdSpec
alsaCmd fontify = CmdSpec
2021-06-23 23:08:50 -04:00
{ csAlias = "alsa:default:Master"
, csRunnable = Run
$ Alsa "default" "Master"
[ "-t", "<status><volume>%"
, "--"
, "-O", fontify' "\xf028" "+"
, "-o", fontify' "\xf026" "-" ++ " "
2021-06-23 23:08:50 -04:00
, "-c", T.fgColor
, "-C", T.fgColor
]
}
where
2022-07-06 19:10:28 -04:00
fontify' i = fontify IconSmall i . ("VOL" ++)
blCmd :: Fontifier -> CmdSpec
blCmd fontify = CmdSpec
2021-11-21 00:42:40 -05:00
{ csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
2021-06-23 23:08:50 -04:00
}
ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec
{ csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
}
ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec
2021-06-23 23:08:50 -04:00
{ csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
2021-06-23 23:08:50 -04:00
}
lockCmd :: Fontifier -> CmdSpec
lockCmd fontify = CmdSpec
2021-06-23 23:08:50 -04:00
{ csAlias = "locks"
, csRunnable = Run
$ Locks
2021-11-27 17:33:02 -05:00
[ "-N", numIcon
, "-n", disabledColor numIcon
, "-C", capIcon
, "-c", disabledColor capIcon
2021-06-23 23:08:50 -04:00
, "-s", ""
, "-S", ""
2021-06-30 22:47:49 -04:00
, "-d", " "
2021-06-23 23:08:50 -04:00
]
}
2021-11-27 17:33:02 -05:00
where
numIcon = fontify' "\xf8a5" "N"
capIcon = fontify' "\xf657" "C"
fontify' = fontify IconXLarge
2021-11-27 17:33:02 -05:00
disabledColor = xmobarFGColor T.backdropFgColor
2021-06-23 23:08:50 -04:00
dateCmd :: CmdSpec
dateCmd = CmdSpec
{ csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
}
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
-- | low-level testing functions
2022-07-07 01:05:17 -04:00
vpnPresent :: IO (Maybe Msg)
2022-07-02 18:22:26 -04:00
vpnPresent =
go <$> tryIOError (readCreateProcessWithExitCode' (proc' "nmcli" args) "")
where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
2022-07-02 17:09:21 -04:00
go (Right (ExitSuccess, out, _)) = if "vpn" `elem` lines out then Nothing
2022-07-07 01:05:17 -04:00
else Just $ Msg Error "vpn not found"
go (Right (ExitFailure c, _, err)) = Just $ Msg Error
$ "vpn search exited with code "
2022-07-02 17:09:21 -04:00
++ show c ++ ": " ++ err
2022-07-07 01:05:17 -04:00
go (Left e) = Just $ Msg Error $ show e
--------------------------------------------------------------------------------
-- | 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 :: FIO String
getTextFont = do
fb <- evalAlways textFont
return $ fb textFontData
2021-06-23 23:08:50 -04:00
--------------------------------------------------------------------------------
-- | icon fonts
2021-06-23 23:08:50 -04:00
getIconFonts :: FIO ([String], [Int])
getIconFonts = do
fb <- evalSometimes iconFont
return $ maybe ([], []) apply fb
2021-11-21 23:55:19 -05:00
where
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts
2021-06-23 23:08:50 -04: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 :: T.FontBuilder -> BarFont -> String
iconString fb i = fb $ iconFontData $ iconSize i
iconDependency :: IODependency_
iconDependency = IOSometimes_ iconFont
2022-07-02 17:09:21 -04:00
fontifyText :: BarFont -> String -> String
fontifyText fnt txt = concat ["<fn=", show $ 1 + fromEnum fnt, ">", txt, "</fn>"]
type Fontifier = BarFont -> String -> String -> String
fontifyAlt :: Fontifier
fontifyAlt _ _ alt = alt
fontifyIcon :: Fontifier
fontifyIcon f i _ = fontifyText f i
2021-11-27 17:33:02 -05:00
--------------------------------------------------------------------------------
-- | various formatting things
colors :: Colors
colors = Colors { colorsOn = T.fgColor, colorsOff = T.backdropFgColor }
sep :: String
sep = xmobarFGColor T.backdropFgColor " : "
lSep :: Char
lSep = '}'
rSep :: Char
rSep = '{'
2020-03-22 17:17:57 -04:00
2021-11-27 17:33:02 -05:00
pSep :: String
pSep = "%"
fmtSpecs :: [CmdSpec] -> String
fmtSpecs = intercalate sep . fmap go
where
go CmdSpec { csAlias = a } = wrap pSep pSep a
fmtRegions :: BarRegions -> String
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } =
fmtSpecs l ++ [lSep] ++ fmtSpecs c ++ [rSep] ++ fmtSpecs r