diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,4 @@ -Taffybar -======== -[![Hackage](https://img.shields.io/hackage/v/taffybar.svg)](https://hackage.haskell.org/package/taffybar) -[![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) -[![Build Status](https://travis-ci.org/taffybar/taffybar.svg?branch=master)](https://travis-ci.org/taffybar/taffybar) -[![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) -[![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) -[![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) +# Taffybar [![Hackage](https://img.shields.io/hackage/v/taffybar.svg)](https://hackage.haskell.org/package/taffybar) [![Commits](https://img.shields.io/github/commits-since/taffybar/taffybar/latest-release.svg?label=unreleased%20commits)](https://github.com/taffybar/taffybar/compare/latest-release...master) [![Build Status](https://travis-ci.org/taffybar/taffybar.svg?branch=master)](https://travis-ci.org/taffybar/taffybar) [![Help Wanted](https://img.shields.io/github/issues/taffybar/taffybar/help%20wanted.svg)](https://github.com/taffybar/taffybar/labels/help%20wanted) [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby) [![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/taffybar/taffybar/blob/master/LICENSE) ![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) diff --git a/dbus-xml/org.freedesktop.UPower.Device.xml b/dbus-xml/org.freedesktop.UPower.Device.xml new file mode 100644 --- /dev/null +++ b/dbus-xml/org.freedesktop.UPower.Device.xml @@ -0,0 +1,48 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dbus-xml/org.freedesktop.UPower.xml b/dbus-xml/org.freedesktop.UPower.xml new file mode 100644 --- /dev/null +++ b/dbus-xml/org.freedesktop.UPower.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dbus-xml/org.mpris.MediaPlayer2.xml b/dbus-xml/org.mpris.MediaPlayer2.xml new file mode 100644 --- /dev/null +++ b/dbus-xml/org.mpris.MediaPlayer2.xml @@ -0,0 +1,10 @@ + + + + + + + + + + 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 @@ -12,11 +12,8 @@ import Control.Monad.IO.Class import Data.GI.Base.ManagedPtr -import Data.Word import Foreign.ForeignPtr -import Foreign.Marshal.Alloc import Foreign.Ptr -import GI.GdkPixbuf.Enums import qualified GI.GdkPixbuf.Objects.Pixbuf as PB import qualified GI.Gtk import qualified Graphics.UI.Gtk as Gtk @@ -57,13 +54,3 @@ 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 PB.Pixbuf -pixbufNewFromData ptr w h = do - let width = fromIntegral w - height = fromIntegral h - rowStride = width * 4 - PB.pixbufNewFromData ptr ColorspaceRgb True 8 - width height rowStride (Just free) 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 @@ -45,7 +45,6 @@ import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util -import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Util import Text.Printf import Unsafe.Coerce @@ -181,15 +180,7 @@ _ <- widgetSetClass window "taffy-window" let addWidgetWith widgetAdd buildWidget = - do - widget <- runReaderT buildWidget context - -- XXX: This is a pretty bad way to do this - let height = - case strutHeight $ strutConfig barConfig of - ExactSize size -> fromIntegral size - _ -> 40 - Gtk.widgetSetSizeRequest widget (-1) height - widgetAdd widget + runReaderT buildWidget thisContext >>= widgetAdd addToStart widget = Gtk.boxPackStart box widget Gtk.PackNatural 0 addToEnd widget = Gtk.boxPackEnd box widget Gtk.PackNatural 0 addToCenter widget = Gtk.boxPackStart centerBox widget Gtk.PackNatural 0 diff --git a/src/System/Taffybar/EWMHPixbuf.hs b/src/System/Taffybar/EWMHPixbuf.hs deleted file mode 100644 --- a/src/System/Taffybar/EWMHPixbuf.hs +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 @@ -4,12 +4,20 @@ , refreshBatteriesOnPropChange ) where -import Control.Concurrent -import Control.Monad.Trans.Class -import System.Taffybar.Context -import System.Taffybar.DBus -import System.Taffybar.Information.Battery -import System.Taffybar.Information.Network +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.Maybe +import qualified Data.MultiMap as MM +import System.FilePath +import System.Taffybar.Context +import System.Taffybar.DBus +import System.Taffybar.Information.Battery +import System.Taffybar.Information.Network +import System.Taffybar.Information.XDG.DesktopEntry +import System.Taffybar.Util newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))]) @@ -24,3 +32,32 @@ withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange + +getDirectoryEntriesByClassName :: TaffyIO (MM.MultiMap String DesktopEntry) +getDirectoryEntriesByClassName = + getStateDefault readDirectoryEntriesDefault + +updateDirectoryEntriesCache :: TaffyIO () +updateDirectoryEntriesCache = ask >>= \ctx -> + void $ lift $ foreverWithDelay (60 :: Double) $ flip runReaderT ctx $ + putState readDirectoryEntriesDefault + +readDirectoryEntriesDefault :: TaffyIO (MM.MultiMap String DesktopEntry) +readDirectoryEntriesDefault = lift $ + directoryEntriesByClassName <$> getDirectoryEntriesDefault + +directoryEntriesByClassName + :: Foldable t + => t DesktopEntry -> MM.MultiMap String DesktopEntry +directoryEntriesByClassName = foldl insertByClassName MM.empty + where + insertByClassName entriesMap entry = + MM.insert (getClassName entry) entry entriesMap + getFromFilename filepath = + let (_, filename) = splitFileName filepath + (_, noExtensions) = splitExtensions filename + in noExtensions + getClassName DesktopEntry {deAttributes = attributes, deFilename = filename} = + fromMaybe (getFromFilename filename) $ + lookup "StartupWMClass" attributes <|> + lookup "Name" attributes 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 @@ -20,31 +20,33 @@ ----------------------------------------------------------------------------- module System.Taffybar.Information.EWMHDesktopInfo - ( X11Window -- re-exported from X11DesktopInfo - , X11WindowHandle - , WorkspaceIdx(..) - , EWMHIcon(..) + ( EWMHIcon(..) , EWMHIconData - , withDefaultCtx -- re-exported from X11DesktopInfo - , isWindowUrgent -- re-exported from X11DesktopInfo + , WorkspaceIdx(..) + , X11Window -- re-exported from X11DesktopInfo + , X11WindowHandle + , focusWindow + , getActiveWindowTitle , getCurrentWorkspace , getVisibleWorkspaces - , getWorkspaceNames - , switchToWorkspace - , switchOneWorkspace - , withEWMHIcons - , getWindowTitle , getWindowClass + , getWindowHandles , getWindowIconsData - , getActiveWindowTitle + , getWindowTitle , getWindows - , getWindowHandles , getWorkspace - , focusWindow + , getWorkspaceNames + , isWindowUrgent -- re-exported from X11DesktopInfo + , parseWindowClasses + , switchOneWorkspace + , switchToWorkspace + , withDefaultCtx -- re-exported from X11DesktopInfo + , withEWMHIcons ) where import Control.Applicative import Control.Monad.Trans.Class +import Data.List.Split import Data.Maybe import Data.Tuple import Data.Word @@ -79,9 +81,9 @@ type EWMHIconData = (ForeignPtr PixelsWordType, Int) data EWMHIcon = EWMHIcon - { width :: Int - , height :: Int - , pixelsARGB :: Ptr PixelsWordType + { ewmhWidth :: Int + , ewmhHeight :: Int + , ewmhPixelsARGB :: Ptr PixelsWordType } deriving (Show, Eq) noFocus :: String @@ -145,6 +147,9 @@ getWindowClass :: X11Window -> X11Property String getWindowClass window = readAsString (Just window) "WM_CLASS" +parseWindowClasses :: String -> [String] +parseWindowClasses = filter (not . null) . splitOn "\NUL" + -- | Get EWMHIconData for the given X11Window getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData) getWindowIconsData window = do @@ -179,9 +184,9 @@ newArr = advancePtr pixelsPtr thisSize thisIcon = EWMHIcon - { width = iwidth - , height = iheight - , pixelsARGB = pixelsPtr + { ewmhWidth = iwidth + , ewmhHeight = iheight + , ewmhPixelsARGB = pixelsPtr } getRes newSize | newSize < 0 = trace "This should not happen parseIcons" return [] diff --git a/src/System/Taffybar/Information/Volume.hs b/src/System/Taffybar/Information/Volume.hs deleted file mode 100644 --- a/src/System/Taffybar/Information/Volume.hs +++ /dev/null @@ -1,40 +0,0 @@ -module System.Taffybar.Information.Volume - ( getVolume - , setVolume - ) where - -import Sound.ALSA.Mixer - -volumeAct :: String -> String -> (Volume -> Integer -> Integer -> IO a) -> IO a -volumeAct mix channel action = withMixer mix $ \mixer -> do - Just control <- getControlByName mixer channel - let Just playbackVolume = playback $ volume control - (lo, hi) <- getRange playbackVolume - action playbackVolume lo hi - --- | Gets volume of a channel of a mixer -getVolume :: String -> String -> IO Integer -getVolume mix channel = volumeAct mix channel $ \playbackVolume lo hi -> do - Just vol <- getChannel FrontLeft $ value playbackVolume - return $ toPercent vol lo hi - --- | Sets volume of a channel of a mixer -setVolume :: String -> String -> Double -> IO () -setVolume mix channel vol = volumeAct mix channel $ \playbackVolume lo hi -> do - let volumeValue = value playbackVolume - percentage = fromPercent vol lo hi - setForChannel c = setChannel c volumeValue percentage - mapM_ setForChannel allChannels - -toPercent :: Integer -> Integer -> Integer -> Integer -toPercent v lo hi = ceiling $ (v' - lo') / (hi' - lo') * 100 - where - v' :: Double - v' = fromIntegral v - lo' = fromIntegral lo - hi' = fromIntegral hi - -fromPercent :: Double -> Integer -> Integer -> Integer -fromPercent v lo hi = ceiling $ lo' + (hi' - lo') * v / 100 - where lo' = fromIntegral lo - hi' = fromIntegral hi 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 @@ -10,7 +10,7 @@ -- -- Implementation of version 1.1 of the freedesktop "Desktop Entry -- specification", see --- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html. +-- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.2.html. ----------------------------------------------------------------------------- module System.Taffybar.Information.XDG.DesktopEntry @@ -25,6 +25,7 @@ , deOnlyShowIn , existingDirs , getDefaultDataHome + , getDirectoryEntriesDefault , getDirectoryEntry , getDirectoryEntryDefault , getXDGDataDirs @@ -184,6 +185,12 @@ getDirectoryEntryDefault entry = fmap ( "applications") <$> getXDGDataDirs >>= flip getDirectoryEntry (printf "%s.desktop" entry) + +getDirectoryEntriesDefault :: IO [DesktopEntry] +getDirectoryEntriesDefault = + fmap ( "applications") <$> getXDGDataDirs >>= foldM addDirectories [] + where addDirectories soFar directory = + (soFar ++) <$> listDesktopEntries "desktop" directory -- | Main section of a desktop entry file. sectionMain :: String 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 @@ -104,7 +104,6 @@ getApplicationEntries langs xm = do defEntries <- if xmDefaultAppDirs xm then do dataDirs <- getXDGDataDirs - putStrLn $ "DataDirs=" ++ show dataDirs concat <$> mapM (listDesktopEntries ".desktop" . ( "applications")) dataDirs else return [] 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 @@ -11,13 +11,19 @@ module System.Taffybar.Util where +import Control.Applicative import Control.Arrow ((&&&)) import Control.Concurrent +import Control.Exception.Base import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +import Data.Either.Combinators +import Data.GI.Base.GError import Data.Tuple.Sequence +import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import System.Exit (ExitCode (..)) import System.Log.Logger import qualified System.Process as P @@ -81,3 +87,41 @@ liftActionTaker actionTaker action = do ctx <- ask lift $ actionTaker $ flip runReaderT ctx . action + +maybeTCombine + :: Monad m + => m (Maybe a) -> m (Maybe a) -> m (Maybe a) +maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b + +infixl 3 <||> +(<||>) :: Monad m => + (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a) +a <||> b = combineOptions + where combineOptions v = maybeTCombine (a v) (b v) + +infixl 3 <|||> +(<|||>) + :: Monad m + => (t -> t1 -> m (Maybe a)) + -> (t -> t1 -> m (Maybe a)) + -> t + -> t1 + -> m (Maybe a) +a <|||> b = combineOptions + where combineOptions v v1 = maybeTCombine (a v v1) (b v v1) + +catchGErrorsAsLeft :: IO a -> IO (Either GError a) +catchGErrorsAsLeft action = catch (Right <$> action) mkLeft + where mkLeft err = return $ Left err + +safePixbufNewFromFile :: FilePath -> IO (Either GError Gdk.Pixbuf) +safePixbufNewFromFile filepath = + catchGErrorsAsLeft (Gdk.pixbufNewFromFile filepath) + +getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf) +getPixbufFromFilePath filepath = do + result <- safePixbufNewFromFile filepath + when (isLeft result) $ + logM "System.Taffybar.WindowIcon" WARNING $ + printf "Failed to load icon from filepath %s" filepath + return $ rightToMaybe result 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 @@ -53,10 +53,6 @@ -- * "System.Taffybar.Widget.Text.NetworkMonitor" , module System.Taffybar.Widget.Text.NetworkMonitor - -- * "System.Taffybar.Widget.Volume" - , volumeTextNew - , volumeControlNew - -- * "System.Taffybar.Widget.Weather" , WeatherConfig(..) , WeatherInfo(..) @@ -73,12 +69,7 @@ , truncatedGetMenuLabel -- * "System.Taffybar.Widget.Workspaces" - , IconInfo(..) - , Workspace(..) - , WorkspacesConfig(..) - , WorkspacesIO - , hideEmpty - , workspacesNew + , module System.Taffybar.Widget.Workspaces -- * "System.Taffybar.Widget.XDGMenu.MenuWidget" , module System.Taffybar.Widget.XDGMenu.MenuWidget @@ -100,7 +91,6 @@ import System.Taffybar.Widget.Text.MemoryMonitor import System.Taffybar.Widget.Text.NetworkMonitor import System.Taffybar.Widget.Util -import System.Taffybar.Widget.Volume import System.Taffybar.Widget.Weather import System.Taffybar.Widget.Windows import System.Taffybar.Widget.Workspaces 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 @@ -2,7 +2,6 @@ import Control.Monad.IO.Class import qualified GI.Gtk as Gtk -import System.Log.Logger data DynamicMenuConfig = DynamicMenuConfig { dmClickWidget :: Gtk.Widget 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 @@ -24,21 +24,21 @@ import System.Taffybar.Widget.Util import Text.Printf -getHost :: TaffyIO H.Host -getHost = getStateDefault $ do +getHost :: Bool -> TaffyIO H.Host +getHost startWatcher = getStateDefault $ do pid <- lift getProcessID client <- asks sessionDBusClient Just host <- lift $ H.build H.defaultParams { H.dbusClient = Just client , H.uniqueIdentifier = printf "taffybar-%s" $ show pid + , H.startWatcher = startWatcher } return host -- | Build a new StatusNotifierItem tray that will share a host with any other -- trays that are constructed automatically -sniTrayNew :: TaffyIO Gtk.Widget -sniTrayNew = do - host <- getHost +sniTrayNewFromHost :: H.Host -> TaffyIO Gtk.Widget +sniTrayNewFromHost host = do client <- asks sessionDBusClient lift $ do tray <- @@ -54,3 +54,10 @@ _ <- widgetSetClassGI tray "sni-tray" GI.Gtk.widgetShowAll tray GI.Gtk.toWidget tray >>= fromGIWidget + +sniTrayNew :: TaffyIO Gtk.Widget +sniTrayNew = getHost False >>= sniTrayNewFromHost + +sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO Gtk.Widget +sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt = getHost True >>= sniTrayNewFromHost + 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 @@ -142,6 +142,14 @@ then Just <$> GI.pixbufNewFromFile iconName else return Nothing +loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf) +loadPixbufByName size name = do + iconTheme <- GI.Gtk.iconThemeGetDefault + hasIcon <- GI.Gtk.iconThemeHasIcon iconTheme name + if hasIcon + then GI.Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags + else return Nothing + alignCenter :: (GI.Gtk.IsWidget o, MonadIO m) => o -> m () alignCenter widget = GI.Gtk.setWidgetValign widget GI.Gtk.AlignCenter >> diff --git a/src/System/Taffybar/Widget/Volume.hs b/src/System/Taffybar/Widget/Volume.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/Volume.hs +++ /dev/null @@ -1,26 +0,0 @@ -module System.Taffybar.Widget.Volume - ( volumeTextNew - , volumeControlNew - ) where - -import Control.Monad.IO.Class -import Graphics.UI.Gtk -import System.Taffybar.Information.Volume -import System.Taffybar.Widget.Generic.PollingLabel - --- | Creates a new text volume meter -volumeTextNew :: MonadIO m => String -> String -> Double -> m Widget -volumeTextNew mixer control pollSeconds = liftIO $ do - l <- pollingLabelNew "" pollSeconds . fmap show $ getVolume mixer control - widgetShowAll l - return l - --- | Creates a new volume meter widget -volumeControlNew :: String -> String -> IO Widget -volumeControlNew mixer control = do - b <- volumeButtonNew - _ <- on b scaleButtonValueChanged $ \v -> - setVolume mixer control (v * 100) - let w = toWidget b - widgetShowAll w - return w 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 @@ -11,38 +11,7 @@ -- Portability : unportable ----------------------------------------------------------------------------- -module System.Taffybar.Widget.Workspaces - ( ControllerConstructor - , IconController(..) - , IconInfo(..) - , WWC(..) - , WindowData(..) - , Workspace(..) - , WorkspaceButtonController(..) - , WorkspaceContentsController(..) - , WorkspaceState(..) - , WorkspaceUnderlineController(..) - , WorkspaceWidgetController(..) - , WorkspacesConfig(..) - , WorkspacesContext(..) - , WorkspacesIO - , buildBorderButtonController - , buildButtonController - , buildContentsController - , buildIconController - , buildLabelController - , buildUnderlineButtonController - , buildUnderlineController - , buildWorkspaceData - , defaultBuildContentsController - , defaultGetIconInfo - , defaultWorkspacesConfig - , getWorkspaceToWindows - , hideEmpty - , liftX11Def - , workspacesNew - , windowTitleClassIconGetter -) where +module System.Taffybar.Widget.Workspaces where import Control.Applicative import Control.Arrow ((&&&)) @@ -51,6 +20,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.RateLimit import qualified Data.Char as Char @@ -76,7 +46,6 @@ import System.Log.Logger import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context -import System.Taffybar.EWMHPixbuf import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo @@ -84,6 +53,7 @@ import System.Taffybar.Widget.Decorators import System.Taffybar.Widget.Generic.AutoSizeImage (autoSizeImage) import System.Taffybar.Widget.Util +import System.Taffybar.WindowIcon import Text.Printf data WorkspaceState @@ -100,16 +70,6 @@ cssWorkspaceStates :: [String] cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent] -data IconInfo - = IIEWMH EWMHIconData - | IIFilePath FilePath - | IIColor ColorRGBA - | IINone - deriving (Eq, Show) - -transparentInfo :: IconInfo -transparentInfo = IIColor 0 - data WindowData = WindowData { windowId :: X11Window , windowTitle :: String @@ -131,7 +91,7 @@ data WorkspacesContext = WorkspacesContext { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC) , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace) - , hudWidget :: Gtk.HBox + , workspacesWidget :: Gtk.HBox , workspacesConfig :: WorkspacesConfig , taffyContext :: Context } @@ -183,6 +143,9 @@ type ParentControllerConstructor = ControllerConstructor -> ControllerConstructor +type WindowIconPixbufGetter = + Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf) + data WorkspacesConfig = WorkspacesConfig { widgetBuilder :: ControllerConstructor @@ -192,7 +155,7 @@ , underlinePadding :: Int , maxIcons :: Maybe Int , minIcons :: Int - , getIconInfo :: WindowData -> WorkspacesIO IconInfo + , getWindowIconPixbuf :: WindowIconPixbufGetter , labelSetter :: Workspace -> WorkspacesIO String , showWorkspaceFn :: Workspace -> Bool , borderWidth :: Int @@ -202,18 +165,6 @@ , urgentWorkspaceState :: Bool } -windowTitleClassIconGetter - :: (Bool -> String -> String -> IconInfo) - -> (WindowData -> WorkspacesIO IconInfo) -windowTitleClassIconGetter customIconF = fn - where - fn w@WindowData {windowTitle = wTitle, windowClass = wClass} = do - ewmhIcon <- defaultGetIconInfo w - let hasEwmhIcon = ewmhIcon /= IINone - custIcon = customIconF hasEwmhIcon wTitle wClass - hasCustomIcon = custIcon /= IINone - return $ if hasCustomIcon then custIcon else ewmhIcon - defaultWorkspacesConfig :: WorkspacesConfig defaultWorkspacesConfig = WorkspacesConfig @@ -224,7 +175,7 @@ , underlinePadding = 1 , maxIcons = Nothing , minIcons = 0 - , getIconInfo = defaultGetIconInfo + , getWindowIconPixbuf = defaultGetWindowIconPixbuf , labelSetter = return . workspaceName , showWorkspaceFn = const True , borderWidth = 2 @@ -321,7 +272,7 @@ addWidgetsToTopLevel = do WorkspacesContext { controllersVar = controllersRef - , hudWidget = cont + , workspacesWidget = cont } <- ask controllersMap <- lift $ MV.readMVar controllersRef -- Elems returns elements in ascending order of their keys so this will always @@ -331,7 +282,7 @@ addWidget :: WWC -> WorkspacesIO () addWidget controller = do - cont <- asks hudWidget + cont <- asks workspacesWidget let workspaceWidget = getWidget controller lift $ do -- XXX: This hbox exists to (hopefully) prevent the issue where workspace @@ -353,7 +304,7 @@ WorkspacesContext { controllersVar = controllersRef , workspacesVar = workspacesRef - , hudWidget = cont + , workspacesWidget = cont , workspacesConfig = cfg , taffyContext = tContext } @@ -431,11 +382,12 @@ updateWorkspaceControllers :: WorkspacesIO () updateWorkspaceControllers = do - WorkspacesContext { controllersVar = controllersRef - , workspacesVar = workspacesRef - , hudWidget = cont - , workspacesConfig = cfg - } <- ask + WorkspacesContext + { controllersVar = controllersRef + , workspacesVar = workspacesRef + , workspacesWidget = cont + , workspacesConfig = cfg + } <- ask workspacesMap <- lift $ MV.readMVar workspacesRef controllersMap <- lift $ MV.readMVar controllersRef @@ -574,29 +526,20 @@ , 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) +getPixbufForIconWidget transparentOnNone dataVar size = do + ctx <- ask + let tContext = taffyContext ctx + getPBFromData = getWindowIconPixbuf $ workspacesConfig ctx + getPB' = runMaybeT $ + MaybeT (lift $ MV.readMVar dataVar) >>= MaybeT . getPBFromData size + getPB = if transparentOnNone + then maybeTCombine getPB' (Just <$> pixBufFromColor size 0) + else getPB' + lift $ runReaderT getPB tContext buildIconWidget :: Bool -> Workspace -> WorkspacesIO IconWidget buildIconWidget transparentOnNone ws = do @@ -673,10 +616,63 @@ W.Requisition w _ <- W.widgetSizeRequest widget when (w < minWidth) $ W.widgetSetSizeRequest widget minWidth $ -1 -defaultGetIconInfo :: WindowData -> WorkspacesIO IconInfo -defaultGetIconInfo w = - maybe IINone IIEWMH <$> liftX11Def Nothing (getWindowIconsData $ windowId w) +scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter +scaledWindowIconPixbufGetter getter size = + getter size >=> + lift . traverse (scalePixbufToSize size GI.Gtk.OrientationHorizontal) +constantScaleWindowIconPixbufGetter :: Int32 + -> WindowIconPixbufGetter + -> WindowIconPixbufGetter +constantScaleWindowIconPixbufGetter constantSize getter = + const $ scaledWindowIconPixbufGetter getter constantSize + +getWindowIconPixbufFromEWMH :: WindowIconPixbufGetter +getWindowIconPixbufFromEWMH size windowData = + runX11Def Nothing (getIconPixBufFromEWMH size $ windowId windowData) + +getWindowIconPixbufFromClass :: WindowIconPixbufGetter +getWindowIconPixbufFromClass size windowData = + lift $ getWindowIconFromClasses size (windowClass windowData) + +getWindowIconPixbufFromDesktopEntry :: WindowIconPixbufGetter +getWindowIconPixbufFromDesktopEntry size windowData = + getWindowIconFromDesktopEntryByClasses size (windowClass windowData) + +defaultGetWindowIconPixbuf :: WindowIconPixbufGetter +defaultGetWindowIconPixbuf = + scaledWindowIconPixbufGetter unscaledDefaultGetWindowIconPixbuf + +unscaledDefaultGetWindowIconPixbuf :: WindowIconPixbufGetter +unscaledDefaultGetWindowIconPixbuf = + getWindowIconPixbufFromDesktopEntry <|||> + getWindowIconPixbufFromClass <|||> + getWindowIconPixbufFromEWMH + +addCustomIconsToDefaultWithFallbackByPath + :: (WindowData -> Maybe FilePath) + -> FilePath + -> WindowIconPixbufGetter +addCustomIconsToDefaultWithFallbackByPath getCustomIconPath fallbackPath = + addCustomIconsAndFallback + getCustomIconPath + (const $ lift $ getPixbufFromFilePath fallbackPath) + unscaledDefaultGetWindowIconPixbuf + +addCustomIconsAndFallback + :: (WindowData -> Maybe FilePath) + -> (Int32 -> TaffyIO (Maybe Gdk.Pixbuf)) + -> WindowIconPixbufGetter + -> WindowIconPixbufGetter +addCustomIconsAndFallback getCustomIconPath fallback defaultGetter = + scaledWindowIconPixbufGetter $ + getCustomIcon <|||> defaultGetter <|||> (\s _ -> fallback s) + where + getCustomIcon :: Int32 -> WindowData -> TaffyIO (Maybe Gdk.Pixbuf) + getCustomIcon _ wdata = + lift $ + maybe (return Nothing) getPixbufFromFilePath $ getCustomIconPath wdata + sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData] sortWindowsByPosition wins = do let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w) @@ -761,13 +757,6 @@ updateWidgetClasses iconButton [statusString] possibleStatusStrings void $ updateVar windowRef $ const $ return windowData lift $ updateIcon >> setIconWidgetProperties - -selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon -selectEWMHIcon imgSize icons = listToMaybe prefIcon - where sortedIcons = sortBy (comparing height) icons - smallestLargerIcon = take 1 $ dropWhile ((<= fromIntegral imgSize) . height) sortedIcons - largestIcon = take 1 $ reverse sortedIcons - prefIcon = smallestLargerIcon ++ largestIcon data WorkspaceButtonController = WorkspaceButtonController { button :: Gtk.EventBox diff --git a/src/System/Taffybar/WindowIcon.hs b/src/System/Taffybar/WindowIcon.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/WindowIcon.hs @@ -0,0 +1,122 @@ +module System.Taffybar.WindowIcon where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Bits +import Data.Int +import Data.List +import Data.Maybe +import qualified Data.MultiMap as MM +import Data.Ord +import qualified Data.Text as T +import Data.Word +import Foreign.Marshal.Alloc +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.Log.Logger +import System.Taffybar.Context +import System.Taffybar.Hooks +import System.Taffybar.Information.EWMHDesktopInfo +import System.Taffybar.Information.X11DesktopInfo +import System.Taffybar.Information.XDG.DesktopEntry +import System.Taffybar.Util +import System.Taffybar.Widget.Util + +type ColorRGBA = Word32 + +-- | 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 + +selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon +selectEWMHIcon imgSize icons = listToMaybe prefIcon + where sortedIcons = sortBy (comparing ewmhHeight) icons + smallestLargerIcon = take 1 $ dropWhile ((<= fromIntegral imgSize) . ewmhHeight) sortedIcons + largestIcon = take 1 $ reverse sortedIcons + prefIcon = smallestLargerIcon ++ largestIcon + +getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf) +getPixbufFromEWMHIcons size = traverse pixBufFromEWMHIcon . selectEWMHIcon size + +-- | Create a pixbuf from the pixel data in an EWMHIcon. +pixBufFromEWMHIcon :: EWMHIcon -> IO Gdk.Pixbuf +pixBufFromEWMHIcon EWMHIcon {ewmhWidth = w, ewmhHeight = h, ewmhPixelsARGB = px} = do + let width = fromIntegral w + height = fromIntegral h + rowStride = width * 4 + wPtr <- pixelsARGBToBytesABGR px (w * h) + Gdk.pixbufNewFromData wPtr Gdk.ColorspaceRgb True 8 + width height rowStride (Just free) + +getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Gdk.Pixbuf) +getIconPixBufFromEWMH size x11WindowId = runMaybeT $ do + ewmhData <- MaybeT $ getWindowIconsData x11WindowId + MaybeT $ lift $ withEWMHIcons ewmhData (getPixbufFromEWMHIcons size) + +-- | Create a pixbuf with the indicated RGBA color. +pixBufFromColor + :: MonadIO m + => Int32 -> Word32 -> m Gdk.Pixbuf +pixBufFromColor imgSize c = do + Just pixbuf <- Gdk.pixbufNew Gdk.ColorspaceRgb True 8 imgSize imgSize + Gdk.pixbufFill pixbuf c + return pixbuf + +getDirectoryEntryByClass + :: String + -> TaffyIO (Maybe DesktopEntry) +getDirectoryEntryByClass klass = do + entries <- MM.lookup klass <$> getDirectoryEntriesByClassName + when (length entries > 1) $ + logPrintF "System.Taffybar.WindowIcon" INFO "Multiple entries for: %s" (klass, entries) + return $ listToMaybe entries + +getWindowIconForAllClasses + :: Monad m + => (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a) +getWindowIconForAllClasses doOnClass size klass = + foldl combine (return Nothing) $ parseWindowClasses klass + where + combine soFar theClass = + maybeTCombine soFar (doOnClass size theClass) + +getWindowIconFromDesktopEntryByClasses :: Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf) +getWindowIconFromDesktopEntryByClasses = + getWindowIconForAllClasses getWindowIconFromDesktopEntryByClass + where getWindowIconFromDesktopEntryByClass size klass = + runMaybeT $ do + entry <- MaybeT $ getDirectoryEntryByClass klass + MaybeT $ lift $ getImageForDesktopEntry size entry + +getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf) +getWindowIconFromClasses = + getWindowIconForAllClasses getWindowIconFromClass + where getWindowIconFromClass size klass = loadPixbufByName size (T.pack klass) diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,5 +1,5 @@ name: taffybar -version: 2.1.0 +version: 2.1.1 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE @@ -17,8 +17,10 @@ README.md CHANGELOG.md taffybar.hs.example + dbus-xml/org.freedesktop.UPower.Device.xml + dbus-xml/org.freedesktop.UPower.xml dbus-xml/org.mpris.MediaPlayer2.Player.xml - + dbus-xml/org.mpris.MediaPlayer2.xml description: Taffybar is a gtk+3 (through gtk2hs) based desktop information bar, intended @@ -37,7 +39,6 @@ default-language: Haskell2010 build-depends: base > 3 && < 5 - , alsa-mixer >= 0.2.0 , ConfigFile , HStringTemplate >= 0.8 && < 0.9 , HTTP @@ -104,7 +105,6 @@ , System.Taffybar.Context , System.Taffybar.DBus , System.Taffybar.DBus.Toggle - , System.Taffybar.EWMHPixbuf , System.Taffybar.Hooks , System.Taffybar.Information.Battery , System.Taffybar.Information.CPU @@ -116,12 +116,12 @@ , System.Taffybar.Information.Network , System.Taffybar.Information.SafeX11 , System.Taffybar.Information.StreamInfo - , System.Taffybar.Information.Volume , System.Taffybar.Information.X11DesktopInfo , System.Taffybar.Information.XDG.DesktopEntry , System.Taffybar.Information.XDG.Protocol , System.Taffybar.SimpleConfig , System.Taffybar.Support.PagerHints + , System.Taffybar.Util , System.Taffybar.Widget , System.Taffybar.Widget.Battery , System.Taffybar.Widget.CPUMonitor @@ -150,12 +150,12 @@ , System.Taffybar.Widget.Text.MemoryMonitor , System.Taffybar.Widget.Text.NetworkMonitor , System.Taffybar.Widget.Util - , System.Taffybar.Widget.Volume , System.Taffybar.Widget.Weather , System.Taffybar.Widget.Windows , System.Taffybar.Widget.Workspaces , System.Taffybar.Widget.XDGMenu.Menu , System.Taffybar.Widget.XDGMenu.MenuWidget + , System.Taffybar.WindowIcon other-modules: Paths_taffybar , System.Taffybar.DBus.Client.MPRIS2 @@ -163,7 +163,6 @@ , System.Taffybar.DBus.Client.UPower , System.Taffybar.DBus.Client.UPowerDevice , System.Taffybar.DBus.Client.Util - , System.Taffybar.Util cc-options: -fPIC ghc-options: -Wall -funbox-strict-fields -fno-warn-orphans diff --git a/taffybar.hs.example b/taffybar.hs.example --- a/taffybar.hs.example +++ b/taffybar.hs.example @@ -64,13 +64,16 @@ clock = textClockNew Nothing "%a %b %_d %r" 1 layout = layoutNew defaultLayoutConfig windows = windowsNew defaultWindowsConfig + -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher + -- for a better way to set up the sni tray + tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt myConfig = defaultSimpleTaffyConfig { startWidgets = workspaces : map (>>= buildContentsBox) [ layout, windows ] , endWidgets = map (>>= buildContentsBox) [ batteryIconNew , clock - , sniTrayNew + , tray , cpu , mem , net