2017-10-29 19:04:57 -07:00
|
|
|
{-# LANGUAGE PackageImports #-}
|
2017-08-23 12:43:25 -07:00
|
|
|
module Main where
|
|
|
|
|
2017-11-16 20:00:33 -08:00
|
|
|
import qualified Control.Concurrent.MVar as MV
|
|
|
|
import Control.Exception.Base
|
|
|
|
import Control.Monad
|
|
|
|
import Control.Monad.Reader
|
2018-03-23 21:24:38 -07:00
|
|
|
import Data.GI.Base
|
|
|
|
import Data.GI.Base.ManagedPtr
|
2017-11-16 20:00:33 -08:00
|
|
|
import Data.List
|
|
|
|
import Data.List.Split
|
|
|
|
import qualified Data.Map as M
|
|
|
|
import Data.Maybe
|
2018-04-18 00:46:41 -07:00
|
|
|
import Debug.Trace
|
2018-03-23 21:24:38 -07:00
|
|
|
import Foreign.ForeignPtr
|
|
|
|
import Foreign.Ptr
|
2018-04-07 12:19:11 -07:00
|
|
|
import qualified GI.Gtk as GI
|
2017-10-29 19:04:57 -07:00
|
|
|
import qualified "gtk3" Graphics.UI.Gtk as Gtk
|
|
|
|
import qualified "gtk3" Graphics.UI.Gtk.Abstract.Widget as W
|
|
|
|
import qualified "gtk3" Graphics.UI.Gtk.Layout.Table as T
|
2018-03-23 21:24:38 -07:00
|
|
|
import Graphics.UI.Gtk.Types
|
|
|
|
import StatusNotifier.Tray
|
2017-11-16 20:00:33 -08:00
|
|
|
import System.Directory
|
|
|
|
import System.Environment
|
|
|
|
import System.FilePath.Posix
|
2018-03-23 21:24:38 -07:00
|
|
|
import System.Glib.GObject
|
2018-04-18 00:46:41 -07:00
|
|
|
import System.IO
|
2017-11-16 20:00:33 -08:00
|
|
|
import System.Information.CPU
|
|
|
|
import System.Information.EWMHDesktopInfo
|
|
|
|
import System.Information.Memory
|
|
|
|
import System.Information.X11DesktopInfo
|
2018-04-18 00:46:41 -07:00
|
|
|
import System.Log.Handler.Simple
|
|
|
|
import System.Log.Logger
|
2017-11-16 20:00:33 -08:00
|
|
|
import System.Process
|
|
|
|
import System.Taffybar
|
|
|
|
import System.Taffybar.Battery
|
|
|
|
import System.Taffybar.IconImages
|
|
|
|
import System.Taffybar.LayoutSwitcher
|
|
|
|
import System.Taffybar.MPRIS2
|
|
|
|
import System.Taffybar.NetMonitor
|
|
|
|
import System.Taffybar.SimpleClock
|
2018-04-18 00:46:41 -07:00
|
|
|
import System.Taffybar.SimpleConfig
|
2017-11-16 20:00:33 -08:00
|
|
|
import System.Taffybar.Systray
|
|
|
|
import System.Taffybar.ToggleMonitor
|
|
|
|
import System.Taffybar.Widgets.PollingGraph
|
|
|
|
import System.Taffybar.WindowSwitcher
|
|
|
|
import System.Taffybar.WorkspaceHUD
|
|
|
|
import Text.Printf
|
2018-03-23 21:24:38 -07:00
|
|
|
import Text.Read hiding (lift)
|
|
|
|
import Unsafe.Coerce
|
2017-03-13 13:58:38 -07:00
|
|
|
|
2017-09-12 01:58:47 -07:00
|
|
|
data ConstantIconController = ConstantIconController { cicImage :: Gtk.Image }
|
|
|
|
|
|
|
|
instance WorkspaceWidgetController ConstantIconController where
|
|
|
|
updateWidget cic _ = return cic
|
|
|
|
getWidget = Gtk.toWidget . cicImage
|
2016-09-16 14:11:52 -07:00
|
|
|
|
2017-10-26 17:59:57 -07:00
|
|
|
instance WorkspaceWidgetController Gtk.Widget where
|
|
|
|
updateWidget w _ = return w
|
|
|
|
getWidget w = w
|
|
|
|
|
|
|
|
makeContents waction klass = do
|
|
|
|
widget <- waction
|
|
|
|
widgetSetClass widget "Contents"
|
|
|
|
widgetSetClass widget klass
|
|
|
|
b <- buildPadBox widget
|
|
|
|
Gtk.widgetShowAll b
|
|
|
|
return $ Gtk.toWidget b
|
|
|
|
|
2017-10-26 00:32:31 -07:00
|
|
|
myGraphConfig =
|
2017-05-24 21:56:34 -07:00
|
|
|
defaultGraphConfig
|
2017-10-26 17:59:57 -07:00
|
|
|
{ graphPadding = 0
|
2017-10-26 00:32:31 -07:00
|
|
|
, graphBorderWidth = 0
|
|
|
|
, graphWidth = 75
|
|
|
|
}
|
|
|
|
|
|
|
|
memCfg =
|
|
|
|
myGraphConfig
|
2017-05-24 21:56:34 -07:00
|
|
|
{graphDataColors = [(0.129, 0.588, 0.953, 1)], graphLabel = Just "mem"}
|
|
|
|
|
2017-10-26 17:59:57 -07:00
|
|
|
memCallback :: IO [Double]
|
|
|
|
memCallback = do
|
2016-09-16 14:11:52 -07:00
|
|
|
mi <- parseMeminfo
|
|
|
|
return [memoryUsedRatio mi]
|
|
|
|
|
2017-09-10 13:16:58 -07:00
|
|
|
getFullWorkspaceNames :: X11Property [(WorkspaceIdx, String)]
|
|
|
|
getFullWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_FULL_NAMES"
|
|
|
|
where go = zip [WSIdx i | i <- [0..]]
|
|
|
|
|
2018-03-23 21:24:38 -07:00
|
|
|
workspaceNamesLabelSetter workspace =
|
|
|
|
fromMaybe "" . lookup (workspaceIdx workspace) <$>
|
|
|
|
liftX11Def [] getFullWorkspaceNames
|
2017-09-10 13:16:58 -07:00
|
|
|
|
2017-10-26 17:59:57 -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
|
2017-05-24 21:56:34 -07:00
|
|
|
|
|
|
|
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
|
2016-09-19 12:08:59 -07:00
|
|
|
(_, systemLoad, totalLoad) <- cpuLoad
|
2016-09-16 14:11:52 -07:00
|
|
|
return [totalLoad, systemLoad]
|
|
|
|
|
2017-10-26 17:59:57 -07:00
|
|
|
containerAddReturn c w =
|
|
|
|
Gtk.containerAdd c w >> Gtk.widgetShowAll c >> (return $ Gtk.toWidget c)
|
|
|
|
|
2017-03-04 13:13:03 -08:00
|
|
|
underlineWidget cfg buildWidget name = do
|
2017-03-04 03:59:38 -08:00
|
|
|
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
|
2017-03-04 03:59:38 -08:00
|
|
|
|
|
|
|
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)
|
2017-03-04 03:59:38 -08:00
|
|
|
|
|
|
|
Gtk.widgetShowAll t
|
|
|
|
|
|
|
|
return $ Gtk.toWidget t
|
|
|
|
|
2017-07-29 00:34:23 -07:00
|
|
|
myFormatEntry wsNames ((ws, wtitle, wclass), _) =
|
2017-08-28 23:06:41 -07:00
|
|
|
printf "%s: %s - %s" wsName (head $ splitOn "\NUL" wclass) wtitle
|
2017-07-29 00:34:23 -07:00
|
|
|
where
|
|
|
|
wsName = M.findWithDefault ("WS#" ++ show wsN) ws wsNames
|
|
|
|
WSIdx wsN = ws
|
|
|
|
|
2017-03-30 11:36:27 -07:00
|
|
|
getInterfaces = do
|
|
|
|
(_, output, _) <- readCreateProcessWithExitCode (shell "list_interfaces.sh") ""
|
|
|
|
return $ splitOn "\n" output
|
|
|
|
|
2018-03-23 21:24:38 -07:00
|
|
|
addClass klass action = do
|
|
|
|
widget <- action
|
2018-04-18 00:46:41 -07:00
|
|
|
lift $ widgetSetClass widget klass
|
2018-03-23 21:24:38 -07:00
|
|
|
return widget
|
|
|
|
|
|
|
|
(buildWidgetCons, _) = mkWidget
|
|
|
|
|
|
|
|
buildSNITray = do
|
2018-04-18 00:46:41 -07:00
|
|
|
-- XXX: this won't work for multiple taffybars because it will attempt to
|
|
|
|
-- register a second host with a name that already exists on the dbus tray.
|
|
|
|
-- Need to take an approach similar to that of gtk-sni-tray to get that to
|
|
|
|
-- work.
|
2018-04-07 12:19:11 -07:00
|
|
|
GI.Widget trayGIWidgetMP <- buildTrayWithHost GI.OrientationHorizontal
|
2018-03-23 21:24:38 -07:00
|
|
|
wrapNewGObject mkWidget (castPtr <$> disownManagedPtr trayGIWidgetMP)
|
|
|
|
|
2018-04-18 00:46:41 -07:00
|
|
|
logDebug = do
|
|
|
|
handler <- streamHandler stdout DEBUG
|
|
|
|
logger <- getLogger "System.Taffybar"
|
|
|
|
saveGlobalLogger $ setLevel DEBUG logger
|
|
|
|
|
2016-09-16 14:11:52 -07:00
|
|
|
main = do
|
2017-03-30 11:36:27 -07:00
|
|
|
interfaceNames <- getInterfaces
|
2017-03-05 18:30:55 -08:00
|
|
|
homeDirectory <- getHomeDirectory
|
2018-04-18 00:46:41 -07:00
|
|
|
logDebug
|
2017-05-30 18:23:13 -07:00
|
|
|
let resourcesDirectory = homeDirectory </> ".lib" </> "resources"
|
|
|
|
inResourcesDirectory file = resourcesDirectory </> file
|
2017-10-13 22:09:08 -07:00
|
|
|
highContrastDirectory =
|
|
|
|
"/" </> "usr" </> "share" </> "icons" </> "HighContrast" </> "256x256"
|
|
|
|
inHighContrastDirectory file = highContrastDirectory </> file
|
|
|
|
getWorkspacePixBuf size Workspace {workspaceIdx = WSIdx wsId} =
|
2017-09-12 02:55:32 -07:00
|
|
|
pixBufFromFile size . inHighContrastDirectory <$>
|
2017-10-13 22:09:08 -07:00
|
|
|
case wsId + 1 of
|
2017-10-24 21:03:33 -07:00
|
|
|
-- 1 -> Just $ "apps" </> "utilities-terminal.png"
|
|
|
|
-- 2 -> Just $ "emblems" </> "emblem-documents.png"
|
|
|
|
-- 3 -> Just $ "actions" </> "bookmark-add.png"
|
|
|
|
-- 4 -> Just $ "devices" </> "video-display.png"
|
2017-10-13 22:09:08 -07:00
|
|
|
_ -> Nothing
|
2017-09-12 01:58:47 -07:00
|
|
|
buildConstantIconController :: ControllerConstructor
|
|
|
|
buildConstantIconController ws = do
|
2017-10-13 22:09:08 -07:00
|
|
|
cfg <- asks hudConfig
|
|
|
|
lift $ do
|
|
|
|
img <- Gtk.imageNew
|
|
|
|
pb <- sequence $ getWorkspacePixBuf (windowIconSize cfg) ws
|
|
|
|
setImage (windowIconSize cfg) img pb
|
|
|
|
return $ WWC ConstantIconController {cicImage = img}
|
2017-09-10 18:20:04 -07:00
|
|
|
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"
|
2017-09-10 18:20:04 -07:00
|
|
|
| "Termite" `isInfixOf` klass = makeIcon "urxvt.png"
|
2017-05-30 18:23:13 -07:00
|
|
|
| "Kodi" `isInfixOf` klass = makeIcon "kodi.png"
|
|
|
|
| "@gmail.com" `isInfixOf` title &&
|
2017-09-10 18:20:04 -07:00
|
|
|
"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-03-01 19:21:58 -08:00
|
|
|
cpuCfg =
|
2017-10-26 00:32:31 -07:00
|
|
|
myGraphConfig
|
2017-03-01 19:21:58 -08:00
|
|
|
{ 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-10-26 17:59:57 -07:00
|
|
|
mem = pollingGraphNew memCfg 1 memCallback
|
2017-09-12 01:58:47 -07:00
|
|
|
myHUDConfig =
|
2017-03-01 19:21:58 -08:00
|
|
|
defaultWorkspaceHUDConfig
|
|
|
|
{ underlineHeight = 3
|
2017-07-27 19:59:23 -07:00
|
|
|
, underlinePadding = 2
|
2017-03-01 19:21:58 -08:00
|
|
|
, minWSWidgetSize = Nothing
|
2017-10-24 11:38:37 -07:00
|
|
|
, minIcons = 1
|
2017-03-01 19:21:58 -08:00
|
|
|
, getIconInfo = myGetIconInfo
|
2017-10-26 17:59:57 -07:00
|
|
|
, windowIconSize = 30
|
2017-03-01 19:21:58 -08:00
|
|
|
, widgetGap = 0
|
2017-10-26 00:32:31 -07:00
|
|
|
-- , widgetBuilder =
|
|
|
|
-- buildButtonController $
|
|
|
|
-- buildUnderlineController $
|
|
|
|
-- buildContentsController
|
|
|
|
-- [ buildConstantIconController
|
|
|
|
-- , buildLabelController
|
|
|
|
-- , buildIconController
|
|
|
|
-- ]
|
2017-03-01 19:21:58 -08:00
|
|
|
, showWorkspaceFn = hideEmpty
|
|
|
|
, updateRateLimitMicroseconds = 100000
|
2017-10-29 19:04:57 -07:00
|
|
|
, debugMode = False
|
2017-09-10 13:16:58 -07:00
|
|
|
, labelSetter = workspaceNamesLabelSetter
|
2017-03-01 19:21:58 -08:00
|
|
|
}
|
2017-03-30 11:36:27 -07:00
|
|
|
netMonitor = netMonitorMultiNew 1.5 interfaceNames
|
2017-10-26 00:32:31 -07:00
|
|
|
-- makeUnderline = underlineWidget myHUDConfig
|
2018-04-18 00:46:41 -07:00
|
|
|
-- pgr <- pagerNew pagerConfig
|
2017-10-13 22:09:08 -07:00
|
|
|
-- tray2 <- movableWidget tray
|
2018-04-18 00:46:41 -07:00
|
|
|
let hud = buildWorkspaceHUD myHUDConfig
|
|
|
|
los = layoutSwitcherNew defaultLayoutSwitcherConfig
|
|
|
|
wnd = windowSwitcherNew defaultWindowSwitcherConfig
|
|
|
|
simpleTaffyConfig =
|
|
|
|
defaultSimpleTaffyConfig
|
2018-03-23 21:24:38 -07:00
|
|
|
{ startWidgets = [hud, los, addClass "WindowSwitcher" wnd]
|
2018-04-18 00:46:41 -07:00
|
|
|
, centerWidgets = []
|
|
|
|
, endWidgets = map lift
|
2017-10-24 21:03:33 -07:00
|
|
|
[ batteryBarNew defaultBatteryConfig 1.0
|
2017-10-26 17:59:57 -07:00
|
|
|
, makeContents clock "Cpu"
|
2018-03-23 21:24:38 -07:00
|
|
|
-- , makeContents systrayNew "Cpu"
|
2018-03-23 21:32:04 -07:00
|
|
|
, makeContents buildSNITray "Cpu"
|
2017-10-26 17:59:57 -07:00
|
|
|
, makeContents cpu "Cpu"
|
|
|
|
, makeContents mem "Cpu"
|
|
|
|
, makeContents netMonitor "Cpu"
|
|
|
|
, makeContents (join $ containerAddReturn <$> Gtk.eventBoxNew <*> mpris) "Cpu"
|
2017-03-12 21:25:59 -07:00
|
|
|
]
|
|
|
|
, barPosition = Top
|
2018-03-23 21:24:38 -07:00
|
|
|
, barPadding = 5
|
2018-04-07 12:19:11 -07:00
|
|
|
, barHeight = (underlineHeight myHUDConfig + windowIconSize myHUDConfig + 15)
|
2017-10-26 17:59:57 -07:00
|
|
|
, widgetSpacing = 0
|
2017-03-12 21:25:59 -07:00
|
|
|
}
|
2018-04-18 00:46:41 -07:00
|
|
|
dyreTaffybar $ handleDBusToggles $ toTaffyConfig simpleTaffyConfig
|
2016-09-16 14:11:52 -07:00
|
|
|
|
|
|
|
-- Local Variables:
|
|
|
|
-- flycheck-ghc-args: ("-Wno-missing-signatures")
|
|
|
|
-- End:
|