189 lines
6.6 KiB
Haskell

{-# LANGUAGE PackageImports #-}
module Main where
import qualified Control.Concurrent.MVar as MV
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import qualified Data.ByteString.Char8 as BS
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
import Foreign.ForeignPtr
import Foreign.Ptr
import qualified GI.Gtk as GI
import qualified GitHub.Auth as Auth
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
import Graphics.UI.Gtk.Types
import StatusNotifier.Tray
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.Glib.GObject
import System.IO
import System.Log.Handler.Simple
import System.Log.Logger
import System.Process
import System.Taffybar
import System.Taffybar.Auth
import System.Taffybar.Compat.GtkLibs
import System.Taffybar.DBus
import System.Taffybar.DBus.Toggle
import System.Taffybar.Hooks
import System.Taffybar.IconImages
import System.Taffybar.Information.CPU
import System.Taffybar.Information.EWMHDesktopInfo
import System.Taffybar.Information.Memory
import System.Taffybar.Information.X11DesktopInfo
import System.Taffybar.SimpleConfig
import System.Taffybar.Widget
import System.Taffybar.Widget.Generic.PollingGraph
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util
import System.Taffybar.Widget.Workspaces
import Text.Printf
import Text.Read hiding (lift)
import Unsafe.Coerce
setMinWidth width widget = liftIO $ do
Gtk.widgetSetSizeRequest widget width (-1)
return widget
mkRGBA (r, g, b, a) = (r/256, g/256, b/256, a/256)
blue = mkRGBA (42, 99, 140, 256)
yellow1 = mkRGBA (242, 163, 54, 256)
yellow2 = mkRGBA (254, 204, 83, 256)
yellow3 = mkRGBA (227, 134, 18, 256)
red = mkRGBA (210, 77, 37, 256)
myGraphConfig =
defaultGraphConfig
{ graphPadding = 0
, graphBorderWidth = 0
, graphWidth = 75
, graphBackgroundColor = (1.0, 1.0, 1.0, 0.0)
}
netCfg = myGraphConfig
{ graphDataColors = [yellow1, yellow2]
, graphLabel = Just "net"
}
memCfg = myGraphConfig
{ graphDataColors = [(0.129, 0.588, 0.953, 1)]
, graphLabel = Just "mem"
}
cpuCfg = myGraphConfig
{ graphDataColors = [(0, 1, 0, 1), (1, 0, 1, 0.5)]
, graphLabel = Just "cpu"
}
memCallback :: IO [Double]
memCallback = do
mi <- parseMeminfo
return [memoryUsedRatio mi]
cpuCallback = do
(_, systemLoad, totalLoad) <- cpuLoad
return [totalLoad, systemLoad]
getFullWorkspaceNames :: X11Property [(WorkspaceIdx, String)]
getFullWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_FULL_NAMES"
where go = zip [WSIdx i | i <- [0..]]
workspaceNamesLabelSetter workspace =
fromMaybe "" . lookup (workspaceIdx workspace) <$>
liftX11Def [] getFullWorkspaceNames
logDebug = do
handler <- streamHandler stdout DEBUG
logger <- getLogger "System.Taffybar"
saveGlobalLogger $ setLevel DEBUG logger
workspacesLogger <- getLogger "System.Taffybar.Widget.Workspaces"
saveGlobalLogger $ setLevel WARNING workspacesLogger
github = do
Right (token, _) <- passGet "github-token"
githubNotificationsNew $ defaultGithubConfig $ Auth.OAuth $ BS.pack token
main = do
homeDirectory <- getHomeDirectory
logDebug
let resourcesDirectory = homeDirectory </> ".lib" </> "resources"
inResourcesDirectory file = resourcesDirectory </> file
highContrastDirectory =
"/" </> "usr" </> "share" </> "icons" </> "HighContrast" </> "256x256"
inHighContrastDirectory file = highContrastDirectory </> file
makeIcon = return . IIFilePath . inResourcesDirectory
myGetIconInfo w@WindowData {windowTitle = title, windowClass = klass}
| "URxvt" `isInfixOf` klass = makeIcon "urxvt.png"
| "Termite" `isInfixOf` klass = makeIcon "urxvt.png"
| "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
clock = textClockNew Nothing "%a %b %_d %r" 1
cpu = pollingGraphNew cpuCfg 0.5 cpuCallback
mem = pollingGraphNew memCfg 1 memCallback
layout = layoutNew defaultLayoutConfig
windows = windowsNew defaultWindowsConfig
myWorkspacesConfig =
defaultWorkspacesConfig
{ underlineHeight = 3
, underlinePadding = 2
, minWSWidgetSize = Nothing
, minIcons = 1
, getIconInfo = myGetIconInfo
, windowIconSize = 31
, widgetGap = 0
, showWorkspaceFn = hideEmpty
, updateRateLimitMicroseconds = 100000
, labelSetter = workspaceNamesLabelSetter
}
workspaces = workspacesNew myWorkspacesConfig
baseConfig = defaultSimpleTaffyConfig
{ startWidgets =
[ workspaces
, layout >>= buildPadBox
, windows >>= buildPadBox
]
, endWidgets = map (>>= buildPadBox)
[ clock >>= setMinWidth 200
, sniTrayNew
, github
, cpu
, mem
, networkGraphNew netCfg Nothing
-- , networkMonitorNew defaultNetFormat Nothing >>= setMinWidth 200
, fsMonitorNew 60 ["/dev/sdd2"]
, mpris2New
]
, barPosition = Top
, barPadding = 0
, barHeight = 55
, widgetSpacing = 0
}
simpleTaffyConfig =
baseConfig
dyreTaffybar $ withBatteryRefresh $ withLogServer $ withToggleServer $
toTaffyConfig simpleTaffyConfig
-- Local Variables:
-- flycheck-ghc-args: ("-Wno-missing-signatures")
-- End: