diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,33 +1,35 @@
Taffybar
========
[](https://hackage.haskell.org/package/taffybar)
+[](https://github.com/taffybar/taffybar/compare/latest-release...master)
[](https://travis-ci.org/taffybar/taffybar)
+[](https://github.com/taffybar/taffybar/labels/help%20wanted)
[](https://gitter.im/taffybar/Lobby)
[](https://github.com/taffybar/taffybar/blob/master/LICENSE)
-
-
-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
-------------------
+
-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:
+
+
+[](https://github.com/taffybar/taffybar/labels/help%20wanted)
+[](https://github.com/taffybar/taffybar/labels/easy)
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
--- a/src/System/Taffybar.hs
+++ b/src/System/Taffybar.hs
@@ -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 "%a %b %_d %H:%M" 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 ()
diff --git a/src/System/Taffybar/Auth.hs b/src/System/Taffybar/Auth.hs
--- a/src/System/Taffybar/Auth.hs
+++ b/src/System/Taffybar/Auth.hs
@@ -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)
diff --git a/src/System/Taffybar/Compat/GtkLibs.hs b/src/System/Taffybar/Compat/GtkLibs.hs
--- a/src/System/Taffybar/Compat/GtkLibs.hs
+++ b/src/System/Taffybar/Compat/GtkLibs.hs
@@ -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
diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs
--- a/src/System/Taffybar/Context.hs
+++ b/src/System/Taffybar/Context.hs
@@ -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
diff --git a/src/System/Taffybar/DBus.hs b/src/System/Taffybar/DBus.hs
--- a/src/System/Taffybar/DBus.hs
+++ b/src/System/Taffybar/DBus.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Client/MPRIS2.hs b/src/System/Taffybar/DBus/Client/MPRIS2.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/MPRIS2.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/Params.hs b/src/System/Taffybar/DBus/Client/Params.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/Params.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Client/UPower.hs b/src/System/Taffybar/DBus/Client/UPower.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/UPower.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/UPowerDevice.hs b/src/System/Taffybar/DBus/Client/UPowerDevice.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/UPowerDevice.hs
@@ -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"
diff --git a/src/System/Taffybar/DBus/Client/Util.hs b/src/System/Taffybar/DBus/Client/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Client/Util.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs
--- a/src/System/Taffybar/DBus/Toggle.hs
+++ b/src/System/Taffybar/DBus/Toggle.hs
@@ -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
diff --git a/src/System/Taffybar/EWMHPixbuf.hs b/src/System/Taffybar/EWMHPixbuf.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/EWMHPixbuf.hs
@@ -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
diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs
--- a/src/System/Taffybar/Hooks.hs
+++ b/src/System/Taffybar/Hooks.hs
@@ -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
diff --git a/src/System/Taffybar/IconImages.hs b/src/System/Taffybar/IconImages.hs
deleted file mode 100644
--- a/src/System/Taffybar/IconImages.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs
--- a/src/System/Taffybar/Information/Battery.hs
+++ b/src/System/Taffybar/Information/Battery.hs
@@ -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
diff --git a/src/System/Taffybar/Information/CPU2.hs b/src/System/Taffybar/Information/CPU2.hs
--- a/src/System/Taffybar/Information/CPU2.hs
+++ b/src/System/Taffybar/Information/CPU2.hs
@@ -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
diff --git a/src/System/Taffybar/Information/DBusClients.hs b/src/System/Taffybar/Information/DBusClients.hs
deleted file mode 100644
--- a/src/System/Taffybar/Information/DBusClients.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Information/DBusObjects.hs b/src/System/Taffybar/Information/DBusObjects.hs
deleted file mode 100644
--- a/src/System/Taffybar/Information/DBusObjects.hs
+++ /dev/null
@@ -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"
- }
diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
--- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs
+++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/MPRIS2.hs b/src/System/Taffybar/Information/MPRIS2.hs
--- a/src/System/Taffybar/Information/MPRIS2.hs
+++ b/src/System/Taffybar/Information/MPRIS2.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Network.hs b/src/System/Taffybar/Information/Network.hs
--- a/src/System/Taffybar/Information/Network.hs
+++ b/src/System/Taffybar/Information/Network.hs
@@ -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
diff --git a/src/System/Taffybar/Information/SafeX11.hsc b/src/System/Taffybar/Information/SafeX11.hsc
--- a/src/System/Taffybar/Information/SafeX11.hsc
+++ b/src/System/Taffybar/Information/SafeX11.hsc
@@ -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)
diff --git a/src/System/Taffybar/Information/StreamInfo.hs b/src/System/Taffybar/Information/StreamInfo.hs
--- a/src/System/Taffybar/Information/StreamInfo.hs
+++ b/src/System/Taffybar/Information/StreamInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs
--- a/src/System/Taffybar/Information/X11DesktopInfo.hs
+++ b/src/System/Taffybar/Information/X11DesktopInfo.hs
@@ -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
diff --git a/src/System/Taffybar/Information/XDG/DesktopEntry.hs b/src/System/Taffybar/Information/XDG/DesktopEntry.hs
--- a/src/System/Taffybar/Information/XDG/DesktopEntry.hs
+++ b/src/System/Taffybar/Information/XDG/DesktopEntry.hs
@@ -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
diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs
--- a/src/System/Taffybar/Information/XDG/Protocol.hs
+++ b/src/System/Taffybar/Information/XDG/Protocol.hs
@@ -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
diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs
--- a/src/System/Taffybar/SimpleConfig.hs
+++ b/src/System/Taffybar/SimpleConfig.hs
@@ -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
diff --git a/src/System/Taffybar/TransparentWindow.hs b/src/System/Taffybar/TransparentWindow.hs
deleted file mode 100644
--- a/src/System/Taffybar/TransparentWindow.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs
--- a/src/System/Taffybar/Util.hs
+++ b/src/System/Taffybar/Util.hs
@@ -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"
diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs
--- a/src/System/Taffybar/Widget.hs
+++ b/src/System/Taffybar/Widget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs
--- a/src/System/Taffybar/Widget/Battery.hs
+++ b/src/System/Taffybar/Widget/Battery.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/CPUMonitor.hs b/src/System/Taffybar/Widget/CPUMonitor.hs
--- a/src/System/Taffybar/Widget/CPUMonitor.hs
+++ b/src/System/Taffybar/Widget/CPUMonitor.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/CommandRunner.hs b/src/System/Taffybar/Widget/CommandRunner.hs
--- a/src/System/Taffybar/Widget/CommandRunner.hs
+++ b/src/System/Taffybar/Widget/CommandRunner.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Decorators.hs b/src/System/Taffybar/Widget/Decorators.hs
--- a/src/System/Taffybar/Widget/Decorators.hs
+++ b/src/System/Taffybar/Widget/Decorators.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/DiskIOMonitor.hs b/src/System/Taffybar/Widget/DiskIOMonitor.hs
--- a/src/System/Taffybar/Widget/DiskIOMonitor.hs
+++ b/src/System/Taffybar/Widget/DiskIOMonitor.hs
@@ -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 )
diff --git a/src/System/Taffybar/Widget/FSMonitor.hs b/src/System/Taffybar/Widget/FSMonitor.hs
--- a/src/System/Taffybar/Widget/FSMonitor.hs
+++ b/src/System/Taffybar/Widget/FSMonitor.hs
@@ -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 )
diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
--- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs
+++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
--- a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelWidget.hs b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/ChannelWidget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/DynamicMenu.hs b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
--- a/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
+++ b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
@@ -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 =
diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs
--- a/src/System/Taffybar/Widget/Generic/Graph.hs
+++ b/src/System/Taffybar/Widget/Generic/Graph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingGraph.hs b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
--- a/src/System/Taffybar/Widget/Generic/PollingGraph.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingLabel.hs b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
--- a/src/System/Taffybar/Widget/Generic/PollingLabel.hs
+++ b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/VerticalBar.hs b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
--- a/src/System/Taffybar/Widget/Generic/VerticalBar.hs
+++ b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs
--- a/src/System/Taffybar/Widget/Layout.hs
+++ b/src/System/Taffybar/Widget/Layout.hs
@@ -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.
+-- Maintainer : Ivan Malison
-- 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
--
diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs
--- a/src/System/Taffybar/Widget/MPRIS2.hs
+++ b/src/System/Taffybar/Widget/MPRIS2.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/NetMonitor.hs b/src/System/Taffybar/Widget/NetMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widget/NetMonitor.hs
+++ /dev/null
@@ -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.
--- 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))
diff --git a/src/System/Taffybar/Widget/NetworkGraph.hs b/src/System/Taffybar/Widget/NetworkGraph.hs
--- a/src/System/Taffybar/Widget/NetworkGraph.hs
+++ b/src/System/Taffybar/Widget/NetworkGraph.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/SNITray.hs b/src/System/Taffybar/Widget/SNITray.hs
--- a/src/System/Taffybar/Widget/SNITray.hs
+++ b/src/System/Taffybar/Widget/SNITray.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs
--- a/src/System/Taffybar/Widget/SimpleClock.hs
+++ b/src/System/Taffybar/Widget/SimpleClock.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Systray.hs b/src/System/Taffybar/Widget/Systray.hs
--- a/src/System/Taffybar/Widget/Systray.hs
+++ b/src/System/Taffybar/Widget/Systray.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
--- a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
+++ b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs
--- a/src/System/Taffybar/Widget/Util.hs
+++ b/src/System/Taffybar/Widget/Util.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Volume.hs b/src/System/Taffybar/Widget/Volume.hs
--- a/src/System/Taffybar/Widget/Volume.hs
+++ b/src/System/Taffybar/Widget/Volume.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs
--- a/src/System/Taffybar/Widget/Weather.hs
+++ b/src/System/Taffybar/Widget/Weather.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs
--- a/src/System/Taffybar/Widget/Windows.hs
+++ b/src/System/Taffybar/Widget/Windows.hs
@@ -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
@@ -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
diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs
--- a/src/System/Taffybar/Widget/Workspaces.hs
+++ b/src/System/Taffybar/Widget/Workspaces.hs
@@ -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
diff --git a/taffybar.cabal b/taffybar.cabal
--- a/taffybar.cabal
+++ b/taffybar.cabal
@@ -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
diff --git a/taffybar.css b/taffybar.css
--- a/taffybar.css
+++ b/taffybar.css
@@ -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;
}
diff --git a/taffybar.hs.example b/taffybar.hs.example
--- a/taffybar.hs.example
+++ b/taffybar.hs.example
@@ -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 "%a %b %_d %H:%M" 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