218 lines
7.2 KiB
Haskell
Raw Normal View History

2017-08-23 12:43:25 -07:00
module Main where
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 Data.List.Split
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.EWMHDesktopInfo
import System.Information.Memory
import System.Information.X11DesktopInfo
import System.Process
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
2017-05-24 21:56:34 -07:00
import System.Taffybar.ToggleMonitor
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)
2016-09-16 14:11:52 -07:00
2017-05-24 21:56:34 -07:00
memCfg =
defaultGraphConfig
{graphDataColors = [(0.129, 0.588, 0.953, 1)], graphLabel = Just "mem"}
memCallback :: Gtk.Widget -> IO [Double]
memCallback widget = do
2016-09-16 14:11:52 -07:00
mi <- parseMeminfo
2017-05-24 21:56:34 -07:00
let tooltip = printf "%s/%s" (show $ memoryUsed mi) (show $ memoryTotal mi) :: String
Gtk.postGUIAsync $ do
_ <- Gtk.widgetSetTooltipText widget (Just tooltip)
return ()
2016-09-16 14:11:52 -07:00
return [memoryUsedRatio mi]
getFullWorkspaceNames :: X11Property [(WorkspaceIdx, String)]
getFullWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_FULL_NAMES"
where go = zip [WSIdx i | i <- [0..]]
workspaceNamesLabelSetter workspace = do
fullNames <- liftX11 getFullWorkspaceNames
return $ fromMaybe "" $ lookup (workspaceIdx workspace) fullNames
2017-05-24 21:56:34 -07:00
mem :: IO Gtk.Widget
mem = do
ebox <- Gtk.eventBoxNew
btn <- pollingGraphNew memCfg 1 $ memCallback $ Gtk.toWidget ebox
Gtk.containerAdd ebox btn
_ <- Gtk.on ebox Gtk.buttonPressEvent systemEvents
Gtk.widgetShowAll ebox
return $ Gtk.toWidget ebox
systemEvents :: Gtk.EventM Gtk.EButton Bool
2017-07-27 19:59:23 -07:00
systemEvents = return True
2017-05-24 21:56:34 -07:00
2016-09-16 14:11:52 -07:00
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
2017-04-08 02:50:49 -07:00
Gtk.widgetShowAll hbox
return $ Gtk.toWidget hbox
return moveWidget
myFormatEntry wsNames ((ws, wtitle, wclass), _) =
printf "%s: %s - %s" wsName (head $ splitOn "\NUL" wclass) wtitle
where
wsName = M.findWithDefault ("WS#" ++ show wsN) ws wsNames
WSIdx wsN = ws
getInterfaces = do
(_, output, _) <- readCreateProcessWithExitCode (shell "list_interfaces.sh") ""
return $ splitOn "\n" output
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)
interfaceNames <- getInterfaces
2017-03-05 18:30:55 -08:00
homeDirectory <- getHomeDirectory
2017-05-30 18:23:13 -07:00
let resourcesDirectory = homeDirectory </> ".lib" </> "resources"
inResourcesDirectory file = resourcesDirectory </> file
makeIcon = return . IIFilePath . inResourcesDirectory
myGetIconInfo w@WindowData {windowTitle = title, windowClass = klass}
2017-05-30 18:23:13 -07:00
| "URxvt" `isInfixOf` klass = makeIcon "urxvt.png"
| "Termite" `isInfixOf` klass = makeIcon "urxvt.png"
2017-05-30 18:23:13 -07:00
| "Kodi" `isInfixOf` klass = makeIcon "kodi.png"
| "@gmail.com" `isInfixOf` title &&
"chrome" `isInfixOf` klass && "Gmail" `isInfixOf` title =
makeIcon "gmail.png"
| otherwise = do
res <- defaultGetIconInfo w
return $
case res of
IINone -> IIFilePath $ inResourcesDirectory "exe-icon.png"
_ -> res
2017-07-27 19:59:23 -07:00
(_, 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)
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
cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
2017-03-05 18:30:55 -08:00
tray = do
2017-04-08 02:50:49 -07:00
theTray <- systrayNew
cont <- Gtk.eventBoxNew
Gtk.containerAdd cont theTray
Gtk.widgetSetName cont "Taffytray"
Gtk.widgetSetName theTray "Taffytray"
Gtk.widgetShowAll cont
return $ Gtk.toWidget cont
hudConfig =
defaultWorkspaceHUDConfig
{ underlineHeight = 3
2017-07-27 19:59:23 -07:00
, underlinePadding = 2
, 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
, labelSetter = workspaceNamesLabelSetter
}
netMonitor = netMonitorMultiNew 1.5 interfaceNames
pagerConfig =
defaultPagerConfig
{useImages = True, windowSwitcherFormatter = myFormatEntry}
2017-07-27 19:59:23 -07:00
-- pager = taffyPagerNew pagerConfig
2017-03-05 18:30:55 -08:00
makeUnderline = underlineWidget hudConfig
pgr <- pagerNew pagerConfig
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-04-08 02:50:49 -07:00
withToggleSupport taffyConfig
2016-09-16 14:11:52 -07:00
-- Local Variables:
-- flycheck-ghc-args: ("-Wno-missing-signatures")
-- End: