260 lines
9.2 KiB
Haskell
Raw Normal View History

{-# LANGUAGE PackageImports #-}
2017-08-23 12:43:25 -07:00
module Main where
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
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import Debug.Trace
2018-03-23 21:24:38 -07:00
import Foreign.ForeignPtr
import Foreign.Ptr
import qualified GI.Gtk as GI
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
import System.Directory
import System.Environment
import System.FilePath.Posix
2018-03-23 21:24:38 -07:00
import System.Glib.GObject
import System.IO
import System.Information.CPU
import System.Information.EWMHDesktopInfo
import System.Information.Memory
import System.Information.X11DesktopInfo
import System.Log.Handler.Simple
import System.Log.Logger
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
import System.Taffybar.SimpleConfig
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-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
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
{ 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"}
memCallback :: IO [Double]
memCallback = do
2016-09-16 14:11:52 -07:00
mi <- parseMeminfo
return [memoryUsedRatio mi]
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
-- 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
(_, systemLoad, totalLoad) <- cpuLoad
2016-09-16 14:11:52 -07:00
return [totalLoad, systemLoad]
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
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
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
2018-03-23 21:24:38 -07:00
addClass klass action = do
widget <- action
lift $ widgetSetClass widget klass
2018-03-23 21:24:38 -07:00
return widget
(buildWidgetCons, _) = mkWidget
buildSNITray = do
-- 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.
GI.Widget trayGIWidgetMP <- buildTrayWithHost GI.OrientationHorizontal
2018-03-23 21:24:38 -07:00
wrapNewGObject mkWidget (castPtr <$> disownManagedPtr trayGIWidgetMP)
logDebug = do
handler <- streamHandler stdout DEBUG
logger <- getLogger "System.Taffybar"
saveGlobalLogger $ setLevel DEBUG logger
2016-09-16 14:11:52 -07:00
main = do
interfaceNames <- getInterfaces
2017-03-05 18:30:55 -08:00
homeDirectory <- getHomeDirectory
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}
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
cpuCfg =
2017-10-26 00:32:31 -07:00
myGraphConfig
{ 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
mem = pollingGraphNew memCfg 1 memCallback
2017-09-12 01:58:47 -07:00
myHUDConfig =
defaultWorkspaceHUDConfig
{ underlineHeight = 3
2017-07-27 19:59:23 -07:00
, underlinePadding = 2
, minWSWidgetSize = Nothing
, minIcons = 1
, getIconInfo = myGetIconInfo
, windowIconSize = 30
, widgetGap = 0
2017-10-26 00:32:31 -07:00
-- , widgetBuilder =
-- buildButtonController $
-- buildUnderlineController $
-- buildContentsController
-- [ buildConstantIconController
-- , buildLabelController
-- , buildIconController
-- ]
, showWorkspaceFn = hideEmpty
, updateRateLimitMicroseconds = 100000
, debugMode = False
, labelSetter = workspaceNamesLabelSetter
}
netMonitor = netMonitorMultiNew 1.5 interfaceNames
2017-10-26 00:32:31 -07:00
-- makeUnderline = underlineWidget myHUDConfig
-- pgr <- pagerNew pagerConfig
2017-10-13 22:09:08 -07:00
-- tray2 <- movableWidget tray
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]
, centerWidgets = []
, endWidgets = map lift
2017-10-24 21:03:33 -07:00
[ batteryBarNew defaultBatteryConfig 1.0
, 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"
, 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
, barHeight = (underlineHeight myHUDConfig + windowIconSize myHUDConfig + 15)
, widgetSpacing = 0
2017-03-12 21:25:59 -07:00
}
dyreTaffybar $ handleDBusToggles $ toTaffyConfig simpleTaffyConfig
2016-09-16 14:11:52 -07:00
-- Local Variables:
-- flycheck-ghc-args: ("-Wno-missing-signatures")
-- End: