168 lines
5.5 KiB
Haskell
Raw Normal View History

import qualified Control.Concurrent.MVar as MV
2017-03-04 12:03:10 -08:00
import Control.Exception.Base
2017-03-28 22:16:08 -07:00
import Control.Monad
import Data.List
import qualified Data.Map as M
2017-03-28 22:16:08 -07:00
import Data.Maybe
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.Abstract.Widget as W
import qualified Graphics.UI.Gtk.Layout.Table as T
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.Information.CPU
import System.Information.Memory
import System.Taffybar
2017-03-05 18:30:55 -08:00
import System.Taffybar.LayoutSwitcher
import System.Taffybar.MPRIS2
2017-03-29 18:53:03 -07:00
import System.Taffybar.NetMonitor
import System.Taffybar.Pager
import System.Taffybar.SimpleClock
import System.Taffybar.Systray
import System.Taffybar.TaffyPager
import System.Taffybar.Widgets.PollingGraph
2017-03-05 18:30:55 -08:00
import System.Taffybar.WindowSwitcher
import System.Taffybar.WorkspaceHUD
import Text.Printf
import Text.Read hiding (get)
import ToggleMonitor
2017-03-28 22:16:08 -07:00
import XMonad.Core ( whenJust )
2016-09-16 14:11:52 -07:00
memCallback = do
mi <- parseMeminfo
return [memoryUsedRatio mi]
cpuCallback = do
(_, systemLoad, totalLoad) <- cpuLoad
2016-09-16 14:11:52 -07:00
return [totalLoad, systemLoad]
2017-03-04 13:13:03 -08:00
underlineWidget cfg buildWidget name = do
w <- buildWidget
t <- T.tableNew 2 1 False
u <- Gtk.eventBoxNew
2017-03-04 13:13:03 -08:00
W.widgetSetSizeRequest u (-1) $ underlineHeight cfg
T.tableAttach t w 0 1 0 1 [T.Expand] [T.Expand] 0 0
T.tableAttach t u 0 1 1 2 [T.Fill] [T.Shrink] 0 0
2017-03-05 18:30:55 -08:00
Gtk.widgetSetName u (printf "%s-underline" name :: String)
Gtk.widgetShowAll t
return $ Gtk.toWidget t
movableWidget builder =
do
-- Delay creation of the widget or else failure from trying to get screen
widVar <- MV.newEmptyMVar
let moveWidget = do
isEmpty <- MV.isEmptyMVar widVar
when isEmpty $
do
putwid <- builder
MV.putMVar widVar putwid
wid <- MV.readMVar widVar
hbox <- Gtk.hBoxNew False 0
parent <- Gtk.widgetGetParent wid
if isJust parent
then
Gtk.widgetReparent wid hbox
else
Gtk.containerAdd hbox wid
return $ Gtk.toWidget hbox
return moveWidget
2016-09-16 14:11:52 -07:00
main = do
2017-03-04 13:13:03 -08:00
monEither <-
(try $ getEnv "TAFFYBAR_MONITOR") :: IO (Either SomeException String)
2017-03-05 18:30:55 -08:00
homeDirectory <- getHomeDirectory
let resourcesDirectory file =
homeDirectory </> ".lib" </> "resources" </> file
2017-03-05 18:30:55 -08:00
fallbackIcons _ klass
| "URxvt" `isInfixOf` klass =
IIFilePath $ resourcesDirectory "urxvt.png"
| "Kodi" `isInfixOf` klass = IIFilePath $ resourcesDirectory "kodi.png"
| otherwise = IIColor (0xFF, 0xFF, 0, 0xFF)
myGetIconInfo = windowTitleClassIconGetter False fallbackIcons
(monFilter, monNumber) =
2017-03-04 12:03:10 -08:00
case monEither of
Left _ -> (allMonitors, 0)
2017-03-12 21:25:59 -07:00
Right monString ->
case readMaybe monString of
Nothing -> (allMonitors, 0)
2017-03-28 22:16:08 -07:00
Just num -> (useMonitorNumber, num)
2017-03-05 18:30:55 -08:00
memCfg =
defaultGraphConfig
2017-03-12 21:25:59 -07:00
{graphDataColors = [(0.129, 0.588, 0.953, 1)], graphLabel = Just "mem"}
cpuCfg =
defaultGraphConfig
{ graphDataColors = [(0, 1, 0, 1), (1, 0, 1, 0.5)]
, graphLabel = Just "cpu"
}
2017-03-05 18:30:55 -08:00
clock = textClockNew Nothing "%a %b %_d %r" 1
2016-09-19 12:08:25 -07:00
mpris = mpris2New
2016-09-16 14:11:52 -07:00
mem = pollingGraphNew memCfg 1 memCallback
cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
2017-03-05 18:30:55 -08:00
tray = do
2017-03-12 21:25:59 -07:00
tray <- systrayNew
container <- Gtk.eventBoxNew
Gtk.containerAdd container tray
Gtk.widgetSetName container "Taffytray"
Gtk.widgetSetName tray "Taffytray"
return $ Gtk.toWidget container
hudConfig =
defaultWorkspaceHUDConfig
{ underlineHeight = 3
2017-03-05 18:30:55 -08:00
, underlinePadding = 5
, minWSWidgetSize = Nothing
, minIcons = 3
, getIconInfo = myGetIconInfo
2017-03-05 18:30:55 -08:00
, windowIconSize = 25
, widgetGap = 0
-- , widgetBuilder = buildBorderButtonController
, showWorkspaceFn = hideEmpty
, updateRateLimitMicroseconds = 100000
, updateIconsOnTitleChange = True
, updateOnWMIconChange = True
2017-03-04 14:13:49 -08:00
, debugMode = False
2017-03-04 03:45:10 -08:00
, redrawIconsOnStateChange = True
2017-03-05 18:30:55 -08:00
, innerPadding = 5
, outerPadding = 5
}
2017-03-29 18:53:03 -07:00
netMonitor = netMonitorMultiNew 1.5 ["enp0s31f6"]
2017-03-05 18:30:55 -08:00
pagerConfig = defaultPagerConfig {useImages = True}
pager = taffyPagerNew pagerConfig
2017-03-05 18:30:55 -08:00
makeUnderline = underlineWidget hudConfig
pgr <- pagerNew pagerConfig
enabledVar <- MV.newMVar M.empty
2017-03-28 22:16:08 -07:00
tray2 <- movableWidget tray
2017-03-12 21:25:59 -07:00
let hud = buildWorkspaceHUD hudConfig pgr
2017-03-05 18:30:55 -08:00
los = makeUnderline (layoutSwitcherNew pgr) "red"
wnd = makeUnderline (windowSwitcherNew pgr) "teal"
2017-03-12 21:25:59 -07:00
taffyConfig =
defaultTaffybarConfig
{ startWidgets = [hud, los, wnd]
, endWidgets =
2017-03-29 18:53:03 -07:00
[ makeUnderline tray "yellow"
2017-03-12 21:25:59 -07:00
, makeUnderline clock "teal"
, makeUnderline mem "blue"
, makeUnderline cpu "green"
2017-03-29 18:53:03 -07:00
, makeUnderline netMonitor "yellow"
2017-03-12 21:25:59 -07:00
, makeUnderline mpris "red"
]
, monitorNumber = monNumber
, barPosition = Top
, barHeight = 50
, widgetSpacing = 5
2017-03-28 22:16:08 -07:00
, startRefresher = handleToggleRequests enabledVar
, getMonitorConfig = toggleableMonitors enabledVar
2017-03-12 21:25:59 -07:00
}
defaultTaffybar taffyConfig
2016-09-16 14:11:52 -07:00
-- Local Variables:
-- flycheck-ghc-args: ("-Wno-missing-signatures")
-- End: