taffybar 2.0.0 → 2.1.0

raw patch · 62 files changed

+1508/−1119 lines, 62 filesdep +gi-gtk-hsdep +template-haskelldep −mtldep ~gtk-sni-traydep ~gtk-strutdep ~status-notifier-itemPVP ok

version bump matches the API change (PVP)

Dependencies added: gi-gtk-hs, template-haskell

Dependencies removed: mtl

Dependency ranges changed: gtk-sni-tray, gtk-strut, status-notifier-item, time

API changes (from Hackage documentation)

Files

• README.md +47/−17
• src/System/Taffybar.hs +22/−23
• src/System/Taffybar/Auth.hs +6/−3
• src/System/Taffybar/Compat/GtkLibs.hs +27/−13
• src/System/Taffybar/Context.hs +41/−18
• src/System/Taffybar/DBus.hs +2/−6
• src/System/Taffybar/DBus/Client/MPRIS2.hs +12/−0
• src/System/Taffybar/DBus/Client/Params.hs +73/−0
• src/System/Taffybar/DBus/Client/UPower.hs +15/−0
• src/System/Taffybar/DBus/Client/UPowerDevice.hs +15/−0
• src/System/Taffybar/DBus/Client/Util.hs +101/−0
• src/System/Taffybar/DBus/Toggle.hs +8/−8
• src/System/Taffybar/EWMHPixbuf.hs +78/−0
• src/System/Taffybar/Hooks.hs +6/−1
• src/System/Taffybar/IconImages.hs +0/−97
• src/System/Taffybar/Information/Battery.hs +166/−133
• src/System/Taffybar/Information/CPU2.hs +42/−31
• src/System/Taffybar/Information/DBusClients.hs +0/−11
• src/System/Taffybar/Information/DBusObjects.hs +0/−34
• src/System/Taffybar/Information/EWMHDesktopInfo.hs +1/−1
• src/System/Taffybar/Information/MPRIS2.hs +3/−2
• src/System/Taffybar/Information/Network.hs +1/−1
• src/System/Taffybar/Information/SafeX11.hsc +16/−16
• src/System/Taffybar/Information/StreamInfo.hs +2/−6
• src/System/Taffybar/Information/X11DesktopInfo.hs +4/−1
• src/System/Taffybar/Information/XDG/DesktopEntry.hs +3/−1
• src/System/Taffybar/Information/XDG/Protocol.hs +1/−1
• src/System/Taffybar/SimpleConfig.hs +1/−1
• src/System/Taffybar/TransparentWindow.hs +0/−59
• src/System/Taffybar/Util.hs +16/−8
• src/System/Taffybar/Widget.hs +1/−4
• src/System/Taffybar/Widget/Battery.hs +73/−165
• src/System/Taffybar/Widget/CPUMonitor.hs +1/−1
• src/System/Taffybar/Widget/CommandRunner.hs +2/−2
• src/System/Taffybar/Widget/Decorators.hs +12/−3
• src/System/Taffybar/Widget/DiskIOMonitor.hs +1/−1
• src/System/Taffybar/Widget/FSMonitor.hs +1/−1
• src/System/Taffybar/Widget/FreedesktopNotifications.hs +1/−1
• src/System/Taffybar/Widget/Generic/AutoSizeImage.hs +168/−0
• src/System/Taffybar/Widget/Generic/ChannelGraph.hs +1/−1
• src/System/Taffybar/Widget/Generic/ChannelWidget.hs +16/−0
• src/System/Taffybar/Widget/Generic/DynamicMenu.hs +13/−14
• src/System/Taffybar/Widget/Generic/Graph.hs +1/−1
• src/System/Taffybar/Widget/Generic/PollingGraph.hs +1/−1
• src/System/Taffybar/Widget/Generic/PollingLabel.hs +15/−10
• src/System/Taffybar/Widget/Generic/VerticalBar.hs +1/−1
• src/System/Taffybar/Widget/Layout.hs +15/−13
• src/System/Taffybar/Widget/MPRIS2.hs +57/−35
• src/System/Taffybar/Widget/NetMonitor.hs +0/−104
• src/System/Taffybar/Widget/NetworkGraph.hs +2/−2
• src/System/Taffybar/Widget/SNITray.hs +7/−3
• src/System/Taffybar/Widget/SimpleClock.hs +1/−1
• src/System/Taffybar/Widget/Systray.hs +1/−1
• src/System/Taffybar/Widget/Text/NetworkMonitor.hs +22/−21
• src/System/Taffybar/Widget/Util.hs +19/−6
• src/System/Taffybar/Widget/Volume.hs +1/−1
• src/System/Taffybar/Widget/Weather.hs +30/−32
• src/System/Taffybar/Widget/Windows.hs +11/−7
• src/System/Taffybar/Widget/Workspaces.hs +144/−116
• taffybar.cabal +18/−10
• taffybar.css +90/−38
• taffybar.hs.example +73/−31

@@ -1,33 +1,35 @@ Taffybar ======== [![Hackage](https://img.shields.io/hackage/v/taffybar.svg)](https://hackage.haskell.org/package/taffybar)+[![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Build Status](https://travis-ci.org/taffybar/taffybar.svg?branch=master)](https://travis-ci.org/taffybar/taffybar)+[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) -![](https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png)--Taffybar is a gtk+3 (through gtk2hs) based desktop information bar, intended-primarily for use with XMonad, though it can also function alongside other EWMH-compliant window managers. It is similar in spirit to xmobar, but it differs in-that it gives up some simplicity for a reasonable helping of eye candy.--Development Status-------------------+![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) -Taffybar is under active development and has many exciting but potentially-breaking changes ahead. All of the planned changes that will be occuring in the-near future are tracked in [this github-project](https://github.com/taffybar/taffybar/projects/1).+Taffybar is a gtk+3 [(through gtk2hs and+gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop+information bar, intended primarily for use with XMonad, though it can also+function alongside other EWMH compliant window managers. It is similar in spirit+to xmobar, but it differs in that it gives up some simplicity for a reasonable+helping of eye candy. -Installation-------------+Prerequisites+-------------  Taffybar has a number of non-haskell dependencies. It is recommended that you follow the installation instructions for [haskell-gi](https://github.com/haskell-gi/haskell-gi) before attempting to install taffybar. +In addition the the dependencies needed by haskell-gi, taffybar also needs the+equivalent of `libdbusmenu-gtk3-dev` and `libgirepository1.0-dev` on Debian.++Installation+------------+ Taffybar itself can be installed in a number of different ways:  ### Stack@@ -51,7 +53,14 @@ name of the binary can be changed in the cabal file in the taffybar configuration directory. +#### Running with stack +When you build with stack, it is recommended that you start taffybar with+`startTaffybar` rather than `dyreTaffybar`, and use+https://github.com/yamadapc/stack-run to execute the custom executable specified+by your cabal and stack files. The maintainers have plans for a better solution+(that does not require the user to use stack-run themselves) in [#158](https://github.com/taffybar/taffybar/issues/158).+ ### Cabal  Cabal installation is a simple matter of installing taffybar from hackage:@@ -64,9 +73,30 @@  Like xmobar and XMonad, taffybar is configured in haskell. Taffybar depends on dyre to automatically detect changes to its configuration file-($XDG_CONFIG_HOME/taffybar/taffybar.hs) and recompile when appropriate.+(`$XDG_CONFIG_HOME/taffybar/taffybar.hs`) and recompile when appropriate.  For more details about how to configure taffybar, see the [full documentation](https://hackage.haskell.org/package/taffybar). You can find a list of available widgets-[here](http://hackage.haskell.org/package/taffybar-1.0.2/docs/System-Taffybar-Widget.html)+[here](http://hackage.haskell.org/package/taffybar-2.0.0/docs/System-Taffybar-Widget.html)++Development Status+------------------++Taffybar has recently undergone a lot changes recently with the release of+[2.0.0](https://github.com/taffybar/taffybar/releases/tag/v2.0.0), but it's API+should be pretty stable moving forward, with the exception of the ongoing gi-gtk+migration (see [#256](https://github.com/taffybar/taffybar/issues/256). Though+it does/will involve significant code changes, this migration should be pretty+transparent, especially for users who don't do any advanced widget customization+(i.e. that involves actually directly importing gtk2hs).++Contributing+------------++Taffybar desperately needs contributors. If you want to help, but don't know+where to get started you can check out our "help wanted" and "easy" labels:+++[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted)+[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/easy.svg)](https://github.com/taffybar/taffybar/labels/easy)

@@ -38,10 +38,7 @@   --   -- > import System.Taffybar   -- > import System.Taffybar.SimpleConfig-  -- > import System.Taffybar.Widget.Systray-  -- > import System.Taffybar.Widget.Workspaces-  -- > import System.Taffybar.Widget.SimpleClock-  -- > import System.Taffybar.Widget.Generic.PollingGraph+  -- > import System.Taffybar.Widget   -- > import System.Taffybar.Information.CPU   -- >   -- > cpuCallback = do@@ -53,12 +50,11 @@   -- >                                   , graphLabel = Just "cpu"   -- >                                   }   -- >       clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1-  -- >       tray = systrayNew   -- >       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback-  -- >       workspacs = workspacesNew defaultWorkspacesConfig+  -- >       workspaces = workspacesNew defaultWorkspacesConfig   -- >       simpleConfig = defaultSimpleTaffyConfig   -- >                        { startWidgets = [ workspaces ]-  -- >                        , endWidgets = [ tray, clock, cpu ]+  -- >                        , endWidgets = [ sniTrayNew, clock, cpu ]   -- >                        }   -- >   simpleTaffybar simpleConfig   --@@ -74,7 +70,7 @@   -- green.   --   -- It is important to note that the widget lists are *not* [Widget]. They are-  -- actually [IO Widget] since the bar needs to construct them after performing+  -- actually [TaffyIO Widget] since the bar needs to construct them after performing   -- some GTK initialization.   --   -- ** A note about taffybar's dependency on DBus:@@ -107,19 +103,20 @@  import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre-import Control.Monad-import Graphics.UI.Gtk as Gtk-import Graphics.UI.Gtk.General.CssProvider+import           Control.Monad+import qualified Data.GI.Gtk.Threading as GIThreading+import qualified Graphics.UI.Gtk as Gtk+import           Graphics.UI.Gtk.General.CssProvider import qualified Graphics.UI.Gtk.General.StyleContext as Gtk-import Graphics.X11.Xlib.Misc-import System.Directory-import System.Environment.XDG.BaseDir ( getUserConfigFile )-import System.Exit ( exitFailure )-import System.FilePath ( (</>) )+import           Graphics.X11.Xlib.Misc+import           System.Directory+import           System.Environment.XDG.BaseDir ( getUserConfigFile )+import           System.Exit ( exitFailure )+import           System.FilePath ( (</>) ) import qualified System.IO as IO-import System.Taffybar.Context+import           System.Taffybar.Context -import Paths_taffybar ( getDataDir )+import           Paths_taffybar ( getDataDir )  -- | The parameters that are passed to Dyre when taffybar is invoked with -- 'dyreTaffybar'.@@ -166,21 +163,23 @@         flip when (cssProviderLoadFromPath taffybarProvider filePath)   loadIfExists =<< getDefaultConfigFile "taffybar.css"   loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css"-  Just scr <- screenGetDefault+  Just scr <- Gtk.screenGetDefault   Gtk.styleContextAddProviderForScreen scr taffybarProvider 800   return taffybarProvider  -- | Start taffybar with the provided 'TaffybarConfig'. Because this function -- will not handle recompiling taffybar automatically when taffybar.hs is -- updated, it is generally recommended that end users use 'dyreTaffybar'--- instead. If automatic recompilation is handled by another mechanism, or not--- desired for some reason, it is perfectly fine to use this function.+-- instead. If automatic recompilation is handled by another mechanism such as+-- stack or a custom user script or not desired for some reason, it is+-- perfectly fine to use this function. startTaffybar :: TaffybarConfig -> IO () startTaffybar config = do   _ <- initThreads-  _ <- initGUI+  _ <- Gtk.initGUI+  Gtk.postGUIAsync GIThreading.setCurrentThreadAsGUIThread   _ <- startCSS   _ <- buildContext config -  mainGUI+  Gtk.mainGUI   return ()

@@ -2,7 +2,7 @@ module System.Taffybar.Auth where  import           Control.Arrow-import           Control.Monad.Trans+import           Control.Monad.IO.Class import           Data.Maybe import           System.Taffybar.Util import           Text.Regex@@ -12,9 +12,12 @@  passGet :: MonadIO m => String -> m (Either String (String, [(String, String)])) passGet credentialName =-  right (getPassComponents . lines) <$> runCommandFromPath ["pass", "show", credentialName]+  right (getPassComponents . lines) <$>+        runCommandFromPath ["pass", "show", credentialName]   where getPassComponents passLines =-          let entries = map buildEntry $ catMaybes $ matchRegex fieldRegex <$> tail passLines+          let entries =+                map buildEntry $ catMaybes $+                    matchRegex fieldRegex <$> tail passLines               buildEntry [fieldName, fieldValue] = (fieldName, fieldValue)               buildEntry _ = ("", "")           in (head passLines, entries)

@@ -27,29 +27,43 @@ fromGIPixBuf (PB.Pixbuf pbManagedPtr) = liftIO $   wrapNewGObject Gtk.mkPixbuf (castPtr <$> disownManagedPtr pbManagedPtr) +fromGIWidget'+  :: (MonadIO m, GObjectClass a)+  => (ForeignPtr a -> a, FinalizerPtr a)+  -> GI.Gtk.ManagedPtr b+  -> m a+fromGIWidget' mk2hs giWidget = liftIO $+  wrapNewGObject mk2hs (castPtr <$> disownManagedPtr giWidget)++toGIWidget'+  :: MonadIO m+  => (GI.Gtk.ManagedPtr a1 -> b) -> (t -> ForeignPtr a2) -> t -> m b+toGIWidget' mkGI un2hs gtk2hsWidget = liftIO $ do+  fPtr <- withForeignPtr (un2hs gtk2hsWidget) $+          flip GI.Gtk.newManagedPtr (return ()) . castPtr+  return $! mkGI fPtr+ fromGIWidget :: MonadIO m => GI.Gtk.Widget -> m Gtk.Widget-fromGIWidget (GI.Gtk.Widget wManagedPtr) = liftIO $-  wrapNewGObject Gtk.mkWidget (castPtr <$> disownManagedPtr wManagedPtr)+fromGIWidget (GI.Gtk.Widget wManagedPtr) = fromGIWidget' Gtk.mkWidget wManagedPtr  toGIWidget :: MonadIO m => Gtk.Widget -> m GI.Gtk.Widget-toGIWidget widget = liftIO $ do-  fPtr <- withForeignPtr (Gtk.unWidget widget) $-          flip GI.Gtk.newManagedPtr (return ()) . castPtr-  return $! GI.Gtk.Widget fPtr+toGIWidget = toGIWidget' GI.Gtk.Widget Gtk.unWidget  toGIWindow :: MonadIO m => Gtk.Window -> m GI.Gtk.Window-toGIWindow window = liftIO $ do-  let wid = Gtk.toWidget window-  fPtr <- withForeignPtr (Gtk.unWidget wid) $ flip GI.Gtk.newManagedPtr (return ()) . castPtr-  return $! GI.Gtk.Window fPtr+toGIWindow = toGIWidget' GI.Gtk.Window Gtk.unWindow +fromGIImage :: MonadIO m => GI.Gtk.Image -> m Gtk.Image+fromGIImage (GI.Gtk.Image wManagedPtr) = fromGIWidget' Gtk.mkImage wManagedPtr++toGIImage :: MonadIO m => Gtk.Image -> m GI.Gtk.Image+toGIImage = toGIWidget' GI.Gtk.Image Gtk.unImage+ -- | Call the GI version of 'pixbufNewFromData' with sensible parameters. The -- provided ptr will be freed when the pixbuf is destroyed.-pixbufNewFromData :: (Integral p2, Integral p1) => Ptr Word8 -> p2 -> p1 -> IO Gtk.Pixbuf+pixbufNewFromData :: (Integral p2, Integral p1) => Ptr Word8 -> p2 -> p1 -> IO PB.Pixbuf pixbufNewFromData ptr w h = do   let width = fromIntegral w       height = fromIntegral h       rowStride = width * 4-  giPb <- PB.pixbufNewFromData ptr ColorspaceRgb True 8+  PB.pixbufNewFromData ptr ColorspaceRgb True 8     width height rowStride (Just free)-  fromGIPixBuf giPb

@@ -22,7 +22,8 @@ import qualified Control.Concurrent.MVar as MV import           Control.Exception.Enclosed (catchAny) import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader import qualified DBus.Client as DBus@@ -38,11 +39,13 @@ import qualified GI.Gtk import           Graphics.UI.GIGtkStrut import           Graphics.UI.Gtk as Gtk+import           StatusNotifier.TransparentWindow import           System.Log.Logger import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Information.SafeX11 import           System.Taffybar.Information.X11DesktopInfo-import           System.Taffybar.TransparentWindow+import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.AutoSizeImage import           System.Taffybar.Widget.Util import           Text.Printf import           Unsafe.Coerce@@ -87,6 +90,10 @@   , errorMsg :: Maybe String   } +appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig+appendHook hook config = config+  { startupHook = startupHook config >> hook }+ defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig   { dbusClientParam = Nothing@@ -100,8 +107,10 @@   , listeners :: MV.MVar SubscriptionList   , contextState :: MV.MVar (M.Map TypeRep Value)   , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]-  , dbusClient :: DBus.Client+  , sessionDBusClient :: DBus.Client+  , systemDBusClient :: DBus.Client   , getBarConfigs :: BarConfigGetter+  , contextBarConfig :: Maybe BarConfig   }  buildContext :: TaffybarConfig -> IO Context@@ -112,6 +121,7 @@                } = do   logIO DEBUG "Building context"   dbusC <- maybe DBus.connectSession return maybeDBus+  sDBusC <- DBus.connectSystem   _ <- DBus.requestName dbusC "org.taffybar.Bar"        [DBus.nameAllowReplacement, DBus.nameReplaceExisting]   listenersVar <- MV.newMVar []@@ -122,9 +132,11 @@                 { x11ContextVar = x11Context                 , listeners = listenersVar                 , contextState = state-                , dbusClient = dbusC+                , sessionDBusClient = dbusC+                , systemDBusClient = sDBusC                 , getBarConfigs = barConfigGetter                 , existingWindows = windowsVar+                , contextBarConfig = Nothing                 }   _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>=               (lift . GI.Gdk.displayGetDefaultScreen) >>=@@ -150,13 +162,14 @@  buildBarWindow :: Context -> BarConfig -> IO Gtk.Window buildBarWindow context barConfig = do+  let thisContext = context { contextBarConfig = Just barConfig }   logIO DEBUG $       printf "Building bar window with StrutConfig: %s" $       show $ strutConfig barConfig    window <- Gtk.windowNew   box <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig-  _ <- widgetSetClass box "TaffyBox"+  _ <- widgetSetClass box "taffy-box"   centerBox <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig   Gtk.boxSetCenterWidget box centerBox @@ -165,7 +178,7 @@   setupStrutWindow (strutConfig barConfig) giWindow   Gtk.containerAdd window box -  _ <- widgetSetClass window "Taffybar"+  _ <- widgetSetClass window "taffy-window"    let addWidgetWith widgetAdd buildWidget =         do@@ -240,7 +253,8 @@             mapM_ setPropertiesFromPair remainingWindows              logIO DEBUG "Constructing new windows"-            mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx)) newConfs+            mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx))+                 newConfs            return $ newWindowPairs ++ remainingWindows @@ -277,20 +291,28 @@   let maybeValue = M.lookup (typeOf (undefined :: t)) stateMap   return $ maybeValue >>= fromValue +-- | Like "putState", but avoids aquiring a lock if the value is already in the+-- map. getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t getStateDefault defaultGetter =-  getState >>= maybe (defaultGetter >>= putState) return+  getState >>= maybe (putState defaultGetter) return -putState :: Typeable t => t -> Taffy IO t-putState v = do+-- | Get a value of the type returned by the provided action from the the+-- current taffybar state, unless the state does not exist, in which case the+-- action will be called to populate the state map.+putState :: forall t. Typeable t => Taffy IO t -> Taffy IO t+putState getValue = do   contextVar <- asks contextState-  lift $ MV.modifyMVar_ contextVar $ return . M.insert (typeOf v) (Value v)-  return v--liftReader ::-  Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b-liftReader modifier action =-  ask >>= lift . modifier . runReaderT action+  ctx <- ask+  lift $ MV.modifyMVar contextVar $ \contextStateMap ->+    let theType = typeOf (undefined :: t)+        currentValue = M.lookup theType contextStateMap+        insertAndReturn value =+          (M.insert theType (Value value) contextStateMap, value)+    in flip runReaderT ctx $  maybe+         (insertAndReturn  <$> getValue)+         (return . (contextStateMap,))+         (currentValue >>= fromValue)  taffyFork :: ReaderT r IO () -> ReaderT r IO () taffyFork = void . liftReader forkIO@@ -324,7 +346,8 @@ subscribeToEvents eventNames listener = do   eventAtoms <- mapM (runX11 . getAtom) eventNames   let filteredListener event@PropertyEvent { ev_atom = atom } =-        when (atom `elem` eventAtoms) $ catchAny (listener event) (const $ return ())+        when (atom `elem` eventAtoms) $+             catchAny (listener event) (const $ return ())       filteredListener _ = return ()   subscribeToAll filteredListener 

@@ -6,19 +6,15 @@   , withToggleServer   ) where -import Control.Monad.Trans+import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import System.Log.DBus.Server import System.Taffybar.Context import System.Taffybar.DBus.Toggle -appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig-appendHook hook config = config-  { startupHook = startupHook config >> hook }- startTaffyLogServer :: TaffyIO () startTaffyLogServer =-  asks dbusClient >>= lift . startLogServer+  asks sessionDBusClient >>= lift . startLogServer  withLogServer :: TaffybarConfig -> TaffybarConfig withLogServer = appendHook startTaffyLogServer

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.MPRIS2 where++import System.Taffybar.DBus.Client.Util+import System.FilePath+import System.Taffybar.DBus.Client.Params++generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $+                       "dbus-xml" </> "org.mpris.MediaPlayer2.xml"++generateClientFromFile defaultRecordGenerationParams playerGenerationParams False $+                       "dbus-xml" </> "org.mpris.MediaPlayer2.Player.xml"

@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.DBus.Client.Params where++import DBus+import DBus.Generation+import Language.Haskell.TH+import System.Taffybar.DBus.Client.Util++playerGenerationParams :: GenerationParams+playerGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True+  , genObjectPath = Just "/org/mpris/MediaPlayer2"+  }+++-- | The base object path for the UPower interface+uPowerBaseObjectPath :: ObjectPath+uPowerBaseObjectPath = "/org/freedesktop/UPower"++-- | The name of the power daemon bus+uPowerBusName :: BusName+uPowerBusName = "org.freedesktop.UPower"++uPowerDeviceInterfaceName :: InterfaceName+uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device"++uPowerGenerationParams :: GenerationParams+uPowerGenerationParams = defaultGenerationParams+  { genTakeSignalErrorHandler = True+  , genBusName = Just uPowerBusName+  }++data BatteryType+  = BatteryTypeUnknown+  | BatteryTypeLinePower+  | BatteryTypeBatteryType+  | BatteryTypeUps+  | BatteryTypeMonitor+  | BatteryTypeMouse+  | BatteryTypeKeyboard+  | BatteryTypePda+  | BatteryTypePhone+  deriving (Show, Ord, Eq, Enum)++data BatteryState+  = BatteryStateUnknown+  | BatteryStateCharging+  | BatteryStateDischarging+  | BatteryStateEmpty+  | BatteryStateFullyCharged+  | BatteryStatePendingCharge+  | BatteryStatePendingDischarge+  deriving (Show, Ord, Eq, Enum)++data BatteryTechnology+  = BatteryTechnologyUnknown+  | BatteryTechnologyLithiumIon+  | BatteryTechnologyLithiumPolymer+  | BatteryTechnologyLithiumIronPhosphate+  | BatteryTechnologyLeadAcid+  | BatteryTechnologyNickelCadmium+  | BatteryTechnologyNickelMetalHydride+  deriving (Show, Ord, Eq, Enum)++batteryTypeForName :: GetTypeForName+batteryTypeForName name = const $+  case name of+    "Type" -> yes ''BatteryType+    "State" -> yes ''BatteryState+    "Technology" -> yes ''BatteryTechnology+    _ -> Nothing+  where yes = Just . ConT

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.UPower where++import DBus.Generation+import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams { recordName = Just "UPowerInfo"+                                , recordPrefix = "upi"+                                }+  uPowerGenerationParams { genObjectPath = Just uPowerBaseObjectPath }+  False $+  "dbus-xml" </> "org.freedesktop.UPower.xml"

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.UPowerDevice where++import System.FilePath+import System.Taffybar.DBus.Client.Params+import System.Taffybar.DBus.Client.Util++generateClientFromFile+  defaultRecordGenerationParams+  { recordName = Just "BatteryInfo"+  , recordPrefix = "battery"+  , recordTypeForName = batteryTypeForName+  }+  uPowerGenerationParams+  False $ "dbus-xml" </> "org.freedesktop.UPower.Device.xml"

@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.DBus.Client.Util where++import           Control.Applicative+import           DBus.Generation+import qualified DBus.Internal.Types as T+import qualified DBus.Introspection as I+import qualified Data.Char as Char+import           Data.Coerce+import           Data.Maybe+import           Language.Haskell.TH+import           StatusNotifier.Util (getIntrospectionObjectFromFile)++#if __GLASGOW_HASKELL__ >= 802+deriveShowAndEQ :: [DerivClause]+deriveShowAndEQ =+  [DerivClause Nothing [ConT ''Eq, ConT ''Show]]+#endif++buildDataFromNameTypePairs :: Name -> [(Name, Type)] -> Dec+buildDataFromNameTypePairs name pairs =+  DataD [] name [] Nothing [RecC name (map mkVarBangType pairs)]+#if __GLASGOW_HASKELL__ >= 802+        deriveShowAndEQ+#else+        []+#endif+  where mkVarBangType (fieldName, fieldType) =+          (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, fieldType)+++standaloneDeriveEqShow :: Name -> [Dec]+#if __GLASGOW_HASKELL__ < 802+standaloneDeriveEqShow name =+  [ StandaloneDerivD [] (ConT ''Eq `AppT` ConT name)+  , StandaloneDerivD [] (ConT ''Show `AppT` ConT name)+  ]+#else+standaloneDeriveEqShow _ = []+#endif++type GetTypeForName = String -> T.Type -> Maybe Type++data RecordGenerationParams = RecordGenerationParams+  { recordName :: Maybe String+  , recordPrefix :: String+  , recordTypeForName :: GetTypeForName+  }++defaultRecordGenerationParams :: RecordGenerationParams+defaultRecordGenerationParams = RecordGenerationParams+  { recordName = Nothing+  , recordPrefix = "_"+  , recordTypeForName = const $ const Nothing+  }++generateGetAllRecord+  :: RecordGenerationParams+  -> GenerationParams+  -> I.Interface+  -> Q [Dec]+generateGetAllRecord+               RecordGenerationParams+               { recordName = recordNameString+               , recordPrefix = prefix+               , recordTypeForName = getTypeForName+               }+               GenerationParams { getTHType = getArgType }+               I.Interface { I.interfaceName = interfaceName+                           , I.interfaceProperties = properties+                           } = do+  let theRecordName =+        maybe (mkName $ map Char.toUpper $ filter Char.isLetter $ coerce interfaceName)+              mkName recordNameString+  let getPairFromProperty I.Property+                            { I.propertyName = propName+                            , I.propertyType = propType+                            } =+                            ( mkName $ prefix ++ propName+                            , fromMaybe (getArgType propType) $ getTypeForName propName propType+                            )+      getAllRecord =+        buildDataFromNameTypePairs+        theRecordName $ map getPairFromProperty properties+  return $ getAllRecord:standaloneDeriveEqShow theRecordName++generateClientFromFile :: RecordGenerationParams -> GenerationParams -> Bool -> FilePath -> Q [Dec]+generateClientFromFile recordGenerationParams params useObjectPath filepath = do+  object <- getIntrospectionObjectFromFile filepath "/"+  let interface = head $ I.objectInterfaces object+      actualObjectPath = I.objectPath object+      realParams =+        if useObjectPath+          then params {genObjectPath = Just actualObjectPath}+          else params+      (<++>) = liftA2 (++)+  generateGetAllRecord recordGenerationParams params interface <++>+    generateClient realParams interface <++>+    generateSignalsFromInterface realParams interface

@@ -13,22 +13,20 @@ -- of taffybar on each monitor while it is running. ----------------------------------------------------------------------------- -module System.Taffybar.DBus.Toggle-  ( handleDBusToggles-  ) where+module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where  import           Control.Applicative import qualified Control.Concurrent.MVar as MV import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader import           DBus import           DBus.Client import           Data.Int import qualified Data.Map as M-import qualified GI.Gdk as Gdk import           Data.Maybe+import qualified GI.Gdk as Gdk import           Graphics.UI.GIGtkStrut import           Paths_taffybar ( getDataDir ) import           Prelude@@ -80,7 +78,8 @@                (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2                _ -> return False       equalsMonitor _ = return False-  snd . fromMaybe (Nothing, 0) . listToMaybe <$> filterM equalsMonitor (zip monitors [0..])+  snd . fromMaybe (Nothing, 0) . listToMaybe <$>+      filterM equalsMonitor (zip monitors [0..])  taffybarTogglePath :: ObjectPath taffybarTogglePath = "/taffybar/toggle"@@ -102,7 +101,8 @@   TogglesMVar enabledVar <- getTogglesVar   numToEnabled <- lift $ MV.readMVar enabledVar   let isEnabled monNumber = fromMaybe True $ M.lookup monNumber numToEnabled-      isConfigEnabled = isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig+      isConfigEnabled =+        isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig   return $ filter isConfigEnabled barConfigs  exportTogglesInterface :: TaffyIO ()@@ -123,7 +123,7 @@         toggleTaffyOnMon not $ fromMaybe 0 num       takeInt :: (Int -> a) -> (Int32 -> a)       takeInt = (. fromIntegral)-  client <- asks dbusClient+  client <- asks sessionDBusClient   let interface =         defaultInterface         { interfaceName = taffybarToggleInterface

@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.EWMHPixbuf+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+-----------------------------------------------------------------------------++module System.Taffybar.EWMHPixbuf+  ( ColorRGBA+  , pixBufFromEWMHIcon+  , pixelsARGBToBytesABGR+  , pixBufFromColor+  , pixBufFromFile+  ) where++import           Data.Bits+import           Data.Int+import           Data.Word+import           Foreign.Marshal.Array+import           Foreign.Ptr+import           Foreign.Storable+import qualified GI.GdkPixbuf.Enums as Gdk+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import           System.Taffybar.Compat.GtkLibs+import           System.Taffybar.Information.EWMHDesktopInfo++type ColorRGBA = Word32++colorspace :: Gdk.Colorspace+colorspace = Gdk.ColorspaceRgb++-- | Create a pixbuf from the pixel data in an EWMHIcon.+pixBufFromEWMHIcon :: EWMHIcon -> IO Gdk.Pixbuf+pixBufFromEWMHIcon EWMHIcon {width = w, height = h, pixelsARGB = px} = do+  wPtr <- pixelsARGBToBytesABGR px (w * h)+  pixbufNewFromData wPtr w h++-- | Create a pixbuf with the indicated RGBA color.+pixBufFromColor :: Int32 -> ColorRGBA -> IO Gdk.Pixbuf+pixBufFromColor imgSize c = do+  Just pixbuf <- Gdk.pixbufNew colorspace True 8 imgSize imgSize+  Gdk.pixbufFill pixbuf c+  return pixbuf++-- | Convert a C array of integer pixels in the ARGB format to the ABGR format.+-- Returns an unmanged Ptr that points to a block of memory that must be freed+-- manually.+pixelsARGBToBytesABGR+  :: (Storable a, Bits a, Num a, Integral a)+  => Ptr a -> Int -> IO (Ptr Word8)+pixelsARGBToBytesABGR ptr size = do+  target <- mallocArray (size * 4)+  let writeIndex i = do+        bits <- peekElemOff ptr i+        let b = toByte bits+            g = toByte $ bits `shift` (-8)+            r = toByte $ bits `shift` (-16)+            a = toByte $ bits `shift` (-24)+            baseTarget = 4 * i+            doPoke offset = pokeElemOff target (baseTarget + offset)+            toByte = fromIntegral . (.&. 0xFF)+        doPoke 0 r+        doPoke 1 g+        doPoke 2 b+        doPoke 3 a+      writeIndexAndNext i+        | i >= size = return ()+        | otherwise = writeIndex i >> writeIndexAndNext (i + 1)+  writeIndexAndNext 0+  return target++-- | Create a pixbuf from a file and scale it to be square.+pixBufFromFile :: FilePath -> IO Gdk.Pixbuf+pixBufFromFile = Gdk.pixbufNewFromFile

@@ -1,12 +1,14 @@ module System.Taffybar.Hooks   ( module System.Taffybar.DBus   , module System.Taffybar.Hooks+  , refreshBatteriesOnPropChange   ) where  import Control.Concurrent-import Control.Monad.Trans+import Control.Monad.Trans.Class import System.Taffybar.Context import System.Taffybar.DBus+import System.Taffybar.Information.Battery import System.Taffybar.Information.Network  newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))])@@ -19,3 +21,6 @@  getNetworkChan :: TaffyIO NetworkInfoChan getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0++withBatteryRefresh :: TaffybarConfig -> TaffybarConfig+withBatteryRefresh = appendHook refreshBatteriesOnPropChange

@@ -1,97 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.IconImages--- Copyright   : (c) Ivan A. Malison--- License     : BSD3-style (see LICENSE)------ Maintainer  : Ivan A. Malison--- Stability   : unstable--- Portability : unportable--------------------------------------------------------------------------------module System.Taffybar.IconImages (-  ColorRGBA,-  scalePixbuf,-  pixBufFromEWMHIcon,-  pixelsARGBToBytesABGR,-  pixBufFromColor,-  pixBufFromFile-) where---- TODO: rename module to IconPixbuf--import           Data.Bits-import           Data.Word-import           Foreign.Marshal.Array-import           Foreign.Ptr-import           Foreign.Storable-import qualified Graphics.UI.Gtk as Gtk-import           System.Taffybar.Information.EWMHDesktopInfo-import           System.Taffybar.Compat.GtkLibs--type ColorRGBA = (Word8, Word8, Word8, Word8)---- | Take the passed in pixbuf and scale it to the provided imageSize.-scalePixbuf :: Int -> Gtk.Pixbuf -> IO Gtk.Pixbuf-scalePixbuf imgSize pixbuf = do-  h <- Gtk.pixbufGetHeight pixbuf-  w <- Gtk.pixbufGetWidth pixbuf-  if h /= imgSize || w /= imgSize-  then-    Gtk.pixbufScaleSimple pixbuf imgSize imgSize Gtk.InterpBilinear-  else-    return pixbuf--sampleBits :: Int-sampleBits = 8--hasAlpha :: Bool-hasAlpha = True--colorspace :: Gtk.Colorspace-colorspace = Gtk.ColorspaceRgb---- | Create a pixbuf from the pixel data in an EWMHIcon.-pixBufFromEWMHIcon :: EWMHIcon -> IO Gtk.Pixbuf-pixBufFromEWMHIcon EWMHIcon {width = w, height = h, pixelsARGB = px} = do-  wPtr <- pixelsARGBToBytesABGR px (w * h)-  pixbufNewFromData wPtr w h---- | Create a pixbuf with the indicated RGBA color.-pixBufFromColor :: Int -> ColorRGBA -> IO Gtk.Pixbuf-pixBufFromColor imgSize (r, g, b, a) = do-  pixbuf <- Gtk.pixbufNew colorspace hasAlpha sampleBits imgSize imgSize-  Gtk.pixbufFill pixbuf r g b a-  return pixbuf---- | Convert a C array of integer pixels in the ARGB format to the ABGR format.--- Returns an unmanged Ptr that points to a block of memory that must be freed--- manually.-pixelsARGBToBytesABGR-  :: (Storable a, Bits a, Num a, Integral a)-  => Ptr a -> Int -> IO (Ptr Word8)-pixelsARGBToBytesABGR ptr size = do-  target <- mallocArray (size * 4)-  let writeIndex i = do-        bits <- peekElemOff ptr i-        let b = toByte bits-            g = toByte $ bits `shift` (-8)-            r = toByte $ bits `shift` (-16)-            a = toByte $ bits `shift` (-24)-            baseTarget = 4 * i-            doPoke offset = pokeElemOff target (baseTarget + offset)-            toByte = fromIntegral . (.&. 0xFF)-        doPoke 0 r-        doPoke 1 g-        doPoke 2 b-        doPoke 3 a-      writeIndexAndNext i-        | i >= size = return ()-        | otherwise = writeIndex i >> writeIndexAndNext (i + 1)-  writeIndexAndNext 0-  return target---- | Create a pixbuf from a file and scale it to be square.-pixBufFromFile :: Int -> FilePath -> IO Gtk.Pixbuf-pixBufFromFile imgSize file =-  Gtk.pixbufNewFromFileAtScale file imgSize imgSize False

@@ -1,117 +1,61 @@ {-# LANGUAGE OverloadedStrings #-} -- | This is a simple library to query the Linux UPower daemon (via DBus) for--- battery information. Currently, it only retrieves information for the first--- battery it finds.-module System.Taffybar.Information.Battery (+-- battery information.+module System.Taffybar.Information.Battery+  (   -- * Types-  BatteryContext,-  BatteryInfo(..),-  BatteryState(..),-  BatteryTechnology(..),-  BatteryType(..),-  -- * Accessors-  batteryContextsNew,-  getBatteryInfo+    BatteryInfo(..)+  , BatteryState(..)+  , BatteryTechnology(..)+  , BatteryType(..)+  , module System.Taffybar.Information.Battery   ) where -import Data.Map ( Map )+import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Reader+import           DBus+import           DBus.Client+import           DBus.Internal.Types (Serial(..))+import qualified DBus.TH as DBus+import           Data.Int+import           Data.List+import           Data.Map ( Map ) import qualified Data.Map as M-import Data.Maybe ( fromMaybe, maybeToList )-import Data.Word-import Data.Int-import DBus-import DBus.Client-import Data.List ( isInfixOf )-import Data.Text ( Text )-import qualified Data.Text as T-import Safe ( atMay )---- | An opaque wrapper around some internal library state-data BatteryContext = BC Client ObjectPath+import           Data.Maybe+import           Data.Text ( Text )+import           Data.Word+import           System.Log.Logger+import           System.Taffybar.Context+import           System.Taffybar.DBus.Client.Params+import           System.Taffybar.DBus.Client.UPower+import           System.Taffybar.DBus.Client.UPowerDevice+import           System.Taffybar.Util -data BatteryType-  = BatteryTypeUnknown-  | BatteryTypeLinePower-  | BatteryTypeBatteryType-  | BatteryTypeUps-  | BatteryTypeMonitor-  | BatteryTypeMouse-  | BatteryTypeKeyboard-  | BatteryTypePda-  | BatteryTypePhone-  deriving (Show, Ord, Eq, Enum)+batteryLogPath :: String+batteryLogPath = "System.Taffybar.Information.Battery" -data BatteryState-  = BatteryStateUnknown-  | BatteryStateCharging-  | BatteryStateDischarging-  | BatteryStateEmpty-  | BatteryStateFullyCharged-  | BatteryStatePendingCharge-  | BatteryStatePendingDischarge-  deriving (Show, Ord, Eq, Enum)+batteryLog+  :: MonadIO m+  => Priority -> String -> m ()+batteryLog priority = liftIO . logM batteryLogPath priority -data BatteryTechnology-  = BatteryTechnologyUnknown-  | BatteryTechnologyLithiumIon-  | BatteryTechnologyLithiumPolymer-  | BatteryTechnologyLithiumIronPhosphate-  | BatteryTechnologyLeadAcid-  | BatteryTechnologyNickelCadmium-  | BatteryTechnologyNickelMetalHydride-  deriving (Show, Ord, Eq, Enum)+batteryLogF+  :: (MonadIO m, Show t)+  => Priority -> String -> t -> m ()+batteryLogF = logPrintF batteryLogPath --- | There are a few fields supported by UPower that aren't exposed--- here.. could be easily.-data BatteryInfo = BatteryInfo-  { batteryNativePath :: Text-  , batteryVendor :: Text-  , batteryModel :: Text-  , batterySerial :: Text-  , batteryType :: BatteryType-  , batteryPowerSupply :: Bool-  , batteryHasHistory :: Bool-  , batteryHasStatistics :: Bool-  , batteryOnline :: Bool-  , batteryEnergy :: Double-  , batteryEnergyEmpty :: Double-  , batteryEnergyFull :: Double-  , batteryEnergyFullDesign :: Double-  , batteryEnergyRate :: Double-  , batteryVoltage :: Double-  , batteryTimeToEmpty :: Int64-  , batteryTimeToFull :: Int64-  , batteryPercentage :: Double-  , batteryIsPresent :: Bool-  , batteryState :: BatteryState-  , batteryIsRechargable :: Bool-  , batteryCapacity :: Double-  , batteryTechnology :: BatteryTechnology-  }-{--  , batteryUpdateTime :: Time-  , batteryRecallNotice :: Bool-  , batteryRecallVendor :: Text-  , batteryRecallUr :: Text--}+-- | The prefix of name of battery devices path. UPower generates the object+-- path as "battery" + "_" + basename of the sysfs object.+batteryPrefix :: String+batteryPrefix = formatObjectPath uPowerBaseObjectPath ++ "/devices/battery_" --- | determine if a power source is a battery. The simple heuristic is a--- substring search on 'BAT'.+-- | Determine if a power source is a battery. isBattery :: ObjectPath -> Bool-isBattery = isInfixOf "BAT" . formatObjectPath---- | Find the power sources that are batteries (according to--- 'isBattery')-batteries :: [ObjectPath] -> [ObjectPath]-batteries = filter isBattery---- | The name of the power daemon bus-powerBusName :: BusName-powerBusName = "org.freedesktop.UPower"---- | The base object path-powerBaseObjectPath :: ObjectPath-powerBaseObjectPath = "/org/freedesktop/UPower"+isBattery = isPrefixOf batteryPrefix . formatObjectPath  -- | A helper to read the variant contents of a dict with a default -- value.@@ -137,26 +81,25 @@     f :: (Num a, IsVariant a) => Variant -> a     f = fromMaybe (fromIntegral dflt) . fromVariant +-- XXX: Remove this once it is exposed in haskell-dbus+dummyMethodError :: MethodError+dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"+ -- | Query the UPower daemon about information on a specific battery. -- If some fields are not actually present, they may have bogus values -- here.  Don't bet anything critical on it.-getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo)-getBatteryInfo (BC systemConn battPath)-  -- Grab all of the properties of the battery each call with one-  -- message.- = do-  reply <--    call_-      systemConn-      (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")-      { methodCallDestination = Just "org.freedesktop.UPower"-      , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]-      }-  return $ do-    body <- methodReturnBody reply `atMay` 0-    dict <- fromVariant body-    return-      BatteryInfo+getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo)+getBatteryInfo battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do+  reply <- ExceptT $ getAllProperties client $+           (methodCall battPath uPowerDeviceInterfaceName "FakeMethod")+           { methodCallDestination = Just uPowerBusName }+  dict <- ExceptT $ return $ maybeToEither dummyMethodError $+         listToMaybe (methodReturnBody reply) >>= fromVariant+  return $ infoMapToBatteryInfo dict++infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo+infoMapToBatteryInfo dict =+    BatteryInfo       { batteryNativePath = readDict dict "NativePath" ""       , batteryVendor = readDict dict "Vendor" ""       , batteryModel = readDict dict "Model" ""@@ -177,22 +120,112 @@       , batteryPercentage = readDict dict "Percentage" 0.0       , batteryIsPresent = readDict dict "IsPresent" False       , batteryState = toEnum $ readDictIntegral dict "State" 0-      , batteryIsRechargable = readDict dict "IsRechargable" True+      , batteryIsRechargeable = readDict dict "IsRechargable" True       , batteryCapacity = readDict dict "Capacity" 0.0       , batteryTechnology =           toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0+      , batteryUpdateTime = readDict dict "UpdateTime" 0+      , batteryLuminosity = readDict dict "Luminosity" 0.0+      , batteryTemperature = readDict dict "Temperature" 0.0+      , batteryWarningLevel = readDict dict "WarningLevel" 0+      , batteryBatteryLevel = readDict dict "BatteryLevel" 0+      , batteryIconName = readDict dict "IconName" ""       } --- | Construct a battery context for every battery in the system. This--- could fail if the UPower daemon is not running. The contexts can be--- used to get actual battery state with 'getBatteryInfo'.-batteryContextsNew :: IO [BatteryContext]-batteryContextsNew = do-  systemConn <- connectSystem-  let mc = methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices"-  reply <- call_ systemConn mc { methodCallDestination = Just powerBusName }-  return $ do-    body <- take 1 $ methodReturnBody reply-    powerDevices <- maybeToList $ fromVariant body-    battPath <- batteries powerDevices-    return $ BC systemConn battPath+getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath])+getBatteryPaths = do+  client <- asks systemDBusClient+  liftIO $ runExceptT $ do+    paths <- ExceptT $ enumerateDevices client+    return $ filter isBattery paths++newtype DisplayBatteryChanVar =+  DisplayBatteryChanVar (Chan BatteryInfo, MVar BatteryInfo)++getDisplayBatteryInfo :: TaffyIO BatteryInfo+getDisplayBatteryInfo = do+  DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar+  lift $ readMVar theVar++getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar+getDisplayBatteryChanVar =+  getStateDefault $ DisplayBatteryChanVar <$> monitorDisplayBattery++getDisplayBatteryChan :: TaffyIO (Chan BatteryInfo)+getDisplayBatteryChan = do+  DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar+  return chan++updateBatteryInfo+  :: Chan BatteryInfo+  -> MVar BatteryInfo+  -> ObjectPath+  -> TaffyIO ()+updateBatteryInfo chan var path =+  getBatteryInfo path >>= lift . either warnOfFailure doWrites+  where+    doWrites info =+        batteryLogF DEBUG "Writing info %s" info >>+        swapMVar var info >> writeChan chan info+    warnOfFailure = batteryLogF WARNING "Failed to update battery info %s"++registerForAnyUPowerPropertiesChanged+  :: (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForAnyUPowerPropertiesChanged signalHandler = do+  client <- asks systemDBusClient+  lift $ DBus.registerForPropertiesChanged+      client+      matchAny { matchInterface = Just uPowerDeviceInterfaceName }+      signalHandler++-- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object+-- to returned "MVar" and "Chan" objects+monitorDisplayBattery :: TaffyIO (Chan BatteryInfo, MVar BatteryInfo)+monitorDisplayBattery = do+  lift $ batteryLog DEBUG "Starting Battery Monitor"+  client <- asks systemDBusClient+  infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty+  chan <- lift newChan+  taffyFork $ do+    ctx <- ask+    let warnOfFailedGetDevice err =+          batteryLogF WARNING "Failure getting DisplayBattery: %s" err >>+          return "/org/freedesktop/UPower/devices/DisplayDevice"+    displayPath <- lift $ getDisplayDevice client >>=+                   either warnOfFailedGetDevice return+    let doUpdate = updateBatteryInfo chan infoVar displayPath+        signalCallback _ _ changedProps _ =+          do+            batteryLogF DEBUG "Battery changed properties: %s" changedProps+            runReaderT doUpdate ctx+    _ <- registerForAnyUPowerPropertiesChanged signalCallback+    doUpdate+    return ()+  return (chan, infoVar)++-- | Call "refreshAllBatteries" whenever the BatteryInfo for the DisplayDevice+-- is updated. This handles cases where there is a race between the signal that+-- something is updated and the update actually being visible. See+-- https://github.com/taffybar/taffybar/issues/330 for more details.+refreshBatteriesOnPropChange :: TaffyIO ()+refreshBatteriesOnPropChange = ask >>= \ctx ->+  let updateIfRealChange _ _ changedProps _ =+        flip runReaderT ctx $+             when (any ((`notElem` ["UpdateTime", "Voltage"]) . fst) $+                       M.toList changedProps) $+                  lift (threadDelay 1000000) >> refreshAllBatteries+  in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange++-- | Request a refresh of all UPower batteries. This is only needed if UPower's+-- refresh mechanism is not working properly.+refreshAllBatteries :: TaffyIO ()+refreshAllBatteries = do+  client <- asks systemDBusClient+  let doRefresh path =+        batteryLogF DEBUG "Refreshing battery: %s" path >> refresh client path+  eerror <- runExceptT $ ExceptT getBatteryPaths >>= liftIO . mapM doRefresh+  let logRefreshError = batteryLogF ERROR "Failed to refresh battery: %s"+      logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s"++  void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      : System.Taffybar.Information.CPU2@@ -16,38 +17,15 @@ -- ----------------------------------------------------------------------------- -module System.Taffybar.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where--import Data.Maybe ( mapMaybe )-import Safe ( atMay, readDef, tailSafe )-import System.Taffybar.Information.StreamInfo ( getLoad, getParsedInfo )---- | Returns a two-element list containing relative system and user times--- calculated using two almost simultaneous samples of the @\/proc\/stat@ file--- for the given core (or all of them aggregated, if \"cpu\" is passed).-getCPULoad :: String -> IO [Double]-getCPULoad cpu = do-  load <- getLoad 0.05 $ getCPUInfo cpu-  case load of-    l0:l1:l2:_ -> return [ l0 + l1, l2 ]-    _ -> return []+module System.Taffybar.Information.CPU2 where --- | Returns a list containing temperatures of user given cpu cores.--- Use ["cpu1", "cpu2".."cpuN"] to get temperature of exact cores.--- Use ["cpu0"] to get common temperature.-getCPUTemp :: [String] -> IO [Int]-getCPUTemp cpus = do-  let cpus' = map (\s -> [last s]) cpus-  concat <$>-    mapM-      (\cpu ->-         getParsedInfo-           ("/sys/bus/platform/devices/coretemp.0/temp" ++-            show ((read cpu :: Int) + 1) ++ "_input")-           (\s -> [("temp", [(read s :: Int) `div` 1000])])-           "temp")-      cpus'-    --TODO and suppoprt for more than 1 physical cpu.+import Control.Monad+import Data.List+import Data.Maybe+import Safe+import System.Directory+import System.FilePath+import System.Taffybar.Information.StreamInfo  -- | Returns a list of 5 to 7 elements containing all the values available for -- the given core (or all of them aggregated, if "cpu" is passed).@@ -62,3 +40,36 @@   cpu <- s `atMay` 0   return (cpu, map (readDef (-1)) (tailSafe s)) +-- | Returns a two-element list containing relative system and user times+-- calculated using two almost simultaneous samples of the @\/proc\/stat@ file+-- for the given core (or all of them aggregated, if \"cpu\" is passed).+getCPULoad :: String -> IO [Double]+getCPULoad cpu = do+  load <- getLoad 0.05 $ getCPUInfo cpu+  case load of+    l0:l1:l2:_ -> return [ l0 + l1, l2 ]+    _ -> return []++-- | Get the directory in which core temperature files are kept.+getCPUTemperatureDirectory :: IO FilePath+getCPUTemperatureDirectory =+  (baseDir </>) . fromMaybe "hwmon0" .+  find (isPrefixOf "hwmon")+  <$> listDirectory baseDir+  where baseDir =+          "/"  </> "sys" </> "bus" </> "platform" </>+          "devices" </> "coretemp.0" </> "hwmon"++readCPUTempFile :: FilePath -> IO Double+readCPUTempFile cpuTempFilePath = (/ 1000) . read <$> readFile cpuTempFilePath++getAllTemperatureFiles :: FilePath -> IO [FilePath]+getAllTemperatureFiles temperaturesDirectory =+  filter (liftM2 (&&) (isPrefixOf "temp") (isSuffixOf "input")) <$>+         listDirectory temperaturesDirectory++getCPUTemperatures :: IO [(String, Double)]+getCPUTemperatures = do+  dir <- getCPUTemperatureDirectory+  let mkPair filename = (filename,) <$> readCPUTempFile (dir </> filename)+  getAllTemperatureFiles dir >>= mapM mkPair

@@ -1,11 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module System.Taffybar.Information.DBusClients where--import DBus.Generation-import System.Taffybar.Information.DBusObjects--generateClient playerGenerationParams playerInterface-generateSignalsFromInterface playerGenerationParams playerInterface--generateClient playerGenerationParams mprisInterface-generateSignalsFromInterface playerGenerationParams mprisInterface

@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module System.Taffybar.Information.DBusObjects where--import System.IO.Unsafe-import DBus.Generation-import DBus.Introspection-import Data.Maybe--{-# NOINLINE playerObject #-}-playerObject :: Object-playerObject = unsafePerformIO $-  head . maybeToList . parseXML "/" <$>-  readFile "dbus-xml/org.mpris.MediaPlayer2.Player.xml"--playerInterface :: Interface-playerInterface =-  head $ objectInterfaces playerObject--{-# NOINLINE mprisObject #-}-mprisObject :: Object-mprisObject = unsafePerformIO $-  head . maybeToList . parseXML "/" <$>-  readFile "dbus-xml/org.mpris.MediaPlayer2.xml"--mprisInterface :: Interface-mprisInterface =-  head $ objectInterfaces mprisObject--playerGenerationParams :: GenerationParams-playerGenerationParams =-  defaultGenerationParams-  { genTakeSignalErrorHandler = True-  , genObjectPath = Just "/org/mpris/MediaPlayer2"-  }

@@ -44,7 +44,7 @@   ) where  import Control.Applicative-import Control.Monad.Trans+import Control.Monad.Trans.Class import Data.Maybe import Data.Tuple import Data.Word

@@ -12,7 +12,8 @@  module System.Taffybar.Information.MPRIS2 where -import           Control.Monad.Trans+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Except import           Control.Monad.Trans.Maybe import qualified DBus@@ -23,8 +24,8 @@ import           Data.List import qualified Data.Map as M import           Data.Maybe-import           System.Taffybar.Information.DBusClients import           System.Log.Logger+import           System.Taffybar.DBus.Client.MPRIS2 import           Text.Printf  data NowPlaying = NowPlaying

@@ -20,7 +20,7 @@ import qualified Control.Concurrent.MVar as MV import           Control.Exception (catch, SomeException) import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.IO.Class import           Control.Monad.Trans.Maybe (MaybeT(..)) import           Data.Maybe ( mapMaybe ) import           Data.Time.Clock

@@ -17,25 +17,25 @@   )   where -import           Control.Concurrent-import           Control.Exception-import           Control.Monad-import           Control.Monad.Trans-import           Control.Monad.Trans.Maybe (MaybeT(..))-import           Data.Either.Combinators-import           Data.Typeable-import           Foreign hiding (void)-import           Foreign.C.Types-import           GHC.ForeignPtr-import           Graphics.X11.Xlib-import           Graphics.X11.Xlib.Extras+import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Either.Combinators+import Data.Typeable+import Foreign hiding (void)+import Foreign.C.Types+import GHC.ForeignPtr+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras        hiding (rawGetWindowProperty, getWindowProperty8,                getWindowProperty16, getWindowProperty32,                xGetWMHints, getWMHints, refreshKeyboardMapping)-import           Prelude-import           System.IO-import           System.IO.Unsafe-import           System.Timeout+import Prelude+import System.IO+import System.IO.Unsafe+import System.Timeout  foreign import ccall safe "XlibExtras.h XGetWMHints"     safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)

@@ -76,14 +76,10 @@ -- obtained values against the whole, where the whole is calculated as the sum -- of all the values in the probe. getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]-getLoad interval action = do-    deltas <- probe action interval-    return $ toRatioList deltas+getLoad interval action = toRatioList <$> probe action interval  -- | Similar to getLoad, but execute the given action only once and use the -- given IORef to calculate the result and to save the current value, so it -- can be reused in the next call. getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]-getAccLoad sample action = do-     deltas <- accProbe action sample-     return $ toRatioList deltas+getAccLoad sample action = toRatioList <$> accProbe action sample

@@ -48,7 +48,10 @@  import Codec.Binary.UTF8.String as UTF8 import qualified Control.Concurrent.MVar as MV-import Control.Monad.Reader+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader import Data.Bits (testBit, (.|.)) import Data.List.Split (endBy) import Graphics.X11.Xlib

@@ -31,7 +31,9 @@   , listDesktopEntries   ) where -import           Control.Monad.Except+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Except import           Data.Char import qualified Data.ConfigFile as CF import           Data.List

@@ -27,7 +27,7 @@   ) where  import           Control.Applicative-import           Control.Monad.Trans+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe import           Data.Char (toLower) import           Data.List

@@ -19,7 +19,7 @@   ) where  import qualified Control.Concurrent.MVar as MV-import           Control.Monad.Trans+import           Control.Monad.Trans.Class import           Data.List import           Data.Maybe import           Data.Unique

@@ -1,59 +0,0 @@-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.TransparentWindow--- Copyright   : (c) Ivan A. Malison--- License     : BSD3-style (see LICENSE)------ Maintainer  : Ivan A. Malison--- Stability   : unstable--- Portability : unportable------ Make a window transparent. Approach adapted from python code from--- https://stackoverflow.com/questions/3908565/how-to-make-gtk-window-background-transparent/33294727#33294727-------------------------------------------------------------------------------module System.Taffybar.TransparentWindow where--import           Control.Monad.Trans-import           Control.Monad.Trans.Reader-import           Data.GI.Base-import           Foreign.Ptr (castPtr)-import qualified GI.Cairo-import qualified GI.Gdk as Gdk-import qualified GI.Gtk as Gtk-import           Graphics.Rendering.Cairo-import           Graphics.Rendering.Cairo.Internal (Render(runRender))-import           Graphics.Rendering.Cairo.Types (Cairo(Cairo))---- | This function bridges gi-cairo with the hand-written cairo package. It--- takes a `GI.Cairo.Context` (as it appears in gi-cairo), and a `Render` action--- (as in the cairo lib), and renders the `Render` action into the given--- context.-renderWithContext :: GI.Cairo.Context -> Render () -> IO ()-renderWithContext ct r =-  withManagedPtr ct $ \p -> runReaderT (runRender r) (Cairo (castPtr p))--makeWindowTransparent :: MonadIO m => Gtk.Window -> m ()-makeWindowTransparent window = do-  screen <- Gtk.widgetGetScreen window-  visual <- Gdk.screenGetRgbaVisual screen-  Gtk.widgetSetVisual window visual-  Gtk.setWidgetAppPaintable window True-  _ <- Gtk.onWidgetDraw window transparentDraw-  return ()--transparentDraw :: Gtk.WidgetDrawCallback-transparentDraw context = do-  rGBA <- Gdk.newZeroRGBA-  Gdk.setRGBAAlpha rGBA 0.0-  Gdk.setRGBABlue rGBA 1.0-  Gdk.setRGBARed rGBA 1.0-  Gdk.setRGBAGreen rGBA 1.0-  Gdk.cairoSetSourceRgba context rGBA-  renderWithContext context $ do-    setOperator OperatorSource-    paint-    setOperator OperatorOver-  return False

@@ -14,16 +14,29 @@ import           Control.Arrow ((&&&)) import           Control.Concurrent import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Reader import           Data.Tuple.Sequence-import qualified GI.GLib as GLib-import qualified GI.Gdk as Gdk import           System.Exit (ExitCode (..)) import           System.Log.Logger import qualified System.Process as P import           Text.Printf +liftReader ::+  Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b+liftReader modifier action =+  ask >>= lift . modifier . runReaderT action++logPrintF+  :: (MonadIO m, Show t)+  => String -> Priority -> String -> t -> m ()+logPrintF logPath priority format toPrint =+  liftIO $ logM logPath priority $ printf format $ show toPrint++logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m ()+logPrintFDebug path = logPrintF path DEBUG+ infixl 4 ?? (??) :: Functor f => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab@@ -43,11 +56,6 @@ truncateString n xs   | length xs <= n = xs   | otherwise      = take n xs ++ "…"--runOnUIThread :: MonadIO m => IO a -> m ()-runOnUIThread action =-  void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $-       action >> return False  runCommandFromPath :: MonadIO m => [String] -> m (Either String String) runCommandFromPath = runCommand "/usr/bin/env"

@@ -1,10 +1,7 @@ module System.Taffybar.Widget   ( module System.Taffybar.Widget.Util   -- * "System.Taffybar.Widget.Battery"-  , batteryBarNew-  , batteryBarNewWithFormat-  , textBatteryNew-  , defaultBatteryConfig+  , module System.Taffybar.Widget.Battery    -- * "System.Taffybar.Widget.CPUMonitor"   , cpuMonitorNew

@@ -13,35 +13,31 @@ -- This module provides battery widgets using the UPower system -- service. ----- Currently it reports only the first battery it finds.  If it does--- not find a battery, it just returns an obnoxious widget with--- warning text in it.  Battery hotplugging is not supported.  These--- more advanced features could be supported if there is interest.+-- Currently it reports only the first battery it finds. If it does not find a+-- battery, it just returns an obnoxious widget with warning text in it. Battery+-- hotplugging is not supported. These more advanced features could be supported+-- if there is interest. ------------------------------------------------------------------------------module System.Taffybar.Widget.Battery-  ( batteryBarNew-  , batteryBarNewWithFormat-  , textBatteryNew-  , defaultBatteryConfig-  ) where+module System.Taffybar.Widget.Battery ( textBatteryNew, batteryIconNew ) where  import           Control.Applicative-import qualified Control.Exception.Enclosed as E-import           Control.Monad.Trans-import           Data.IORef+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Reader+import           Data.GI.Gtk.Threading import           Data.Int (Int64)-import           Graphics.UI.Gtk-import           Safe (atMay)-import qualified System.IO as IO-import           Text.Printf (printf)-import           Text.StringTemplate-+import qualified Data.Text as T+import           GI.Gtk+import qualified Graphics.UI.Gtk as Gtk2hs import           Prelude-+import           StatusNotifier.Tray (scalePixbufToSize)+import           System.Taffybar.Compat.GtkLibs+import           System.Taffybar.Context import           System.Taffybar.Information.Battery-import           System.Taffybar.Widget.Generic.PollingBar-import           System.Taffybar.Widget.Generic.PollingLabel-+import           System.Taffybar.Widget.Generic.AutoSizeImage+import           System.Taffybar.Widget.Generic.ChannelWidget+import           Text.Printf+import           Text.StringTemplate  -- | Just the battery info that will be used for display (this makes combining -- several easier).@@ -51,18 +47,6 @@   , status :: String   } deriving (Eq, Show) --- | Combination for 'BatteryWidgetInfo'.--- If one battery lacks time information, combination has no time information-combine :: [BatteryWidgetInfo] -> Maybe BatteryWidgetInfo-combine [] = Nothing-combine bs =-  Just-    BWI-    { seconds = sum <$> sequence (seconds <$> bs)-    , percent = sum (percent <$> bs) `div` length bs-    , status = status $ head bs-    }- -- | Format a duration expressed as seconds to hours and minutes formatDuration :: Maybe Int64 -> String formatDuration Nothing = ""@@ -71,49 +55,27 @@                                  minutes' = minutes `mod` 60                              in printf "%02d:%02d" hours minutes' -safeGetBatteryInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryInfo)-safeGetBatteryInfo mv i = do-  ctxt <- readIORef mv-  E.catchAny (getBatteryInfo ctxt) $ const reconnect-  where-    reconnect = do-      IO.hPutStrLn IO.stderr "reconnecting"-      ctxts <- batteryContextsNew-      let mctxt = ctxts `atMay` i-      case mctxt of-        Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower"-        Just ctxt ->-          writeIORef mv ctxt-      return Nothing--getBatteryWidgetInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryWidgetInfo)-getBatteryWidgetInfo r i = do-  minfo <- safeGetBatteryInfo r i-  case minfo of-    Nothing -> return Nothing-    Just info -> do-      let battPctNum :: Int-          battPctNum = floor (batteryPercentage info)-          battTime :: Maybe Int64-          battTime = case batteryState info of-            BatteryStateCharging    -> Just $ batteryTimeToFull info-            BatteryStateDischarging -> Just $ batteryTimeToEmpty info-            _                       -> Nothing-          battStatus :: String-          battStatus = case batteryState info of-            BatteryStateCharging    -> "Charging"-            BatteryStateDischarging -> "Discharging"-            _                       -> "✔"-      return . Just $ BWI { seconds = battTime-                          , percent = battPctNum-                          , status = battStatus-                          }-+getBatteryWidgetInfo :: BatteryInfo -> BatteryWidgetInfo+getBatteryWidgetInfo info =+  let battPctNum :: Int+      battPctNum = floor (batteryPercentage info)+      battTime :: Maybe Int64+      battTime =+        case batteryState info of+          BatteryStateCharging -> Just $ batteryTimeToFull info+          BatteryStateDischarging -> Just $ batteryTimeToEmpty info+          _ -> Nothing+      battStatus :: String+      battStatus =+        case batteryState info of+          BatteryStateCharging -> "Charging"+          BatteryStateDischarging -> "Discharging"+          _ -> "✔"+  in BWI {seconds = battTime, percent = battPctNum, status = battStatus}  -- | Given (maybe summarized) battery info and format: provides the string to display-formatBattInfo :: Maybe BatteryWidgetInfo -> String -> String-formatBattInfo Nothing _       =  ""-formatBattInfo (Just info) fmt =+formatBattInfo :: BatteryWidgetInfo -> String -> String+formatBattInfo info fmt =   let tpl = newSTMP fmt       tpl' = setManyAttrib [ ("percentage", (show . percent) info)                            , ("time", formatDuration (seconds info))@@ -121,95 +83,41 @@                            ] tpl   in render tpl' --- | Provides textual information regarding multiple batteries-battSumm :: [IORef BatteryContext] -> String -> IO String-battSumm rs fmt = do-  winfos <- traverse (uncurry getBatteryWidgetInfo) (rs `zip` [0..])-  let ws :: [BatteryWidgetInfo]-      ws = flatten winfos-      flatten []            = []-      flatten (Just a:as) = a:flatten as-      flatten (Nothing:as)  = flatten as-      combined = combine ws-  return $ formatBattInfo combined fmt----- | A simple textual battery widget that auto-updates once every polling period--- (specified in seconds). The displayed format is specified format string where--- $percentage$ is replaced with the percentage of battery remaining and $time$--- is replaced with the time until the battery is fully charged/discharged.------ Multiple battery values are combined as follows:--- - for time remaining, the largest value is used.--- - for percentage, the mean is taken.-textBatteryNew :: [IORef BatteryContext]-                    -> String -- ^ Display format-                    -> Double -- ^ Poll period in seconds-                    -> IO Widget-textBatteryNew [] _ _ =-  let lbl :: Maybe String-      lbl = Just "No battery"-  in toWidget <$> labelNew lbl-textBatteryNew rs fmt pollSeconds = do-    l <- pollingLabelNew "" pollSeconds (battSumm rs fmt)-    widgetShowAll l-    return l----- | Returns the current battery percent as a double in the range [0,--- 1]-battPct :: IORef BatteryContext -> Int -> IO Double-battPct i r = do-  minfo <- safeGetBatteryInfo i r-  case minfo of-    Nothing   -> return 0-    Just info -> return (batteryPercentage info / 100)---- | A default configuration for the graphical battery display.  The--- bar will be red when power is critical (< 10%), green if it is full--- (> 90%), and grey otherwise.------ You can customize this with any of the options in 'BarConfig'-defaultBatteryConfig :: BarConfig-defaultBatteryConfig =-  defaultBarConfig colorFunc-  where-    colorFunc pct-      | pct < 0.1 = (1, 0, 0)-      | pct < 0.9 = (0.5, 0.5, 0.5)-      | otherwise = (0, 1, 0)-+-- | A simple textual battery widget. The displayed format is specified format+-- string where $percentage$ is replaced with the percentage of battery+-- remaining and $time$ is replaced with the time until the battery is fully+-- charged/discharged.+textBatteryNew+  :: String -- ^ Display format+  -> TaffyIO Gtk2hs.Widget+textBatteryNew format = fromGIWidget =<< do+  chan <- getDisplayBatteryChan+  ctx <- ask+  let getLabelText info =+        T.pack $ formatBattInfo (getBatteryWidgetInfo info) format+      getBatteryInfoIO = runReaderT getDisplayBatteryInfo ctx+  liftIO $ do+    label <- getLabelText <$> getBatteryInfoIO >>= labelNew . Just+    let setMarkup text = postGUIASync $ labelSetMarkup label text+        updateWidget = setMarkup . getLabelText+    void $ onWidgetRealize label $ getLabelText <$> getBatteryInfoIO >>= setMarkup+    toWidget =<< channelWidgetNew label chan updateWidget --- | A fancy graphical battery widget that represents batteries as colored--- vertical bars (one per battery). There is also a textual percentage reppadout--- next to the bars, containing a summary of battery information.-batteryBarNew :: MonadIO m => BarConfig -> Double -> m Widget-batteryBarNew battCfg = liftIO .-  batteryBarNewWithFormat battCfg "$percentage$%"+themeLoadFlags :: [IconLookupFlags]+themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] --- | A battery bar constructor which allows using a custom format string in--- order to display more information, such as charging/discharging time and--- status. An example: "$percentage$% ($time$) - $status$".-batteryBarNewWithFormat :: MonadIO m => BarConfig -> String -> Double -> m Widget-batteryBarNewWithFormat battCfg formatString pollSeconds =+batteryIconNew :: TaffyIO Gtk2hs.Widget+batteryIconNew = fromGIWidget =<< do+  chan <- getDisplayBatteryChan+  ctx <- ask   liftIO $ do-    battCtxt <- batteryContextsNew-    case battCtxt of-      [] -> do-        let lbl :: Maybe String-            lbl = Just "No battery"-        toWidget <$> labelNew lbl-      cs -> do-        b <- hBoxNew False 1-        rs <- traverse newIORef cs-        txt <- textBatteryNew rs formatString pollSeconds-        let ris :: [(IORef BatteryContext, Int)]-            ris = rs `zip` [0 ..]-        bars <--          traverse-            (\(i, r) -> pollingBarNew battCfg pollSeconds (battPct i r))-            ris-        mapM_ (\bar -> boxPackStart b bar PackNatural 0) bars-        boxPackStart b txt PackNatural 0-        widgetShowAll b-        return (toWidget b)+    image <- imageNew+    defaultTheme <- iconThemeGetDefault+    let getCurrentBatteryIconNameString =+          T.pack . batteryIconName <$> runReaderT getDisplayBatteryInfo ctx+        setIconForSize size = do+          name <- getCurrentBatteryIconNameString+          iconThemeLoadIcon defaultTheme name size themeLoadFlags >>=+                            traverse (scalePixbufToSize size OrientationHorizontal)+    updateImage <- autoSizeImage image setIconForSize OrientationHorizontal+    toWidget =<< channelWidgetNew image chan (const $ postGUIASync updateImage)

@@ -14,7 +14,7 @@ -------------------------------------------------------------------------------- module System.Taffybar.Widget.CPUMonitor where -import Control.Monad.Trans+import Control.Monad.IO.Class import Data.IORef import Graphics.UI.Gtk import System.Taffybar.Information.CPU2 (getCPUInfo)

@@ -14,7 +14,7 @@  module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where -import           Control.Monad.Trans+import           Control.Monad.IO.Class import qualified Graphics.UI.Gtk as Gtk import           System.Log.Logger import           System.Taffybar.Util@@ -37,7 +37,7 @@  runCommandWithDefault :: FilePath -> [String] -> String -> IO String runCommandWithDefault cmd args def =-  runCommand cmd args >>= either logError return+  filter (/= '\n') <$> (runCommand cmd args >>= either logError return)   where logError err =           logM "System.Taffybar.Widget.CommandRunner" ERROR                (printf "Got error in CommandRunner %s" err) >> return def

@@ -14,7 +14,16 @@   outerBox <- Gtk.eventBoxNew   Gtk.containerAdd innerBox contents   Gtk.containerAdd outerBox innerBox-  _ <- widgetSetClass innerBox "InnerPad"-  _ <- widgetSetClass outerBox "OuterPad"-  Gtk.widgetShowAll outerBox+  _ <- widgetSetClass innerBox "inner-pad"+  _ <- widgetSetClass outerBox "outer-pad"+  Gtk.widgetShow outerBox+  Gtk.widgetShow innerBox   return $ Gtk.toWidget outerBox++buildContentsBox :: (Gtk.WidgetClass widget, MonadIO m) => widget -> m Gtk.Widget+buildContentsBox widget = liftIO $ do+  contents <- Gtk.hBoxNew False 0+  Gtk.containerAdd contents widget+  _ <- widgetSetClass contents "contents"+  Gtk.widgetShowAll contents+  buildPadBox contents

@@ -15,7 +15,7 @@  module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where -import           Control.Monad.Trans+import           Control.Monad.IO.Class import qualified Graphics.UI.Gtk as Gtk import           System.Taffybar.Information.DiskIO ( getDiskTransfer ) import           System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew )

@@ -16,7 +16,7 @@  module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where -import           Control.Monad.Trans+import           Control.Monad.IO.Class import qualified Graphics.UI.Gtk as Gtk import           System.Process ( readProcess ) import           System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )

@@ -31,7 +31,7 @@ import           Control.Concurrent import           Control.Concurrent.STM import           Control.Monad ( forever, void )-import           Control.Monad.Trans+import           Control.Monad.IO.Class import           DBus import           DBus.Client import           Data.Foldable

@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.Widget.Generic.AutoSizeImage where++import qualified Control.Concurrent.MVar as MV+import           Control.Monad+import           Control.Monad.IO.Class+import qualified Data.GI.Gtk.Threading as Gtk+import           Data.Int+import           Data.Maybe+import qualified GI.Gdk as Gdk+import           GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk as Gtk+import           StatusNotifier.Tray (scalePixbufToSize)+import           System.Log.Logger+import           System.Taffybar.Widget.Util+import           Text.Printf++imageLog :: Priority -> String -> IO ()+imageLog = logM "System.Taffybar.Widget.Generic.AutoSizeImage"++borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border]+borderFunctions =+  [ Gtk.styleContextGetPadding+  , Gtk.styleContextGetMargin+  , Gtk.styleContextGetBorder+  ]++data BorderInfo = BorderInfo+  { borderTop :: Int16+  , borderBottom :: Int16+  , borderLeft :: Int16+  , borderRight :: Int16+  } deriving (Show, Eq)++borderInfoZero :: BorderInfo+borderInfoZero = BorderInfo 0 0 0 0++borderWidth, borderHeight :: BorderInfo -> Int16+borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo+borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo++toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo+toBorderInfo border =+  BorderInfo+  <$> Gtk.getBorderTop border+  <*> Gtk.getBorderBottom border+  <*> Gtk.getBorderLeft border+  <*> Gtk.getBorderRight border++addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo+addBorderInfo+  (BorderInfo t1 b1 l1 r1)+  (BorderInfo t2 b2 l2 r2)+    = BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + r2)++-- | Get the total size of the border (the sum of its assigned margin, border+-- and padding values) that will be drawn for a widget as a "BorderInfo" record.+getBorderInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo+getBorderInfo widget = liftIO $ do+  stateFlags <- Gtk.widgetGetStateFlags widget+  styleContext <- Gtk.widgetGetStyleContext widget++  let getBorderInfoFor borderFn =+        borderFn styleContext stateFlags >>= toBorderInfo+      combineBorderInfo lastSum fn =+        addBorderInfo lastSum <$> getBorderInfoFor fn++  foldM combineBorderInfo borderInfoZero borderFunctions++-- | Get the actual allocation for a "Gtk.Widget", accounting for the size of+-- its CSS assined margin, border and padding values.+getContentAllocation+  :: (MonadIO m, Gtk.IsWidget a)+  => a -> BorderInfo -> m Gdk.Rectangle+getContentAllocation widget borderInfo = do+  allocation <- Gtk.widgetGetAllocation widget+  currentWidth <- Gdk.getRectangleWidth allocation+  currentHeight <- Gdk.getRectangleHeight allocation+  currentX <- Gdk.getRectangleX allocation+  currentY <- Gdk.getRectangleX allocation++  Gdk.setRectangleWidth allocation $ max 1 $+     currentWidth - fromIntegral (borderWidth borderInfo)+  Gdk.setRectangleHeight allocation $ max 1 $+     currentHeight - fromIntegral (borderHeight borderInfo)+  Gdk.setRectangleX allocation $+     currentX + fromIntegral (borderLeft borderInfo)+  Gdk.setRectangleY allocation $+     currentY + fromIntegral (borderTop borderInfo)++  return allocation++-- | Automatically update the "Gdk.Pixbuf" of a "Gtk.Image" using the provided+-- action whenever the "Gtk.Image" is allocated. Returns an action that forces a+-- refresh of the image through the provided action.+autoSizeImage+  :: MonadIO m+  => Gtk.Image+  -> (Int32 -> IO (Maybe Gdk.Pixbuf))+  -> Gtk.Orientation+  -> m (IO ())+autoSizeImage image getPixbuf orientation = liftIO $ do+  case orientation of+    Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand image True+    _ -> Gtk.widgetSetHexpand image True++  _ <- widgetSetClassGI image "auto-size-image"++  lastAllocation <- MV.newMVar 0+  -- XXX: Gtk seems to report information about padding etc inconsistently,+  -- which is why we look it up once, at startup. This means that we won't+  -- properly react to changes to these values, which could be a pretty nasty+  -- gotcha for someone down the line. :(+  borderInfo <- getBorderInfo image++  let setPixbuf force allocation = do+        _width <- Gdk.getRectangleWidth allocation+        _height <- Gdk.getRectangleHeight allocation++        let width = max 1 $ _width - fromIntegral (borderWidth borderInfo)+            height = max 1 $ _height - fromIntegral (borderHeight borderInfo)+            size =+              case orientation of+                Gtk.OrientationHorizontal -> height+                _ -> width++        previousSize <- MV.readMVar lastAllocation++        when (size /= previousSize || force) $ do+          MV.modifyMVar_ lastAllocation $ const $ return size++          pixbuf <- getPixbuf size+          pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf+          pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf+          let pbSize = case orientation of+                         Gtk.OrientationHorizontal -> pbHeight+                         _ -> pbWidth+              logLevel = if pbSize <= size then DEBUG else WARNING++          imageLog logLevel $+                 printf "Allocating image: size %s, width %s, \+                         \ height %s, aw: %s, ah: %s, pbw: %s pbh: %s"+                 (show size)+                 (show width)+                 (show height)+                 (show _width)+                 (show _height)+                 (show pbWidth)+                 (show pbHeight)++          Gtk.imageSetFromPixbuf image pixbuf+          Gtk.postGUIASync $ Gtk.widgetQueueResize image++  _ <- Gtk.onWidgetSizeAllocate image $ setPixbuf False+  return $ Gtk.widgetGetAllocation image >>= setPixbuf True++-- | Make a new "Gtk.Image" and call "autoSizeImage" on it. Automatically scale+-- the "Gdk.Pixbuf" returned from the provided getter to the appropriate size+-- using "scalePixbufToSize".+autoSizeImageNew+  :: MonadIO m+  => (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image+autoSizeImageNew getPixBuf orientation = do+  image <- Gtk.imageNew+  void $ autoSizeImage image+         (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation))+         orientation+  return image

@@ -2,7 +2,7 @@  import Control.Concurrent import Control.Monad-import Control.Monad.Trans+import Control.Monad.IO.Class import Graphics.UI.Gtk import System.Taffybar.Widget.Generic.Graph 

@@ -0,0 +1,16 @@+module System.Taffybar.Widget.Generic.ChannelWidget where++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import GI.Gtk++channelWidgetNew :: (MonadIO m, IsWidget w) => w -> Chan a -> (a -> IO ()) -> m w+channelWidgetNew widget channel updateWidget = do+  void $ onWidgetRealize widget $ do+    ourChan <- dupChan channel+    processingThreadId <- forkIO $ forever $+      readChan ourChan >>= updateWidget+    void $ onWidgetUnrealize widget $ killThread processingThreadId+  widgetShowAll widget+  return widget

@@ -1,8 +1,8 @@ module System.Taffybar.Widget.Generic.DynamicMenu where -import           Control.Monad.Trans+import           Control.Monad.IO.Class import qualified GI.Gtk as Gtk-import           System.Taffybar.Widget.Util+import           System.Log.Logger  data DynamicMenuConfig = DynamicMenuConfig   { dmClickWidget :: Gtk.Widget@@ -10,21 +10,20 @@   }  dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget-dynamicMenuNew DynamicMenuConfig { dmClickWidget = clickWidget-                                 , dmPopulateMenu = populateMenu-                                 } = do-  bar <- Gtk.menuBarNew+dynamicMenuNew DynamicMenuConfig+                 { dmClickWidget = clickWidget+                 , dmPopulateMenu = populateMenu+                 } = do+  button <- Gtk.menuButtonNew   menu <- Gtk.menuNew-  menuItem <- Gtk.menuItemNew-  Gtk.containerAdd menuItem clickWidget-  Gtk.menuItemSetSubmenu menuItem $ Just menu-  Gtk.containerAdd bar menuItem-  _ <- widgetSetClassGI menu "Menu"+  Gtk.containerAdd button clickWidget+  Gtk.menuButtonSetPopup button $ Just menu -  _ <- Gtk.onMenuItemActivate menuItem $ populateMenu menu-  _ <- Gtk.onMenuItemDeselect menuItem $ emptyMenu menu+  _ <- Gtk.onButtonPressed button $ emptyMenu menu >> populateMenu menu -  Gtk.toWidget bar+  Gtk.widgetShowAll button++  Gtk.toWidget button  emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m () emptyMenu menu =

@@ -24,7 +24,7 @@  import           Control.Concurrent import           Control.Monad ( when )-import           Control.Monad.Trans+import           Control.Monad.IO.Class import           Data.Foldable ( mapM_ ) import           Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) import qualified Data.Sequence as S

@@ -14,7 +14,7 @@ import           Control.Concurrent import qualified Control.Exception.Enclosed as E import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.IO.Class import           Graphics.UI.Gtk import           System.Taffybar.Util import           System.Taffybar.Widget.Generic.Graph

@@ -1,4 +1,3 @@-{-# LANGUAGE TupleSections #-} -- | This is a simple text widget that updates its contents by calling -- a callback at a set interval. module System.Taffybar.Widget.Generic.PollingLabel@@ -6,15 +5,16 @@   , pollingLabelNewWithTooltip   ) where -import           Control.Monad.Trans import           Control.Exception.Enclosed as E import           Control.Monad+import           Control.Monad.IO.Class+import           Data.GI.Gtk.Threading import qualified Data.Text as T import           GI.Gtk import qualified Graphics.UI.Gtk as Gtk2hs import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Util-import           System.Taffybar.Widget.Decorators+import           System.Taffybar.Widget.Util  -- | Create a new widget that updates itself at regular intervals.  The -- function@@ -45,15 +45,20 @@   -> IO (String, Maybe String) -- ^ Command to run to get the input string   -> m Gtk2hs.Widget pollingLabelNewWithTooltip initialString interval cmd =-  liftIO $ buildPadBox =<< fromGIWidget =<< do-    l <- labelNew $ Just $ T.pack initialString+  liftIO $ fromGIWidget =<< do+    grid <- gridNew+    label <- labelNew $ Just $ T.pack initialString      let updateLabel (labelStr, tooltipStr) =-          runOnUIThread $ do-            labelSetMarkup l $ T.strip $ T.pack labelStr-            widgetSetTooltipMarkup l $ T.pack <$> tooltipStr+          postGUIASync $ do+            labelSetMarkup label $ T.pack labelStr+            widgetSetTooltipMarkup label $ T.pack <$> tooltipStr -    _ <- onWidgetRealize l $ void $ foreverWithDelay interval $+    _ <- onWidgetRealize label $ void $ foreverWithDelay interval $       E.tryAny cmd >>= either (const $ return ()) updateLabel -    toWidget l+    vFillCenter label+    vFillCenter grid+    containerAdd grid label+    widgetShowAll grid+    toWidget grid

@@ -14,7 +14,7 @@  import           Control.Concurrent import           Control.Monad-import           Control.Monad.Trans+import           Control.Monad.IO.Class import qualified Graphics.Rendering.Cairo as C import           Graphics.UI.Gtk import           System.Taffybar.Widget.Util

@@ -1,34 +1,36 @@ ----------------------------------------------------------------------------- -- | -- Module      : System.Taffybar.Widget.Layout--- Copyright   : (c) José A. Romero L.+-- Copyright   : (c) Ivan Malison -- License     : BSD3-style (see LICENSE) ----- Maintainer  : José A. Romero L. <escherdragon@gmail.com>+-- Maintainer  : Ivan Malison <IvanMalison@gmail.com> -- Stability   : unstable -- Portability : unportable ----- Simple text widget that shows the XMonad layout used in the currently--- active workspace, and that allows to change it by clicking with the--- mouse: left-click to switch to the next layout in the list, right-click--- to switch to the first one (as configured in @xmonad.hs@)+-- Simple text widget that shows the XMonad layout used in the currently active+-- workspace, and that allows to change it by clicking with the mouse:+-- left-click to switch to the next layout in the list, right-click to switch to+-- the first one (as configured in @xmonad.hs@) ----------------------------------------------------------------------------- -module System.Taffybar.Widget.Layout (+module System.Taffybar.Widget.Layout+  (   -- * Usage   -- $usage     LayoutConfig(..)   , defaultLayoutConfig   , layoutNew-) where+  ) where -import Control.Monad.Trans-import Control.Monad.Reader+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Abstract.Widget as W-import System.Taffybar.Information.X11DesktopInfo-import System.Taffybar.Widget.Util-import System.Taffybar.Context+import           System.Taffybar.Context+import           System.Taffybar.Information.X11DesktopInfo+import           System.Taffybar.Util+import           System.Taffybar.Widget.Util  -- $usage --

@@ -9,68 +9,84 @@ -- Stability   : unstable -- Portability : unportable ----- This is a "Now Playing" widget that listens for MPRIS events on DBus. Various--- media players implement this. This widget works with version 2 of the MPRIS--- protocol (https://specifications.freedesktop.org/mpris-spec/latest/).+-- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You+-- can find the MPRIS2 specification here at+-- (https://specifications.freedesktop.org/mpris-spec/latest/). ----------------------------------------------------------------------------- module System.Taffybar.Widget.MPRIS2 ( mpris2New ) where +import           Control.Arrow import qualified Control.Concurrent.MVar as MV import           Control.Monad-import           Control.Monad.Trans-import           Control.Monad.Trans.Maybe+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except import           Control.Monad.Trans.Reader import           DBus import           DBus.Client import           DBus.Internal.Types import qualified DBus.TH as DBus import           Data.Coerce-import           Data.Either.Combinators+import qualified Data.GI.Gtk.Threading as Gtk import           Data.List import qualified Data.Text as T import qualified GI.Gtk as Gtk import qualified Graphics.UI.Gtk as Gtk2hs+import           System.Log.Logger import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Context-import           System.Taffybar.Information.DBusClients+import           System.Taffybar.DBus.Client.MPRIS2 import           System.Taffybar.Information.MPRIS2 import           System.Taffybar.Information.XDG.DesktopEntry import           System.Taffybar.Util+import           System.Taffybar.Widget.Generic.AutoSizeImage import           System.Taffybar.Widget.Util import           Text.Printf +mprisLog :: (MonadIO m, Show t) => Priority -> String -> t -> m ()+mprisLog = logPrintF "System.Taffybar.Widget.MPRIS2"+ data MPRIS2PlayerWidget = MPRIS2PlayerWidget   { playerLabel :: Gtk.Label   , playerGrid :: Gtk.Grid   }  mpris2New :: TaffyIO Gtk2hs.Widget-mpris2New = asks dbusClient >>= \client -> lift $ fromGIWidget =<< do+mpris2New = asks sessionDBusClient >>= \client -> lift $ fromGIWidget =<< do   grid <- Gtk.gridNew-  alignCenter grid+  vFillCenter grid   playerWidgetsVar <- MV.newMVar []   let     newPlayerWidget :: BusName -> IO MPRIS2PlayerWidget     newPlayerWidget busName =       do-        -- TODO: Size the image dynamically-        pixbuf <--          maybe (loadIcon 20 "play.svg") return =<< runMaybeT-          (   MaybeT (rightToMaybe <$> getDesktopEntry client busName)-          >>= MaybeT . getDirectoryEntryDefault-          >>= MaybeT . getImageForDesktopEntry 20-          )+        let logErrorAndLoadDefault size err =+              mprisLog WARNING "Failed to get MPRIS icon: %s" err >>+              mprisLog WARNING "MPRIS failure for: %s" busName >>+                       loadIcon size "play.svg"+            makeExcept ::+              String -> (a -> IO (Maybe b)) -> a -> ExceptT String IO b+            makeExcept errorString actionBuilder =+              ExceptT . fmap (maybeToEither errorString) . actionBuilder+            loadIconAtSize size =+              either (logErrorAndLoadDefault size) return =<< runExceptT+              (   ExceptT (left show <$> getDesktopEntry client busName)+              >>= makeExcept "Failed to get desktop entry"+                  getDirectoryEntryDefault+              >>= makeExcept "Failed to get image"+                    (getImageForDesktopEntry size)+              ) -        image <- Gtk.imageNewFromPixbuf $ Just pixbuf+        image <- autoSizeImageNew loadIconAtSize Gtk.OrientationHorizontal         playerBox <- Gtk.gridNew         label <- Gtk.labelNew Nothing          Gtk.containerAdd playerBox image         Gtk.containerAdd playerBox label-        alignCenter playerBox+        vFillCenter playerBox -        Gtk.widgetShowAll playerBox         Gtk.containerAdd grid playerBox+        Gtk.widgetSetVexpand playerBox True         Gtk.widgetHide playerBox         return MPRIS2PlayerWidget {playerLabel = label, playerGrid = playerBox} @@ -86,30 +102,33 @@           setNowPlaying playerWidget           return $ (busName, playerWidget):children         Just playerWidget -> setNowPlaying playerWidget >> return children-      where setNowPlaying MPRIS2PlayerWidget {playerLabel = label , playerGrid = playerBox} =-              do+      where setNowPlaying+              MPRIS2PlayerWidget+              { playerLabel = label+              , playerGrid = playerBox+              } = do+                logPrintF "System.Taffybar.Widget.MPRIS2"+                          DEBUG "Setting state %s" nowPlaying                 Gtk.labelSetMarkup label $ playingText 20 30 nowPlaying                 if status == "Playing"-                then-                  Gtk.widgetShow playerBox-                else-                  Gtk.widgetHide playerBox+                then Gtk.widgetShowAll playerBox+                else Gtk.widgetHide playerBox      updatePlayerWidgets nowPlayings playerWidgets = do       newWidgets <- foldM updatePlayerWidget playerWidgets nowPlayings       let existingBusNames = map npBusName nowPlayings-          noInfoPlayerWidgets = filter ((`notElem` existingBusNames) . fst) newWidgets+          noInfoPlayerWidgets =+            filter ((`notElem` existingBusNames) . fst) newWidgets       mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets       return newWidgets      updatePlayerWidgetsVar nowPlayings =-      MV.modifyMVar_ playerWidgetsVar (updatePlayerWidgets nowPlayings)+      MV.modifyMVar_ playerWidgetsVar $+          Gtk.postGUISync . updatePlayerWidgets nowPlayings      doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar     signalCallback _ _ _ _ = doUpdate-    propMatcher =-        matchAny-        { matchPath = Just "/org/mpris/MediaPlayer2" }+    propMatcher = matchAny { matchPath = Just "/org/mpris/MediaPlayer2" }      handleNameOwnerChanged _ name _ _ = do       busNames <- map (coerce . fst) <$> MV.readMVar playerWidgetsVar@@ -120,14 +139,17 @@       DBus.registerForPropertiesChanged client propMatcher signalCallback     nameHandler <-       DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged+    doUpdate     void $ Gtk.onWidgetUnrealize grid $          removeMatch client updateHandler >> removeMatch client nameHandler   Gtk.widgetShow grid-  doUpdate   Gtk.toWidget grid  playingText :: Int -> Int -> NowPlaying -> T.Text-playingText artistMax songMax NowPlaying { npArtists = artists, npTitle = title } = T.pack $-  Gtk2hs.escapeMarkup $ printf "%s - %s"-       (truncateString artistMax $ intercalate "," artists)-       (truncateString songMax title)+playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} =+  T.pack $+  Gtk2hs.escapeMarkup $+  printf+    "%s - %s"+    (truncateString artistMax $ intercalate "," artists)+    (truncateString songMax title)

@@ -1,104 +0,0 @@-{-# LANGUAGE TupleSections #-}--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.Widget.NetMonitor--- Copyright   : (c) José A. Romero L.--- License     : BSD3-style (see LICENSE)------ Maintainer  : José A. Romero L. <escherdragon@gmail.com>--- Stability   : unstable--- Portability : unportable------ Simple text widget that displays incoming\/outgoing network traffic over--- one selected interface, as provided by the "System.Taffybar.Information.Network"--- module.-----------------------------------------------------------------------------------module System.Taffybar.Widget.NetMonitor-  {-# DEPRECATED "Use System.Taffybar.Widget.Text.NetworkMonitor instead" #-}-  ( defaultNetFormat-  , netMonitorMultiNew-  , netMonitorMultiNewWith-  , netMonitorNew-  , netMonitorNewWith-  , showInfo-  ) where--import           Control.Monad.Trans-import           Data.IORef-import           Data.Maybe (catMaybes)-import qualified Data.Traversable as T-import           Graphics.UI.Gtk-import           System.Taffybar.Information.Network (getNetInfo)-import           System.Taffybar.Widget.Generic.PollingLabel-import           System.Taffybar.Widget.Text.NetworkMonitor---- | Creates a new network monitor widget. It consists of two 'PollingLabel's,--- one for incoming and one for outgoing traffic fed by regular calls to--- 'getNetInfo'.-netMonitorNew-  :: MonadIO m-  => Double -- ^ Polling interval (in seconds, e.g. 1.5)-  -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")-  -> m Widget-netMonitorNew interval interface = liftIO $ netMonitorMultiNew interval [interface]---- | Creates a new network monitor widget with custom template and precision.--- Similar to 'netMonitorNew'.------ The format template currently supports four units: bytes,--- kilobytes, megabytes, and auto.-netMonitorNewWith-  :: MonadIO m-  => Double -- ^ Polling interval (in seconds, e.g. 1.5)-  -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")-  -> Int -- ^ Precision for an output-  -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$-  -> m Widget-netMonitorNewWith interval interface prec template =-  liftIO $ netMonitorMultiNewWith interval [interface] prec template---- | Like `netMonitorNew` but allows specification of multiple interfaces.---   Interfaces are allowed to not exist at all (e.g. unplugged usb ethernet),---   the resulting speed is the speed of all available interfaces summed up. So---   you get your network speed regardless of which interface you are currently---   using.-netMonitorMultiNew-  :: MonadIO m-  => Double -- ^ Polling interval (in seconds, e.g. 1.5)-  -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")-  -> m Widget-netMonitorMultiNew interval interfaces =-  liftIO $ netMonitorMultiNewWith interval interfaces 3 defaultNetFormat---- | Like `newMonitorNewWith` but for multiple interfaces.-netMonitorMultiNewWith-  :: MonadIO m-  => Double -- ^ Polling interval (in seconds, e.g. 1.5)-  -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")-  -> Int -- ^ Precision for an output-  -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$-  -> m Widget-netMonitorMultiNewWith interval interfaces prec template = liftIO $ do-  interfaceRefs <- T.forM interfaces $ \i -> (i,) <$> newIORef (0, 0)-  let showResult = showInfo template prec <$> calculateNetUse interfaceRefs-  label <- pollingLabelNew "" interval showResult-  widgetShowAll label-  return (toWidget label)-  where-    calculateNetUse ifaceRefs = do-      mIfaceInfos <- T.forM ifaceRefs $ \(i, ref) ->-        fmap (\ifaceInfo -> (ref, ifaceInfo)) <$> getNetInfo i-      speeds <- T.forM (catMaybes mIfaceInfos) $ \(ref, ifaceInfo) -> do-        let ii = case ifaceInfo of-              [info1, info2] -> (info1, info2)-              _ -> (0, 0)-        calcSpeed interval ref ii-      return $ foldr (\(d, u) (dsum, usum) -> (dsum + d, usum + u)) (0, 0) speeds--calcSpeed :: Double -> IORef (Int, Int) -> (Int, Int) -> IO (Double, Double)-calcSpeed interval sample result@(r1, r2) = do-    (s1, s2) <- readIORef sample-    writeIORef sample result-    return (max 0 (fromIntegral (r1 - s1) / interval), max 0 (fromIntegral (r2 - s2) / interval))

@@ -12,8 +12,8 @@   logBase base (min value maxValue) / actualMax     where actualMax = logBase base maxValue -netMonitorGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO Widget-netMonitorGraphNew config interfaces = do+networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO Widget+networkGraphNew config interfaces = do   NetworkInfoChan chan <- getNetworkChan   let filterFn = maybe (const True) (flip elem) interfaces       getUpDown = sumSpeeds . map snd . filter (filterFn . fst)

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      : System.Taffybar.Widget.SNITray@@ -10,7 +11,7 @@ ----------------------------------------------------------------------------- module System.Taffybar.Widget.SNITray where -import           Control.Monad.Trans+import           Control.Monad.Trans.Class import           Control.Monad.Trans.Reader import qualified GI.Gtk import           Graphics.UI.GIGtkStrut@@ -20,12 +21,13 @@ import           System.Posix.Process import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Context+import           System.Taffybar.Widget.Util import           Text.Printf  getHost :: TaffyIO H.Host getHost = getStateDefault $ do   pid <- lift getProcessID-  client <- asks dbusClient+  client <- asks sessionDBusClient   Just host <- lift $ H.build H.defaultParams      { H.dbusClient = Just client      , H.uniqueIdentifier = printf "taffybar-%s" $ show pid@@ -37,7 +39,7 @@ sniTrayNew :: TaffyIO Gtk.Widget sniTrayNew = do   host <- getHost-  client <- asks dbusClient+  client <- asks sessionDBusClient   lift $ do     tray <-       buildTray@@ -49,4 +51,6 @@         , trayIconExpand = False         , trayAlignment = End         }+    _ <- widgetSetClassGI tray "sni-tray"+    GI.Gtk.widgetShowAll tray     GI.Gtk.toWidget tray >>= fromGIWidget

@@ -10,7 +10,7 @@   , ClockConfig(..)   ) where -import           Control.Monad.Trans+import           Control.Monad.IO.Class import           Data.Time.Calendar ( toGregorian ) import qualified Data.Time.Clock as Clock import           Data.Time.Format

@@ -2,7 +2,7 @@ -- very well since it is based on eggtraymanager. module System.Taffybar.Widget.Systray {-# DEPRECATED "Use SNITray instead" #-} ( systrayNew ) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Graphics.UI.Gtk import Graphics.UI.Gtk.Misc.TrayManager 

@@ -1,14 +1,18 @@ module System.Taffybar.Widget.Text.NetworkMonitor where -import Control.Monad-import Control.Concurrent-import Control.Monad.Trans-import Graphics.UI.Gtk-import System.Taffybar.Context-import System.Taffybar.Hooks-import System.Taffybar.Information.Network-import Text.Printf-import Text.StringTemplate+import           Control.Monad+import           Control.Monad.Trans.Class+import           Data.GI.Gtk.Threading+import qualified Data.Text as T+import           GI.Gtk+import qualified Graphics.UI.Gtk as Gtk2hs+import           System.Taffybar.Compat.GtkLibs+import           System.Taffybar.Context+import           System.Taffybar.Hooks+import           System.Taffybar.Information.Network+import           System.Taffybar.Widget.Generic.ChannelWidget+import           Text.Printf+import           Text.StringTemplate  defaultNetFormat :: String defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"@@ -54,17 +58,14 @@         p :: Int         p = max 0 $ floor $ fromIntegral prec - logBase 10 v -networkMonitorNew :: String -> Maybe [String] -> TaffyIO Widget-networkMonitorNew template interfaces = do+networkMonitorNew :: String -> Maybe [String] -> TaffyIO Gtk2hs.Widget+networkMonitorNew template interfaces = fromGIWidget =<< do   NetworkInfoChan chan <- getNetworkChan   let filterFn = maybe (const True) (flip elem) interfaces-  liftIO $ do-    ourChan <- dupChan chan-    label <- labelNew (Nothing :: Maybe String)-    widgetShowAll label-    _ <- on label realize $ void $ forkIO $ forever $ do-        (up, down) <- sumSpeeds . map snd . filter (filterFn . fst) <$> readChan ourChan-        let labelString =-              showInfo template 3 (fromRational down, fromRational up)-        postGUIAsync $ labelSetMarkup label labelString-    return $ toWidget label+  label <- lift $ labelNew Nothing+  void $ channelWidgetNew label chan $ \speedInfo ->+    let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo+        labelString =+          T.pack $ showInfo template 3 (fromRational down, fromRational up)+    in postGUIASync $ labelSetMarkup label labelString+  toWidget label

@@ -23,17 +23,17 @@ import qualified Data.Text as T import           Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as GI+import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import qualified GI.Gtk import           Graphics.UI.Gtk as Gtk import           Graphics.UI.Gtk.General.StyleContext import           System.Directory import           System.FilePath.Posix-import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Information.XDG.DesktopEntry+import           System.Taffybar.Util import           Text.Printf-import qualified GI.GdkPixbuf.Objects.Pixbuf as PB -import Paths_taffybar ( getDataDir )+import           Paths_taffybar ( getDataDir )  -- | Execute the given action as a response to any of the given types -- of mouse button clicks.@@ -113,10 +113,10 @@   styleContextAddClass context klass   return widget -widgetSetClassGI :: (GI.Gtk.IsWidget b, MonadIO m) => b -> String -> m b+widgetSetClassGI :: (GI.Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b widgetSetClassGI widget klass =-  GI.Gtk.toWidget widget >>= fromGIWidget >>= flip widgetSetClass klass >>-    return widget+  GI.Gtk.widgetGetStyleContext widget >>=+    flip GI.Gtk.styleContextAddClass klass >> return widget  themeLoadFlags :: [GI.Gtk.IconLookupFlags] themeLoadFlags =@@ -131,6 +131,8 @@   MaybeT $ do     iconTheme <- GI.Gtk.iconThemeGetDefault     hasIcon <- GI.Gtk.iconThemeHasIcon iconTheme iconNameText+    logPrintFDebug "System.Taffybar.Widget.Util" "Entry: %s" entry+    logPrintFDebug "System.Taffybar.Widget.Util" "Icon present: %s" hasIcon     if hasIcon     then       GI.Gtk.iconThemeLoadIcon iconTheme iconNameText size themeLoadFlags@@ -145,6 +147,12 @@   GI.Gtk.setWidgetValign widget GI.Gtk.AlignCenter >>   GI.Gtk.setWidgetHalign widget GI.Gtk.AlignCenter +vFillCenter :: (GI.Gtk.IsWidget o, MonadIO m) => o -> m ()+vFillCenter widget =+  GI.Gtk.widgetSetVexpand widget True >>+  GI.Gtk.setWidgetValign widget GI.Gtk.AlignFill >>+  GI.Gtk.setWidgetHalign widget GI.Gtk.AlignCenter+ pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO PB.Pixbuf pixbufNewFromFileAtScaleByHeight height name =   PB.pixbufNewFromFileAtScale name (-1) height True@@ -153,3 +161,8 @@ loadIcon height name =   ((</> "icons" </> name) <$> getDataDir) >>=   pixbufNewFromFileAtScaleByHeight height++setMinWidth :: (Gtk.WidgetClass w, MonadIO m) => Int -> w -> m w+setMinWidth width widget = liftIO $ do+  Gtk.widgetSetSizeRequest widget width (-1)+  return widget

@@ -3,7 +3,7 @@   , volumeControlNew   ) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Graphics.UI.Gtk import System.Taffybar.Information.Volume import System.Taffybar.Widget.Generic.PollingLabel

@@ -5,19 +5,17 @@ -- -- For example, Madison, WI is KMSN. ----- NOAA provides several pieces of information in each request; you--- can control which pieces end up in your weather widget by providing--- a _template_ that is filled in with the current information.  The--- template is just a 'String' with variables between dollar signs.--- The variables will be substituted with real data by the widget.--- Example:+-- NOAA provides several pieces of information in each request; you can control+-- which pieces end up in your weather widget by providing a _template_ that is+-- filled in with the current information. The template is just a 'String' with+-- variables between dollar signs. The variables will be substituted with real+-- data by the widget. Example: -- -- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" } -- >     weatherWidget = weatherNew wcfg 10 ----- This example makes a new weather widget that checks the weather at--- KMSN (Madison, WI) every 10 minutes, and displays the results in--- Celcius.+-- This example makes a new weather widget that checks the weather at KMSN+-- (Madison, WI) every 10 minutes, and displays the results in Celcius. -- -- Available variables: --@@ -39,7 +37,7 @@ -- -- [@skyCondition@] ? ----- [@tempC@] The temperature in Celcius+-- [@tempC@] The temperature in Celsius -- -- [@tempF@] The temperature in Farenheit --@@ -54,12 +52,12 @@ -- -- > "$tempF$ °F" ----- would yield a widget displaying the temperature in Farenheit with a--- small label after it.+-- would yield a widget displaying the temperature in Farenheit with a small+-- label after it. ----- Implementation Note: the weather data parsing code is taken from--- xmobar.  This version of the code makes direct HTTP requests--- instead of invoking a separate cURL process.+-- Implementation Note: the weather data parsing code is taken from xmobar. This+-- version of the code makes direct HTTP requests instead of invoking a separate+-- cURL process. module System.Taffybar.Widget.Weather   ( WeatherConfig(..)   , WeatherInfo(..)@@ -69,7 +67,7 @@   , defaultWeatherConfig   ) where -import Control.Monad.Trans+import Control.Monad.IO.Class import Graphics.UI.Gtk import qualified Network.Browser as Browser import Network.HTTP@@ -80,22 +78,22 @@  import System.Taffybar.Widget.Generic.PollingLabel -data WeatherInfo =-    WI { stationPlace :: String-       , stationState :: String-       , year         :: String-       , month        :: String-       , day          :: String-       , hour         :: String-       , wind         :: String-       , visibility   :: String-       , skyCondition :: String-       , tempC        :: Int-       , tempF        :: Int-       , dewPoint     :: String-       , humidity     :: Int-       , pressure     :: Int-       } deriving (Show)+data WeatherInfo = WI+  { stationPlace :: String+  , stationState :: String+  , year :: String+  , month :: String+  , day :: String+  , hour :: String+  , wind :: String+  , visibility :: String+  , skyCondition :: String+  , tempC :: Int+  , tempF :: Int+  , dewPoint :: String+  , humidity :: Int+  , pressure :: Int+  } deriving (Show)   -- Parsers stolen from xmobar

@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : System.Taffybar.Widget.Windows--- Copyright   : (c) José A. Romero L.+-- Copyright   : (c) Ivan Malison -- License     : BSD3-style (see LICENSE) -- -- Maintainer  : Ivan Malison <IvanMalison@gmail.com>@@ -10,8 +10,8 @@ -- Portability : unportable -- -- Menu widget that shows the title of the currently focused window and that,--- when clicked, displays the list of all currently open windows allowing to--- switch to any of them.+-- when clicked, displays a menu from which the user may select a window to+-- which to switch the focus. -----------------------------------------------------------------------------  module System.Taffybar.Widget.Windows (@@ -24,7 +24,10 @@   , truncatedGetMenuLabel ) where -import           Control.Monad.Reader+import           Control.Monad+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader+import           Data.GI.Gtk.Threading import qualified Data.Text as T import qualified GI.Gtk as Gtk import qualified Graphics.UI.Gtk as Gtk2hs@@ -60,7 +63,8 @@  truncatedGetActiveLabel :: Int -> TaffyIO String truncatedGetActiveLabel maxLength =-  truncateString maxLength <$> runX11Def "(nameless window)" getActiveWindowTitle+  Gtk2hs.escapeMarkup . truncateString maxLength <$>+        runX11Def "(nameless window)" getActiveWindowTitle  defaultWindowsConfig :: WindowsConfig defaultWindowsConfig =@@ -72,10 +76,10 @@ -- | Create a new Windows widget that will use the given Pager as -- its source of events. windowsNew :: WindowsConfig -> TaffyIO Gtk2hs.Widget-windowsNew config = (`widgetSetClass` "Windows") =<< fromGIWidget =<< do+windowsNew config = (`widgetSetClass` "windows") =<< fromGIWidget =<< do   label <- lift $ Gtk.labelNew Nothing -  let setLabelTitle title = lift $ runOnUIThread $ Gtk.labelSetMarkup label (T.pack title)+  let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label (T.pack title)       activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle    subscription <- subscribeToEvents ["_NET_ACTIVE_WINDOW"] activeWindowUpdatedCallback

@@ -41,7 +41,6 @@   , hideEmpty   , liftX11Def   , workspacesNew-  , setImage   , windowTitleClassIconGetter ) where @@ -51,9 +50,12 @@ import qualified Control.Concurrent.MVar as MV import           Control.Monad import           Control.Monad.IO.Class-import           Control.Monad.Reader+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Reader import           Control.RateLimit+import qualified Data.Char as Char import qualified Data.Foldable as F+import           Data.Int import           Data.List (intersect, sortBy) import qualified Data.Map as M import           Data.Maybe@@ -63,19 +65,24 @@ import           Data.Time.Units import           Data.Tuple.Select import           Data.Tuple.Sequence+import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk+import qualified GI.Gtk import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Abstract.Widget as W import           Graphics.UI.Gtk.General.StyleContext import qualified Graphics.UI.Gtk.Layout.Table as T import           Prelude+import           StatusNotifier.Tray (scalePixbufToSize) import           System.Log.Logger+import           System.Taffybar.Compat.GtkLibs import           System.Taffybar.Context-import           System.Taffybar.IconImages+import           System.Taffybar.EWMHPixbuf import           System.Taffybar.Information.EWMHDesktopInfo import           System.Taffybar.Information.SafeX11 import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar.Util import           System.Taffybar.Widget.Decorators+import           System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage) import           System.Taffybar.Widget.Util import           Text.Printf @@ -87,9 +94,12 @@   | Urgent   deriving (Show, Eq) -workspaceStates :: [String]-workspaceStates = map show [Active, Visible, Hidden, Empty, Urgent]+getCSSClass :: (Show s) => s -> String+getCSSClass = map Char.toLower . show +cssWorkspaceStates :: [String]+cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent]+ data IconInfo   = IIEWMH EWMHIconData   | IIFilePath FilePath@@ -98,7 +108,7 @@   deriving (Eq, Show)  transparentInfo :: IconInfo-transparentInfo = IIColor (0, 0, 0, 0)+transparentInfo = IIColor 0  data WindowData = WindowData   { windowId :: X11Window@@ -122,7 +132,7 @@   { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)   , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)   , hudWidget :: Gtk.HBox-  , hudConfig :: WorkspacesConfig+  , workspacesConfig :: WorkspacesConfig   , taffyContext :: Context   } @@ -138,7 +148,10 @@   :: W.WidgetClass widget   => Workspace -> widget -> IO () setWorkspaceWidgetStatusClass workspace widget =-  updateWidgetClasses widget [show $ workspaceState workspace] workspaceStates+  updateWidgetClasses+    widget+    [map Char.toLower $ show $ workspaceState workspace]+    cssWorkspaceStates  updateWidgetClasses   :: W.WidgetClass widget@@ -174,7 +187,6 @@   WorkspacesConfig   { widgetBuilder :: ControllerConstructor   , widgetGap :: Int-  , windowIconSize :: Int   , underlineHeight :: Int   , minWSWidgetSize :: Maybe Int   , underlinePadding :: Int@@ -207,7 +219,6 @@   WorkspacesConfig   { widgetBuilder = buildButtonController defaultBuildContentsController   , widgetGap = 0-  , windowIconSize = 16   , underlineHeight = 4   , minWSWidgetSize = Just 30   , underlinePadding = 1@@ -284,7 +295,7 @@   let getWorkspaceState idx ws         | idx == active = Active         | idx `elem` visible = Visible-        | urgentWorkspaceState (hudConfig context) &&+        | urgentWorkspaceState (workspacesConfig context) &&           not (null (ws `intersect` urgentWindows)) =           Urgent         | null ws = Empty@@ -343,7 +354,7 @@         { controllersVar = controllersRef         , workspacesVar = workspacesRef         , hudWidget = cont-        , hudConfig = cfg+        , workspacesConfig = cfg         , taffyContext = tContext         }   -- This will actually create all the widgets@@ -358,16 +369,17 @@   let doUnsubscribe = flip runReaderT tContext $         mapM_ unsubscribe [iconSubscription, workspaceSubscription]   _ <- Gtk.on cont W.unrealize doUnsubscribe+  _ <- widgetSetClass cont "workspaces"   return $ Gtk.toWidget cont  updateAllWorkspaceWidgets :: WorkspacesIO () updateAllWorkspaceWidgets = do-  wLog DEBUG "-Workspace- -Execute-..."+  wLog DEBUG "Updating workspace widgets"    workspacesMap <- updateWorkspacesVar   wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap -  wLog DEBUG "-Workspace- Adding and removing widgets..."+  wLog DEBUG "Adding and removing widgets"   updateWorkspaceControllers    let updateController' idx controller =@@ -375,20 +387,22 @@               (updateWidget controller . WorkspaceUpdate) $               M.lookup idx workspacesMap       logUpdateController i =-        wLog DEBUG $ printf "-Workspace- -each- Updating %s widget" $ show i+        wLog DEBUG $ printf "Updating %s workspace widget" $ show i       updateController i cont = logUpdateController i >>                                 updateController' i cont +  wLog DEBUG "Done updating individual widget"+   doWidgetUpdate updateController -  wLog DEBUG "-Workspace- Showing and hiding controllers..."+  wLog DEBUG "Showing and hiding controllers"   setControllerWidgetVisibility  setControllerWidgetVisibility :: WorkspacesIO () setControllerWidgetVisibility = do   WorkspacesContext { workspacesVar = workspacesRef           , controllersVar = controllersRef-          , hudConfig = cfg+          , workspacesConfig = cfg           } <- ask   lift $ do     workspacesMap <- MV.readMVar workspacesRef@@ -406,6 +420,7 @@ doWidgetUpdate updateController = do   c@WorkspacesContext { controllersVar = controllersRef } <- ask   lift $ MV.modifyMVar_ controllersRef $ \controllers -> do+    wLog DEBUG "Updating controllers ref"     controllersList <-       mapM       (\(idx, controller) -> do@@ -419,7 +434,7 @@   WorkspacesContext { controllersVar = controllersRef           , workspacesVar = workspacesRef           , hudWidget = cont-          , hudConfig = cfg+          , workspacesConfig = cfg           } <- ask   workspacesMap <- lift $ MV.readMVar workspacesRef   controllersMap <- lift $ MV.readMVar controllersRef@@ -450,7 +465,7 @@   -> ResultsCombiner req resp   -> IO (req -> IO resp) rateLimitFn context =-  let limit = (updateRateLimitMicroseconds $ hudConfig context)+  let limit = (updateRateLimitMicroseconds $ workspacesConfig context)       rate = fromMicroseconds limit :: Microsecond in   generateRateLimitedFunction $ PerInvocation rate @@ -460,8 +475,8 @@   let withLog event = do         case event of           PropertyEvent _ _ _ _ _ atom _ _ ->-            wLog DEBUG $ printf "-Event- -Workspace- %s" $ show atom-          _ -> wLog DEBUG "-Event- -Workspace-"+            wLog DEBUG $ printf "Event %s" $ show atom+          _ -> return ()         void $ forkIO $ rateLimited event   return withLog   where@@ -472,7 +487,7 @@ onIconChanged handler event =   case event of     PropertyEvent { ev_window = wid } -> do-      wLog DEBUG  $ printf "-Icon- -Event- %s" $ show wid+      wLog DEBUG  $ printf "Icon changed event %s" $ show wid       handler $ Set.singleton wid     _ -> return () @@ -483,11 +498,11 @@     combineRequests windows1 windows2 =       Just (Set.union windows1 windows2, const ((), ()))     onIconsChanged' wids = do-      wLog DEBUG $ printf "-Icon- -Execute- %s" $ show wids+      wLog DEBUG $ printf "Icon update execute %s" $ show wids       flip runReaderT context $         doWidgetUpdate           (\idx c ->-             wLog DEBUG (printf "-Icon- -each- Updating %s icons." $ show idx) >>+             wLog DEBUG (printf "Updating %s icons." $ show idx) >>              updateWidget c (IconUpdate $ Set.toList wids))  data WorkspaceContentsController = WorkspaceContentsController@@ -502,7 +517,7 @@     cons <- Gtk.hBoxNew False 0     mapM_ (Gtk.containerAdd cons . getWidget) controllers     outerBox <- buildPadBox cons-    _ <- widgetSetClass cons "Contents"+    _ <- widgetSetClass cons "contents"     return       WorkspaceContentsController       { containerWidget = Gtk.toWidget outerBox@@ -517,7 +532,7 @@ instance WorkspaceWidgetController WorkspaceContentsController where   getWidget = containerWidget   updateWidget cc update = do-    WorkspacesContext {hudConfig = cfg} <- ask+    WorkspacesContext {workspacesConfig = cfg} <- ask     lift $       maybe (return ()) (updateMinSize $ Gtk.toWidget $ containerWidget cc) $       minWSWidgetSize cfg@@ -537,14 +552,14 @@ buildLabelController ws = do   tempController <- lift $ do     lbl <- Gtk.labelNew (Nothing :: Maybe String)-    _ <- widgetSetClass lbl "WorkspaceLabel"+    _ <- widgetSetClass lbl "workspace-label"     return LabelController { label = lbl }   WWC <$> updateWidget tempController (WorkspaceUpdate ws)  instance WorkspaceWidgetController LabelController where   getWidget = Gtk.toWidget . label   updateWidget lc (WorkspaceUpdate newWorkspace) = do-    WorkspacesContext { hudConfig = cfg } <- ask+    WorkspacesContext { workspacesConfig = cfg } <- ask     labelText <- labelSetter cfg newWorkspace     lift $ do       Gtk.labelSetMarkup (label lc) labelText@@ -556,8 +571,66 @@   { iconContainer :: Gtk.EventBox   , iconImage :: Gtk.Image   , iconWindow :: MV.MVar (Maybe WindowData)+  , iconForceUpdate :: IO ()   } +getPixbufFromInfo :: Bool -> Int32 -> IconInfo -> IO (Maybe Gdk.Pixbuf)+getPixbufFromInfo transparentOnNone imgSize = gpb+  where+    gpb (IIEWMH iconData) =+      withEWMHIcons iconData (traverse pixBufFromEWMHIcon . selectEWMHIcon imgSize)+    gpb (IIFilePath file) = Just <$> pixBufFromFile file+    gpb (IIColor color) = Just <$> pixBufFromColor imgSize color+    gpb IINone =+      if transparentOnNone+      then getPixbufFromInfo transparentOnNone imgSize transparentInfo+      else return Nothing++getPixbufForIconWidget :: Bool+                       -> MV.MVar (Maybe WindowData)+                       -> Int32+                       -> WorkspacesIO (Maybe Gdk.Pixbuf)+getPixbufForIconWidget transparentOnNone dataVar size =+  ask >>= \ctx ->+    let getII = getIconInfo $ workspacesConfig ctx+    in lift $ MV.readMVar dataVar >>=+       flip runReaderT ctx . maybe (return IINone) getII >>=+       getPixbufFromInfo transparentOnNone size >>=+       traverse (scalePixbufToSize size GI.Gtk.OrientationHorizontal)++buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget+buildIconWidget transparentOnNone ws = do+  ctx <- ask+  lift $ do+    windowVar <- MV.newMVar Nothing+    img <- Gtk.imageNew+    giImg <- toGIImage img+    refreshImage <-+      autoSizeImage giImg+        (flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar)+        GI.Gtk.OrientationHorizontal+    ebox <- Gtk.eventBoxNew+    _ <- widgetSetClass img "window-icon"+    _ <- widgetSetClass ebox "window-icon-container"+    Gtk.containerAdd ebox img+    _ <-+      Gtk.on ebox Gtk.buttonPressEvent $+      liftIO $ do+        info <- MV.readMVar windowVar+        case info of+          Just updatedInfo ->+            flip runReaderT ctx $+            liftX11Def () $ focusWindow $ windowId updatedInfo+          _ -> liftIO $ void $ switch ctx (workspaceIdx ws)+        return True+    return+      IconWidget+      { iconContainer = ebox+      , iconImage = img+      , iconWindow = windowVar+      , iconForceUpdate = refreshImage+      }+ data IconController = IconController   { iconsContainer :: Gtk.HBox   , iconImages :: [IconWidget]@@ -592,7 +665,7 @@       do         info <- lift $ MV.readMVar $ iconWindow widget         when (maybe False (flip elem windowIds . windowId) info) $-         updateIconWidget ic widget info False+         updateIconWidget ic widget info  updateMinSize :: Gtk.Widget -> Int  -> IO () updateMinSize widget minWidth = do@@ -621,18 +694,23 @@  updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget] updateImages ic ws = do-  WorkspacesContext {hudConfig = cfg} <- ask+  WorkspacesContext {workspacesConfig = cfg} <- ask   sortedWindows <- iconSort cfg $ windows ws-  let updateIconWidget' getImageAction wdata ton = do+  wLog DEBUG $ printf "Updating images for %s" (show ws)+  let updateIconWidget' getImageAction wdata = do         iconWidget <- getImageAction-        _ <- updateIconWidget ic iconWidget wdata ton+        _ <- updateIconWidget ic iconWidget wdata         return iconWidget       existingImages = map return $ iconImages ic-      buildAndAddIconWidget = do-        iw <- buildIconWidget ws+      buildAndAddIconWidget transparentOnNone = do+        iw <- buildIconWidget transparentOnNone ws         lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw         return iw-      infiniteImages = existingImages ++ repeat buildAndAddIconWidget+      infiniteImages =+        existingImages +++        replicate (minIcons cfg - length existingImages)+                  (buildAndAddIconWidget True) +++        repeat (buildAndAddIconWidget False)       windowCount = length $ windows ws       maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg       newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded@@ -649,98 +727,48 @@           then justWindows ++                replicate (minIcons cfg - length justWindows) Nothing           else justWindows ++ repeat Nothing-      transparentOnNones = replicate (minIcons cfg) True ++ repeat False   newImgs <--    sequence $ zipWith3 updateIconWidget' getImgs windowDatas transparentOnNones+    zipWithM updateIconWidget' getImgs windowDatas   when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic   return newImgs -buildIconWidget :: Workspace -> WorkspacesIO IconWidget-buildIconWidget ws = do-  ctx <- ask-  lift $ do-    img <- Gtk.imageNew-    ebox <- Gtk.eventBoxNew-    windowVar <- MV.newMVar Nothing-    _ <- widgetSetClass img "IconImage"-    _ <- widgetSetClass ebox "IconContainer"-    Gtk.containerAdd ebox img-    _ <--      Gtk.on ebox Gtk.buttonPressEvent $-      liftIO $ do-        info <- MV.readMVar windowVar-        case info of-          Just updatedInfo ->-            flip runReaderT ctx $ liftX11Def () $ focusWindow $ windowId updatedInfo-          _ -> liftIO $ void $ switch ctx (workspaceIdx ws)-        return True-    return-      IconWidget {iconContainer = ebox, iconImage = img, iconWindow = windowVar}- getWindowStatusString :: WindowData -> String-getWindowStatusString WindowData { windowMinimized = True } = "Minimized"-getWindowStatusString WindowData { windowActive = True } = show Active-getWindowStatusString WindowData { windowUrgent = True } = show Urgent-getWindowStatusString _ = "Normal"+getWindowStatusString windowData = map Char.toLower $+  case windowData of+    WindowData { windowMinimized = True } -> "minimized"+    WindowData { windowActive = True } -> show Active+    WindowData { windowUrgent = True } -> show Urgent+    _ -> "normal"  possibleStatusStrings :: [String]-possibleStatusStrings = [show Active, show Urgent, "Minimized", "Normal", "Nodata"]+possibleStatusStrings =+  map+    (map Char.toLower)+    [show Active, show Urgent, "minimized", "normal", "inactive"]  updateIconWidget   :: IconController   -> IconWidget   -> Maybe WindowData-  -> Bool   -> WorkspacesIO () updateIconWidget _ IconWidget                    { iconContainer = iconButton-                   , iconImage = image                    , iconWindow = windowRef-                   } windowData transparentOnNone = do-  cfg <- asks hudConfig--  let setIconWidgetProperties = do-        info <- maybe (return IINone) (getIconInfo cfg) windowData-        let imgSize = windowIconSize cfg-            statusString = maybe "nodata" getWindowStatusString windowData-            iconInfo =-              case info of-                IINone ->-                  if transparentOnNone-                  then transparentInfo-                  else IINone-                _ -> info-        lift $ do-          mpixBuf <- getPixBuf imgSize iconInfo-          setImage imgSize image mpixBuf-          updateWidgetClasses iconButton [statusString] possibleStatusStrings--  void $ updateVar windowRef $ const $ setIconWidgetProperties >> return windowData--setImage :: Int -> Gtk.Image -> Maybe Gtk.Pixbuf -> IO ()-setImage imgSize img pixBuf =-  case pixBuf of-    Just pixbuf -> do-      scaledPixbuf <- scalePixbuf imgSize pixbuf-      Gtk.imageSetFromPixbuf img scaledPixbuf-    Nothing -> Gtk.imageClear img+                   , iconForceUpdate = updateIcon+                   } windowData = do+  let statusString = maybe "inactive" getWindowStatusString windowData+      setIconWidgetProperties =+        updateWidgetClasses iconButton [statusString] possibleStatusStrings+  void $ updateVar windowRef $ const $ return windowData+  lift $ updateIcon >> setIconWidgetProperties -selectEWMHIcon :: Int -> [EWMHIcon] -> EWMHIcon-selectEWMHIcon imgSize icons = head prefIcon+selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon+selectEWMHIcon imgSize icons = listToMaybe prefIcon   where sortedIcons = sortBy (comparing height) icons-        smallestLargerIcon = take 1 $ dropWhile ((<= imgSize) . height) sortedIcons+        smallestLargerIcon = take 1 $ dropWhile ((<= fromIntegral imgSize) . height) sortedIcons         largestIcon = take 1 $ reverse sortedIcons         prefIcon = smallestLargerIcon ++ largestIcon -getPixBuf :: Int -> IconInfo -> IO (Maybe Gtk.Pixbuf)-getPixBuf imgSize = gpb-  where-    gpb (IIEWMH iconData) = Just <$>-      withEWMHIcons iconData (pixBufFromEWMHIcon . selectEWMHIcon imgSize)-    gpb (IIFilePath file) = Just <$> pixBufFromFile imgSize file-    gpb (IIColor color) = Just <$> pixBufFromColor imgSize color-    gpb _ = return Nothing- data WorkspaceButtonController = WorkspaceButtonController   { button :: Gtk.EventBox   , buttonWorkspace :: Workspace@@ -800,7 +828,7 @@  buildUnderlineController :: ParentControllerConstructor buildUnderlineController contentsBuilder workspace = do-  cfg <- asks hudConfig+  cfg <- asks workspacesConfig   cc <- contentsBuilder workspace    lift $ do@@ -813,7 +841,7 @@     T.tableAttach t u 0 1 1 2        [T.Fill] [T.Shrink] (underlinePadding cfg) 0 -    _ <- widgetSetClass u "Underline"+    _ <- widgetSetClass u "underline"     return $ WWC WorkspaceUnderlineController       {table = t, underline = u, overlineController = cc} @@ -831,16 +859,16 @@   newContents <- updateWidget (overlineController uc) u   return uc { overlineController = newContents } -data WorkspaceBorderController =-  WorkspaceBorderController { border :: Gtk.EventBox-                            , borderContents :: Gtk.EventBox-                            , insideController :: WWC-                            }+data WorkspaceBorderController = WorkspaceBorderController+  { border :: Gtk.EventBox+  , borderContents :: Gtk.EventBox+  , insideController :: WWC+  }  buildBorderController :: ParentControllerConstructor buildBorderController contentsBuilder workspace = do   cc <- contentsBuilder workspace-  cfg <- asks hudConfig+  cfg <- asks workspacesConfig   lift $ do     brd <- Gtk.eventBoxNew     cnt <- Gtk.eventBoxNew@@ -848,8 +876,8 @@     Gtk.containerSetBorderWidth cnt $ borderWidth cfg     Gtk.containerAdd brd cnt     Gtk.containerAdd cnt $ getWidget cc-    _ <- widgetSetClass brd "Border"-    _ <- widgetSetClass cnt "Container"+    _ <- widgetSetClass brd "border"+    _ <- widgetSetClass cnt "container"     return $       WWC         WorkspaceBorderController

@@ -1,5 +1,5 @@ name: taffybar-version: 2.0.0+version: 2.1.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -31,6 +31,10 @@   default: True             library+  default-extensions:+    TupleSections+    StandaloneDeriving+   default-language: Haskell2010   build-depends: base > 3 && < 5                , alsa-mixer >= 0.2.0@@ -53,15 +57,15 @@                , gi-gdkx11                , gi-glib                , gi-gtk+               , gi-gtk-hs                , glib-               , gtk-sni-tray >= 0.1.2.0-               , gtk-strut >= 0.1.2.0+               , gtk-sni-tray >= 0.1.3.1+               , gtk-strut >= 0.1.2.1                , gtk-traymanager >= 1.0.1 && < 2.0.0                , gtk3 >= 0.14.9                , haskell-gi >= 0.21.2                , haskell-gi-base >= 0.21.1                , hslogger-               , mtl >= 2                , multimap >= 1.2.1                , old-locale                , parsec >= 3.1@@ -70,8 +74,9 @@                , regex-compat                , safe >= 0.3 && < 1                , split >= 0.1.4.2-               , status-notifier-item >= 0.2.1.0+               , status-notifier-item >= 0.2.2.0                , stm+               , template-haskell                , text                , time >= 1.4 && < 2.0                , time-locale-compat >= 0.1 && < 0.2@@ -99,8 +104,8 @@                  , System.Taffybar.Context                  , System.Taffybar.DBus                  , System.Taffybar.DBus.Toggle+                 , System.Taffybar.EWMHPixbuf                  , System.Taffybar.Hooks-                 , System.Taffybar.IconImages                  , System.Taffybar.Information.Battery                  , System.Taffybar.Information.CPU                  , System.Taffybar.Information.CPU2@@ -117,7 +122,6 @@                  , System.Taffybar.Information.XDG.Protocol                  , System.Taffybar.SimpleConfig                  , System.Taffybar.Support.PagerHints-                 , System.Taffybar.TransparentWindow                  , System.Taffybar.Widget                  , System.Taffybar.Widget.Battery                  , System.Taffybar.Widget.CPUMonitor@@ -126,7 +130,9 @@                  , System.Taffybar.Widget.DiskIOMonitor                  , System.Taffybar.Widget.FSMonitor                  , System.Taffybar.Widget.FreedesktopNotifications+                 , System.Taffybar.Widget.Generic.AutoSizeImage                  , System.Taffybar.Widget.Generic.ChannelGraph+                 , System.Taffybar.Widget.Generic.ChannelWidget                  , System.Taffybar.Widget.Generic.DynamicMenu                  , System.Taffybar.Widget.Generic.Graph                  , System.Taffybar.Widget.Generic.Icon@@ -136,7 +142,6 @@                  , System.Taffybar.Widget.Generic.VerticalBar                  , System.Taffybar.Widget.Layout                  , System.Taffybar.Widget.MPRIS2-                 , System.Taffybar.Widget.NetMonitor                  , System.Taffybar.Widget.NetworkGraph                  , System.Taffybar.Widget.SNITray                  , System.Taffybar.Widget.SimpleClock@@ -153,8 +158,11 @@                  , System.Taffybar.Widget.XDGMenu.MenuWidget                       other-modules: Paths_taffybar-               , System.Taffybar.Information.DBusClients-               , System.Taffybar.Information.DBusObjects+               , System.Taffybar.DBus.Client.MPRIS2+               , System.Taffybar.DBus.Client.Params+               , System.Taffybar.DBus.Client.UPower+               , System.Taffybar.DBus.Client.UPowerDevice+               , System.Taffybar.DBus.Client.Util                , System.Taffybar.Util    cc-options: -fPIC

@@ -1,69 +1,121 @@-@define-color bg-color #000000;-@define-color bg-tone #1E1E20;-@define-color active-window-color #374140;-@define-color urgent-window-color #D9CB9E;-@define-color font-color #D9CB9E;+@define-color transparent rgba(0.0, 0.0, 0.0, 0.0);+@define-color white #FFFFFF;+@define-color black #000000;+@define-color taffy-blue #0c7cd5; -.Contents {-	border-radius: 5px;-	padding: 3px;+@define-color active-window-color @white;+@define-color urgent-window-color @taffy-blue;+@define-color font-color @white;+@define-color menu-background-color @white;+@define-color menu-font-color @black;++/* Top level styling */++.taffy-window * {+	font-family: "Noto Sans", sans-serif;+	font-size: 10pt;+	color: @font-color; } -.Active .Contents, .Visible .Contents {-	background-color: @bg-tone;+.taffy-box {+	border-radius: 10px;+	background-color: rgba(0.0, 0.0, 0.0, 0.3); } -.InnerPad {-	padding: 4px;+.inner-pad {+	padding-bottom: 5px;+	padding-top: 5px;+	padding-left: 2px;+	padding-right: 2px; } -.WorkspaceLabel {+.contents {+	padding-bottom: 4px;+	padding-top: 4px;+	padding-right: 2px;+	padding-left: 2px;+	transition: background-color .5s;+	border-radius: 5px;+}++/* Workspaces styling */++.workspace-label { 	padding-right: 3px; 	padding-left: 2px; 	font-size: 12pt; } -.Menu {-	background-color: @bg-color;+.active .contents {+	background-color: rgba(0.0, 0.0, 0.0, 0.5); } -.IconContainer {-	transition: background-color .5s;-	border-radius: 5px;+.visible .contents {+	background-color: rgba(0.0, 0.0, 0.0, 0.2); } -.IconContainer.Active {-	transition: background-color .5s;-	background-color: @active-window-color;+.window-icon-container {+	transition: opacity .5s, box-shadow .5s;+	opacity: 1; } -.IconContainer.Urgent {-	transition: background-color .5s;-	background-color: @urgent-window-color;+/* This gives space for the box-shadow (they look like underlines) that follow.+   This will actually affect all widgets, (not just the workspace icons), but+   that is what we want since we want the icons to look the same. */+.auto-size-image, .sni-tray {+	padding-top: 3px;+	padding-bottom: 3px; } -.IconContainer.Minimized .IconImage {-	transition: opacity .5s;+.window-icon-container.active {+	box-shadow: inset 0 -3px @white;+}++.window-icon-container.urgent {+	box-shadow: inset 0 -3px @urgent-window-color;+}++.window-icon-container.inactive .window-icon {+  padding: 0px;+}++.window-icon-container.minimized .window-icon { 	opacity: .3; } -.IconImage {-	transition: opacity .5s;-	padding: 2px;+.window-icon { 	opacity: 1;+	transition: opacity .5s; } -#Windows {-	background-color: @bg-color;+/* Button styling */++button {+	background-color: @transparent;+	border-width: 0px;+	border-radius: 0px; } -.Taffybar {-	background-color: @bg-color;-	border-radius: 5px;+button:checked, button:hover .Contents:hover {+	box-shadow: inset 0 -3px @taffy-blue; } -.Taffybar * {-	font-family: "Fira Sans", sans-serif;-	font-size: 10pt;-	color: @font-color;+/* Menu styling */++/* The ".taffy-window" prefixed selectors are needed because if they aren't present,+   the top level .Taffybar selector takes precedence */+.taffy-window menuitem *,  menuitem * {+	color: @menu-font-color;+}++.taffy-window menuitem, menuitem {+	background-color: @menu-background-color;+}++.taffy-window menuitem:hover, menuitem:hover {+	background-color: @taffy-blue;+}++.taffy-window menuitem:hover > label, menuitem:hover > label {+	color: @white; }

@@ -1,43 +1,85 @@ module Main where -import           System.Taffybar-import           System.Taffybar.Information.CPU-import           System.Taffybar.Information.Memory-import           System.Taffybar.SimpleConfig-import           System.Taffybar.Widget-import           System.Taffybar.Widget.Generic.PollingGraph+import System.Taffybar+import System.Taffybar.Hooks+import System.Taffybar.Information.CPU+import System.Taffybar.Information.Memory+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 +transparent = (0.0, 0.0, 0.0, 0.0)+yellow1 = (0.9453125, 0.63671875, 0.2109375, 1.0)+yellow2 = (0.9921875, 0.796875, 0.32421875, 1.0)+green1 = (0, 1, 0, 1)+green2 = (1, 0, 1, 0.5)+taffyBlue = (0.129, 0.588, 0.953, 1)++myGraphConfig =+  defaultGraphConfig+  { graphPadding = 0+  , graphBorderWidth = 0+  , graphWidth = 75+  , graphBackgroundColor = transparent+  }++netCfg = myGraphConfig+  { graphDataColors = [yellow1, yellow2]+  , graphLabel = Just "net"+  }++memCfg = myGraphConfig+  { graphDataColors = [taffyBlue]+  , graphLabel = Just "mem"+  }++cpuCfg = myGraphConfig+  { graphDataColors = [green1, green2]+  , graphLabel = Just "cpu"+  }++memCallback :: IO [Double] memCallback = do   mi <- parseMeminfo   return [memoryUsedRatio mi]  cpuCallback = do-  (userLoad, systemLoad, totalLoad) <- cpuLoad+  (_, systemLoad, totalLoad) <- cpuLoad   return [totalLoad, systemLoad]  main = do-  let memCfg = defaultGraphConfig-               { graphDataColors = [(1, 0, 0, 1)]-               , graphLabel = Just "mem"-               }-      cpuCfg = defaultGraphConfig-               { graphDataColors =-                   [ (0, 1, 0, 1)-                   , (1, 0, 1, 0.5)-                   ]-               , graphLabel = Just "cpu"-               }-  let clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1-      workspaces = workspacesNew defaultWorkspacesConfig-      windows = windowsNew defaultWindowsConfig-      layout = layoutNew defaultLayoutconfig-      note = notifyAreaNew defaultNotificationConfig-      wea = weatherNew (defaultWeatherConfig "KMSN") 10-      mpris = mpris2New-      mem = pollingGraphNew memCfg 1 memCallback+  let myWorkspacesConfig =+        defaultWorkspacesConfig+        { minIcons = 1+        , widgetGap = 0+        , showWorkspaceFn = hideEmpty+        }+      workspaces = workspacesNew myWorkspacesConfig       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback-      tray = systrayNew-  simpleTaffybar defaultSimpleTaffyConfig-                   { startWidgets = [ workspaces, layout, windows, note ]-                   , endWidgets = [ tray, wea, clock, mem, cpu, mpris ]-                   }+      mem = pollingGraphNew memCfg 1 memCallback+      net = networkGraphNew netCfg Nothing+      clock = textClockNew Nothing "%a %b %_d %r" 1+      layout = layoutNew defaultLayoutConfig+      windows = windowsNew defaultWindowsConfig+      myConfig = defaultSimpleTaffyConfig+        { startWidgets =+            workspaces : map (>>= buildContentsBox) [ layout, windows ]+        , endWidgets = map (>>= buildContentsBox)+          [ batteryIconNew+          , clock+          , sniTrayNew+          , cpu+          , mem+          , net+          , mpris2New+          ]+        , barPosition = Top+        , barPadding = 10+        , barHeight = 50+        , widgetSpacing = 0+        }+  dyreTaffybar $ withBatteryRefresh $ withLogServer $ withToggleServer $+               toTaffyConfig myConfig