taffybar 0.4.6 → 1.0.0
raw patch · 44 files changed
+4045/−967 lines, 44 filesdep +ConfigFiledep +alsa-mixerdep +directorydep −gtkdep ~dbusdep ~gtk-traymanagerdep ~mtlnew-uploader
Dependencies added: ConfigFile, alsa-mixer, directory, either, glib, gtk3, multimap, rate-limit, taffybar, time-units, tuple, unix, xml, xml-helpers
Dependencies removed: gtk
Dependency ranges changed: dbus, gtk-traymanager, mtl, process, time
Files
- CHANGELOG.md +44/−0
- README.md +20/−7
- src/System/Information/Battery.hs +23/−21
- src/System/Information/EWMHDesktopInfo.hs +66/−3
- src/System/Information/Memory.hs +18/−7
- src/System/Information/Network.hs +20/−12
- src/System/Information/SafeX11.hsc +214/−0
- src/System/Information/Volume.hs +38/−0
- src/System/Information/X11DesktopInfo.hs +80/−14
- src/System/Taffybar.hs +259/−87
- src/System/Taffybar/Battery.hs +135/−75
- src/System/Taffybar/FreedesktopNotifications.hs +137/−175
- src/System/Taffybar/Hooks/PagerHints.hs +4/−4
- src/System/Taffybar/IconImages.hs +107/−0
- src/System/Taffybar/LayoutSwitcher.hs +19/−17
- src/System/Taffybar/MPRIS.hs +7/−4
- src/System/Taffybar/MPRIS2.hs +10/−9
- src/System/Taffybar/Menu/DesktopEntry.hs +179/−0
- src/System/Taffybar/Menu/Menu.hs +124/−0
- src/System/Taffybar/Menu/MenuWidget.hs +129/−0
- src/System/Taffybar/Menu/XdgMenu.hs +277/−0
- src/System/Taffybar/NetMonitor.hs +89/−36
- src/System/Taffybar/Pager.hs +98/−23
- src/System/Taffybar/SimpleClock.hs +12/−10
- src/System/Taffybar/Systray.hs +0/−3
- src/System/Taffybar/TaffyPager.hs +35/−9
- src/System/Taffybar/ToggleMonitor.hs +125/−0
- src/System/Taffybar/Util.hs +20/−0
- src/System/Taffybar/Volume.hs +28/−0
- src/System/Taffybar/Weather.hs +57/−38
- src/System/Taffybar/Widgets/Graph.hs +64/−51
- src/System/Taffybar/Widgets/Icon.hs +58/−0
- src/System/Taffybar/Widgets/PollingLabel.hs +23/−1
- src/System/Taffybar/Widgets/Util.hs +16/−6
- src/System/Taffybar/Widgets/VerticalBar.hs +87/−45
- src/System/Taffybar/WindowSwitcher.hs +42/−52
- src/System/Taffybar/WorkspaceHUD.hs +1000/−0
- src/System/Taffybar/WorkspaceSwitcher.hs +206/−41
- src/System/Taffybar/XMonadLog.hs +0/−119
- src/gdk_property_change_wrapper.c +2/−1
- taffybar.cabal +99/−62
- taffybar.css +65/−0
- taffybar.hs.example +9/−9
- taffybar.rc +0/−26
CHANGELOG.md view
@@ -1,3 +1,47 @@+# 1.0.0++## Breaking Changes++ * Migrate from Gtk2 to Gtk3, which replaces rc theming with css theming (Ivan Malison)++## New Features++ * Support for taffybar on multiple monitors (Ivan Malison)+ * D-Bus toggling of taffybar per monitor (Ivan Malison)+ * A new workspace switcher widget called WorkspaceHUD (Ivan Malison)+ * Support for multiple batteries via ``batteryContextsNew`` (Edd Steel)+ * Add support for IO actions to configure vertical bar widgets+ * Images in WorkspaceSwitcher - images are taken from EWMH via \_NET\_WM_ICON (Elliot Wolk)+ * Preliminary support for i3wm (Saksham Sharma)+ * Support for multiple network interfaces in NetMonitor (Robert Klotzner)+ * Add a pager config field that configures the construction of window switcher titles (Ivan Malison)+ * Quick start script for installing from git with stack (Ivan Malison)+ * Add a volume widget (Nick Hu and Abdul Sattar)+ * Add available memory field to MemoryInfo (Will Price)+ * The freedesktop.org notifications widget now allows for notifications to+ never expire and can handle multiple notifications at once. In particular the+ default formatter now shows the number of pending notifications (Daniel+ Oliveira)+ * Battery bar is more informative (Samshak Sharma)+ * Network monitor speeds are auto formatted to use the most appropriate units (TeXitoi)+ * A new freedesktop.org menu widget (u11gh)++...and many smaller tweaks.++## Bug Fixes++ * Fixes for outdated weather information sources+ * Various styling fixes in the gtkrc code+ * Share a single X11Connection between all components to fix the `user error+ (openDisplay)` error (Ivan Malison)+ * Call initThreads at startup. This fixes ```taffybar-linux-x86_64:+ xcb_io.c:259: poll_for_event: Assertion `!xcb_xlib_threads_sequence_lost'+ failed.``` (Ivan Malison)+ * Add an eventBox to window switcher to allow setting its background (Ivan Malison)+ * #105 Prevent taffybar from crashing when two windows are closed+ simultaneously, or when taffybar otherwise requests data about a window that+ no longer exists.+ # 0.4.6 * Fix a longstanding bug in loading .rc files (Peder Stray)
README.md view
@@ -1,3 +1,5 @@+[](https://travis-ci.org/travitch/taffybar)+ This is a desktop information bar intended for use with XMonad and similar window managers. It is similar in spirit to xmobar; it is different in that it gives up some simplicity for a reasonable helping@@ -22,18 +24,29 @@ There are also several more specialized widgets: * Battery widget+ * Volume widget+ * Network activity * Textual clock * Freedesktop.org notifications (via dbus) * MPRIS1 and MPRIS2 widgets * Weather widget- * XMonad log widget (listens on dbus instead of stdin)+ * Workspace, Window and Layout switchers * System tray+ * Freedesktop.org menu -TODO-====+[See full documentation of release version here.](https://hackage.haskell.org/package/taffybar) -An incomplete list of things that would be cool to have:+Installation+============+**NOTE**: `gtk2hs-buildtools` is needed for installations with GHC 8 and above, till there's better support for `setup-depends`. - * xrandr widget (for dealing changing clone/extend mode and orientation)- * Better behavior when adding/removing monitors (never tried it)- * Make MPRIS more configurable+### Cabal+```+cabal install taffybar+```++### Stack+```+stack install gtk2hs-buildtools+stack install taffybar+```
src/System/Information/Battery.hs view
@@ -10,18 +10,18 @@ BatteryTechnology(..), BatteryType(..), -- * Accessors- batteryContextNew,+ batteryContextsNew, getBatteryInfo ) where import Data.Map ( Map ) import qualified Data.Map as M-import Data.Maybe ( fromMaybe )+import Data.Maybe ( fromMaybe, maybeToList ) import Data.Word import Data.Int import DBus import DBus.Client-import Data.List ( find, isInfixOf )+import Data.List ( isInfixOf ) import Data.Text ( Text ) import qualified Data.Text as T import Safe ( atMay )@@ -90,11 +90,16 @@ -} } --- | Find the first power source that is a battery in the list. The--- simple heuristic is a substring search on 'BAT'-firstBattery :: [ObjectPath] -> Maybe ObjectPath-firstBattery = find (isInfixOf "BAT" . formatObjectPath)+-- | determine if a power source is a battery. The simple heuristic is a+-- substring search on 'BAT'.+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"@@ -168,20 +173,17 @@ toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0 } --- | Construct a battery context if possible. This could fail if the--- UPower daemon is not running. The context can be used to get--- actual battery state with 'getBatteryInfo'.-batteryContextNew :: IO (Maybe BatteryContext)-batteryContextNew = do- systemConn <- connectSystem - -- First, get the list of devices. For now, we just get the stats- -- for the first battery- reply <- call_ systemConn (methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices")- { methodCallDestination = Just powerBusName- }+-- | 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 <- methodReturnBody reply `atMay` 0- powerDevices <- fromVariant body- battPath <- firstBattery powerDevices+ body <- take 1 $ methodReturnBody reply+ powerDevices <- maybeToList $ fromVariant body+ battPath <- batteries powerDevices return $ BC systemConn battPath
src/System/Information/EWMHDesktopInfo.hs view
@@ -23,6 +23,7 @@ ( X11Window -- re-exported from X11DesktopInfo , X11WindowHandle , WorkspaceIdx(..)+ , EWMHIcon(..) , withDefaultCtx -- re-exported from X11DesktopInfo , isWindowUrgent -- re-exported from X11DesktopInfo , getCurrentWorkspace@@ -32,6 +33,7 @@ , switchOneWorkspace , getWindowTitle , getWindowClass+ , getWindowIcons , getActiveWindowTitle , getWindows , getWindowHandles@@ -39,9 +41,21 @@ , focusWindow ) where -import Control.Applicative ((<$>))+import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Maybe (listToMaybe, mapMaybe, fromMaybe) import Data.Tuple (swap)-import Data.Maybe (listToMaybe, mapMaybe)+import Data.Word+import Debug.Trace+import Foreign.ForeignPtr+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import System.Information.SafeX11++import Prelude+ import System.Information.X11DesktopInfo -- | Convenience alias for a pair of the form (props, window), where props is a@@ -52,6 +66,21 @@ newtype WorkspaceIdx = WSIdx Int deriving (Show, Read, Ord, Eq) +-- A super annoying detail of the XGetWindowProperty interface is that: "If the+-- returned format is 32, the returned data is represented as a long array and+-- should be cast to that type to obtain the elements." This means that even+-- though only the 4 least significant bits will ever contain any data, the+-- array that is returned from X11 can have a larger word size. This means that+-- we need to manipulate the underlying data in annoying ways to pass it to gtk+-- appropriately.+type PixelsWordType = Word64++data EWMHIcon = EWMHIcon+ { width :: Int+ , height :: Int+ , pixelsARGB :: Ptr PixelsWordType+ } deriving (Show, Eq)+ noFocus :: String noFocus = "..." @@ -67,7 +96,7 @@ vis <- getVisibleTags allNames <- map swap <$> getWorkspaceNames cur <- getCurrentWorkspace- return $ cur : mapMaybe (flip lookup allNames) vis+ return $ cur : mapMaybe (`lookup` allNames) vis -- | Return a list with the names of all the workspaces currently -- available.@@ -112,6 +141,40 @@ -- | Get the class of the given X11 window. getWindowClass :: X11Window -> X11Property String getWindowClass window = readAsString (Just window) "WM_CLASS"++-- | Get list of icon ARGB data from EWMH+getWindowIcons :: X11Window -> X11Property [EWMHIcon]+getWindowIcons window = fromMaybe [] <$> do+ dpy <- getDisplay+ atom <- getAtom "_NET_WM_ICON"+ lift $ runMaybeT $ do+ (ptr, arraySize) <- MaybeT $ rawGetWindowPropertyBytes 32 dpy atom window+ ics <- lift $ withForeignPtr ptr $ parseIcons arraySize+ return ics++-- | Split icon raw integer data into EWMHIcons.+-- Each icon raw data is an integer for width,+-- followed by height,+-- followed by exactly (width*height) ARGB pixels,+-- optionally followed by the next icon.+parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon]+parseIcons 0 _ = return []+parseIcons totalSize arr = do+ iwidth <- fromIntegral <$> peek arr+ iheight <- fromIntegral <$> peekElemOff arr 1+ let pixelsPtr = advancePtr arr 2+ thisSize = iwidth * iheight+ newArr = advancePtr pixelsPtr thisSize+ thisIcon =+ EWMHIcon+ { width = iwidth+ , height = iheight+ , pixelsARGB = pixelsPtr+ }+ getRes newSize+ | newSize < 0 = trace "This should not happen parseIcons" return []+ | otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going+ getRes $ totalSize - fromIntegral (thisSize + 2) withActiveWindow :: (X11Window -> X11Property String) -> X11Property String withActiveWindow getProp = do
src/System/Information/Memory.hs view
@@ -10,23 +10,31 @@ , memoryFree :: Double , memoryBuffer :: Double , memoryCache :: Double+ , memorySwapTotal :: Double+ , memorySwapFree :: Double+ , memorySwapUsed :: Double -- swapTotal - swapFree+ , memorySwapUsedRatio :: Double -- swapUsed / swapTotal+ , memoryAvailable :: Double -- An estimate of how much memory is available for starting new apps , memoryRest :: Double -- free + buffer + cache , memoryUsed :: Double -- total - rest , memoryUsedRatio :: Double -- used / total } emptyMemoryInfo :: MemoryInfo-emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0+emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0 parseLines :: [String] -> MemoryInfo -> MemoryInfo parseLines (line:rest) memInfo = parseLines rest newMemInfo where (label:size:_) = words line newMemInfo = case label of- "MemTotal:" -> memInfo { memoryTotal = toMB size }- "MemFree:" -> memInfo { memoryFree = toMB size }- "Buffers:" -> memInfo { memoryBuffer = toMB size }- "Cached:" -> memInfo { memoryCache = toMB size }- _ -> memInfo+ "MemTotal:" -> memInfo { memoryTotal = toMB size }+ "MemFree:" -> memInfo { memoryFree = toMB size }+ "MemAvailable:" -> memInfo { memoryAvailable = toMB size }+ "Buffers:" -> memInfo { memoryBuffer = toMB size }+ "Cached:" -> memInfo { memoryCache = toMB size }+ "SwapTotal:" -> memInfo { memorySwapTotal = toMB size }+ "SwapFree:" -> memInfo { memorySwapFree = toMB size }+ _ -> memInfo parseLines _ memInfo = memInfo parseMeminfo :: IO MemoryInfo@@ -36,8 +44,11 @@ rest = memoryFree m + memoryBuffer m + memoryCache m used = memoryTotal m - rest usedRatio = used / memoryTotal m+ swapUsed = memorySwapTotal m - memorySwapFree m+ swapUsedRatio = swapUsed / memorySwapTotal m return m { memoryRest = rest , memoryUsed = used , memoryUsedRatio = usedRatio+ , memorySwapUsed = swapUsed+ , memorySwapUsedRatio = swapUsedRatio }-
src/System/Information/Network.hs view
@@ -17,26 +17,27 @@ module System.Information.Network ( getNetInfo ) where import Control.Applicative+import Control.Monad+import Control.Exception (catch, SomeException) import Data.Maybe ( mapMaybe ) import Safe ( atMay, initSafe, readDef ) import System.Information.StreamInfo ( getParsedInfo )+import Control.Monad.Trans.Maybe (MaybeT(..)) import Prelude -- | Returns a two-element list containing the current number of bytes -- received and transmitted via the given network interface (e.g. \"wlan0\"), -- according to the contents of the @\/proc\/dev\/net@ file.-getNetInfo :: String -> IO (Maybe [Integer])-getNetInfo iface = do- isUp <- isInterfaceUp iface- case isUp of- True -> Just <$> getParsedInfo "/proc/net/dev" parse iface- False -> return Nothing+getNetInfo :: String -> IO (Maybe [Int])+getNetInfo iface = runMaybeT $ do+ isInterfaceUp iface+ handleFailure $ getParsedInfo "/proc/net/dev" parse iface -parse :: String -> [(String, [Integer])]+parse :: String -> [(String, [Int])] parse = mapMaybe tuplize . map words . drop 2 . lines -tuplize :: [String] -> Maybe (String, [Integer])+tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do dev <- initSafe <$> s `atMay` 0 down <- readDef (-1) <$> s `atMay` 1@@ -45,9 +46,16 @@ where out = (length s) - 8 -isInterfaceUp :: String -> IO Bool+-- Nothing if interface does not exist or is down+isInterfaceUp :: String -> MaybeT IO () isInterfaceUp iface = do- state <- readFile $ "/sys/class/net/" ++ iface ++ "/operstate"+ state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate" case state of- 'u' : _ -> return True- _ -> return False+ 'u' : _ -> return ()+ _ -> mzero++handleFailure :: IO a -> MaybeT IO a+handleFailure action = MaybeT $ catch (Just <$> action) eToNothing+ where+ eToNothing :: SomeException -> IO (Maybe a)+ eToNothing _ = pure Nothing
+ src/System/Information/SafeX11.hsc view
@@ -0,0 +1,214 @@+{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,+ InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Information.SafeX11+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Information.SafeX11 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+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32,+ xGetWMHints, getWMHints)+import Prelude+import Graphics.X11.Xlib.Types+import System.IO+import System.IO.Unsafe+import System.Timeout++foreign import ccall safe "XlibExtras.h XGetWMHints"+ safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)++foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"+ safeXGetWindowProperty ::+ Display ->+ Window ->+ Atom ->+ CLong ->+ CLong ->+ Bool ->+ Atom ->+ Ptr Atom ->+ Ptr CInt ->+ Ptr CULong ->+ Ptr CULong ->+ Ptr (Ptr CUChar) -> IO Status++rawGetWindowPropertyBytes+ :: Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))+rawGetWindowPropertyBytes bits d atom w =+ alloca $ \actual_type_return ->+ alloca $ \actual_format_return ->+ alloca $ \nitems_return ->+ alloca $ \bytes_after_return ->+ alloca $ \prop_return -> do+ ret <- postX11RequestSync $+ safeXGetWindowProperty+ d+ w+ atom+ 0+ 0xFFFFFFFF+ False+ anyPropertyType+ actual_type_return+ actual_format_return+ nitems_return+ bytes_after_return+ prop_return+ if fromRight (-1) ret /= 0+ then return Nothing+ else do+ prop_ptr <- peek prop_return+ actual_format <- fromIntegral `fmap` peek actual_format_return+ nitems <- fromIntegral `fmap` peek nitems_return+ getprop prop_ptr nitems actual_format+ where+ getprop prop_ptr nitems actual_format+ | actual_format == 0 = return Nothing -- Property not found+ | actual_format /= bits = xFree prop_ptr >> return Nothing+ | otherwise = do+ ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)+ return $ Just (ptr, nitems)++data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)++instance Exception SafeX11Exception++data IORequest = forall a. IORequest+ { ioAction :: IO a+ , ioResponse :: Chan (Either SafeX11Exception a)+ }++{-# NOINLINE requestQueue #-}+requestQueue :: Chan IORequest+requestQueue = unsafePerformIO newChan++{-# NOINLINE x11Thread #-}+x11Thread :: ThreadId+x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests++withErrorHandler :: XErrorHandler -> IO a -> IO a+withErrorHandler new_handler action = do+ handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)+ original <- _xSetErrorHandler handler+ res <- action+ _ <- _xSetErrorHandler original+ return res++deriving instance Show ErrorEvent++startHandlingX11Requests :: IO ()+startHandlingX11Requests =+ withErrorHandler handleError handleX11Requests+ where handleError _ xerrptr = do+ putStrLn "Got error"+ ee <- getErrorEvent xerrptr+ print ee++handleX11Requests :: IO ()+handleX11Requests = do+ IORequest {ioAction = action, ioResponse = responseChannel} <-+ readChan requestQueue+ res <-+ catch+ (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)+ (\e -> do+ putStrLn "Got error on X11 thread"+ hFlush stdout+ print (e :: IOException)+ return $ Left SafeX11Exception)+ writeChan responseChannel res+ handleX11Requests+ return ()++postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)+postX11RequestSync action = do+ let postAndWait = do+ responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))+ writeChan+ requestQueue+ IORequest {ioAction = action, ioResponse = responseChannel}+ readChan responseChannel+ currentTID <- myThreadId+ if currentTID == x11Thread+ then Right <$> action+ else postAndWait++postX11RequestSyncDef :: a -> IO a -> IO a+postX11RequestSyncDef def action =+ fromRight def <$> postX11RequestSync action++rawGetWindowProperty ::+ Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe [a])+rawGetWindowProperty bits d atom w =+ runMaybeT $ do+ (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w+ lift $ withForeignPtr ptr $ peekArray count++getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])+getWindowProperty8 = rawGetWindowProperty 8++getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])+getWindowProperty16 = rawGetWindowProperty 16++getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])+getWindowProperty32 = rawGetWindowProperty 32++getWMHints :: Display -> Window -> IO WMHints+getWMHints dpy w = do+ p <- safeXGetWMHints dpy w+ if p == nullPtr+ then return $ WMHints 0 False 0 0 0 0 0 0 0+ else do x <- peek p; _ <- xFree p; return x++safeGetGeometry :: Display -> Drawable ->+ IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)+safeGetGeometry display d =+ outParameters7 (throwIfZero "getGeometry") $+ xGetGeometry display d++outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>+ (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->+ IO (a,b,c,d,e,f,g)+outParameters7 check fn =+ alloca $ \ a_return ->+ alloca $ \ b_return ->+ alloca $ \ c_return ->+ alloca $ \ d_return ->+ alloca $ \ e_return ->+ alloca $ \ f_return ->+ alloca $ \ g_return -> do+ check (fn a_return b_return c_return d_return e_return f_return g_return)+ a <- peek a_return+ b <- peek b_return+ c <- peek c_return+ d <- peek d_return+ e <- peek e_return+ f <- peek f_return+ g <- peek g_return+ return (a,b,c,d,e,f,g)++foreign import ccall safe "HsXlib.h XGetGeometry"+ xGetGeometry :: Display -> Drawable ->+ Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->+ Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
+ src/System/Information/Volume.hs view
@@ -0,0 +1,38 @@+module System.Information.Volume (+ getVolume,+ setVolume+) where++import Sound.ALSA.Mixer++-- | Gets volume of a channel of a mixer+getVolume :: String -> String -> IO Integer+getVolume mix channel = withMixer mix $ \mixer -> do+ Just control <- getControlByName mixer channel+ let Just playbackVolume = playback $ volume control+ (lo, hi) <- getRange playbackVolume+ 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 = withMixer mix $ \mixer -> do+ Just control <- getControlByName mixer channel+ let Just playbackVolume = playback $ volume control+ (lo, hi) <- getRange playbackVolume+ setChannel FrontLeft (value playbackVolume) $ fromPercent vol lo hi+ setChannel FrontRight (value playbackVolume) $ fromPercent vol lo hi+ setChannel RearLeft (value playbackVolume) $ fromPercent vol lo hi+ setChannel RearRight (value playbackVolume) $ fromPercent vol lo hi+ setChannel FrontCenter (value playbackVolume) $ fromPercent vol lo hi++toPercent :: Integer -> Integer -> Integer -> Integer+toPercent v lo hi = ceiling $ (v' - lo') / (hi' - lo') * 100+ where 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
src/System/Information/X11DesktopInfo.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : System.Information.X11DesktopInfo@@ -19,31 +20,46 @@ ----------------------------------------------------------------------------- module System.Information.X11DesktopInfo- ( X11Context+ ( X11Context(..) , X11Property , X11Window , withDefaultCtx+ , getDefaultCtx+ , getWindowState+ , getWindowStateProperty , readAsInt+ , readAsListOfInt , readAsString , readAsListOfString , readAsListOfWindow , isWindowUrgent , getVisibleTags , getAtom+ , getDisplay , eventLoop , sendCommandEvent , sendWindowEvent+ , postX11RequestSyncProp+ , getPrimaryOutputNumber ) where +import Data.List+import Data.Maybe+ import Codec.Binary.UTF8.String as UTF8 import Control.Monad.Reader import Data.Bits (testBit, (.|.)) import Data.List.Split (endBy)-import Data.Maybe (fromMaybe) import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32,+ getWMHints)+import Graphics.X11.Xrandr+import Prelude+import System.Information.SafeX11 -data X11Context = X11Context { contextDisplay :: Display, contextRoot :: Window }+data X11Context = X11Context { contextDisplay :: Display, _contextRoot :: Window } type X11Property a = ReaderT X11Context IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])@@ -57,6 +73,9 @@ closeDisplay (contextDisplay ctx) return res +getDisplay :: X11Property Display+getDisplay = contextDisplay <$> ask+ -- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a value of type Int. If that -- property hasn't been set, then return -1.@@ -70,6 +89,18 @@ _ -> return (-1) -- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of Ints. If that+-- property hasn't been set, then return an empty list.+readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property [Int]+readAsListOfInt window name = do+ prop <- fetch getWindowProperty32 window name+ case prop of+ Just xs -> return (map fromIntegral xs)+ _ -> return []++-- | Retrieve the property of the given window (or the root window, -- if Nothing) with the given name as a String. If the property -- hasn't been set, then return an empty string. readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.@@ -119,15 +150,13 @@ -- instructions on how to do this), or an empty list of strings if the -- PagerHints hook is not available. getVisibleTags :: X11Property [String]-getVisibleTags = return =<<- readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"+getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES" -- | Return the Atom with the given name. getAtom :: String -> X11Property Atom getAtom s = do (X11Context d _) <- ask- atom <- liftIO $ internAtom d s False- return atom+ liftIO $ internAtom d s False -- | Spawn a new thread and listen inside it to all incoming events, -- invoking the given function to every event of type @MapNotifyEvent@ that@@ -137,12 +166,11 @@ eventLoop dispatch = do (X11Context d w) <- ask liftIO $ do- xSetErrorHandler selectInput d w $ propertyChangeMask .|. substructureNotifyMask allocaXEvent $ \e -> forever $ do event <- nextEvent d e >> getEvent e case event of- MapNotifyEvent _ _ _ _ _ window _ -> do+ MapNotifyEvent _ _ _ _ _ window _ -> selectInput d window propertyChangeMask _ -> return () dispatch event@@ -169,6 +197,19 @@ w <- rootWindow d $ defaultScreen d return $ X11Context d w +getWindowStateProperty :: X11Window -> String -> X11Property Bool+getWindowStateProperty window property = not . null <$> getWindowState window [property]++getWindowState :: X11Window -> [String] -> X11Property [String]+getWindowState window request = do+ let getAsLong s = fromIntegral <$> getAtom s+ integers <- mapM getAsLong request+ properties <- fetch getWindowProperty32 (Just window) "_NET_WM_STATE"+ let integerToString = zip integers request+ present = intersect integers $ fromMaybe [] properties+ presentStrings = map (`lookup` integerToString) present+ return $ catMaybes presentStrings+ -- | Apply the given function to the given window in order to obtain the X11 -- property with the given name, or Nothing if no such property can be read. fetch :: (Integral a)@@ -179,15 +220,13 @@ fetch fetcher window name = do (X11Context dpy root) <- ask atom <- getAtom name- prop <- liftIO $ fetcher dpy atom (fromMaybe root window)- return prop+ liftIO $ fetcher dpy atom (fromMaybe root window) -- | Retrieve the @WM_HINTS@ mask assigned by the X server to the given window. fetchWindowHints :: X11Window -> X11Property WMHints fetchWindowHints window = do (X11Context d _) <- ask- hints <- liftIO $ getWMHints d window- return hints+ liftIO $ getWMHints d window -- | Emit an event of type @ClientMessage@ that can be listened to and -- consumed by XMonad event hooks.@@ -197,9 +236,36 @@ -> X11Window -> X11Window -> X11Property ()-sendCustomEvent dpy cmd arg root win = do+sendCustomEvent dpy cmd arg root win = liftIO $ allocaXEvent $ \e -> do setEventType e clientMessage setClientMessageEvent e win cmd 32 arg currentTime sendEvent dpy root False structureNotifyMask e sync dpy False++postX11RequestSyncProp :: X11Property a -> a -> X11Property a+postX11RequestSyncProp prop def = do+ c <- ask+ let action = runReaderT prop c+ lift $ postX11RequestSyncDef def action++isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool+isActiveOutput sres output = do+ (X11Context display _) <- ask+ maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output+ return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0++getActiveOutputs :: X11Property [RROutput]+getActiveOutputs = do+ (X11Context display rootw) <- ask+ maybeSres <- liftIO $ xrrGetScreenResources display rootw+ maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres)+ maybeSres++-- | Get the index of the primary monitor as set and ordered by Xrandr.+getPrimaryOutputNumber :: X11Property (Maybe Int)+getPrimaryOutputNumber = do+ (X11Context display rootw) <- ask+ primary <- liftIO $ xrrGetOutputPrimary display rootw+ outputs <- getActiveOutputs+ return $ primary `elemIndex` outputs
src/System/Taffybar.hs view
@@ -86,15 +86,15 @@ -- > main = do -- > client <- connectSession -- > let pp = defaultPP- -- > xmonad defaultConfig { logHook = dbusLog client pp- -- > , manageHook = manageDocks- -- > }+ -- > xmonad $ docks defaultConfig { logHook = dbusLog client pp } --- -- The complexity is handled in the System.Tafftbar.XMonadLog- -- module. Note that manageDocks is required to have XMonad put- -- taffybar in the strut space that it reserves. If you have- -- problems with taffybar appearing almost fullscreen, check to- -- see if you have manageDocks in your manageHook.+ -- The complexity is handled in the System.Taffybar.XMonadLog module. Note+ -- that the docks wrapper from ManageDocks is required to have XMonad put+ -- taffybar in the strut space that it reserves. If you have problems with+ -- taffybar appearing almost fullscreen, check to see if you are using this+ -- wrapper. Note that the manageDocks hook that previous used to be sufficient+ -- for this is no longer so (see+ -- https://github.com/travitch/taffybar/issues/185). -- ** A note about DBus: -- |@@ -118,32 +118,97 @@ -- customize this theme by copying it to -- @~\/.config\/taffybar\/taffybar.rc@. For an idea of the customizations you can make, -- see <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.++ -- * Advanced Widget Example+ --+ -- | The following is an example leveraging GTK+ features that are not exposed+ -- by the normal Taffybar widget hooks.+ --+ -- > import qualified Graphics.UI.Gtk as Gtk+ -- > import System.Taffybar.Widgets.PollingGraph+ -- > import System.Information.CPU+ -- > import XMonad.Util.Run+ -- >+ -- > main = do+ -- > let+ -- > cpuReader widget = do+ -- > (userLoad, systemLoad, totalLoad) <- cpuLoad+ -- > Gtk.postGUIAsync $ do+ -- > let+ -- > user = round $ 100 * userLoad :: Int+ -- > system = round $ 100 * systemLoad :: Int+ -- > tooltip = printf "%02i%% User\n%02i%% System" user system :: String+ -- > _ <- Gtk.widgetSetTooltipText widget $ Just tooltip+ -- > return ()+ -- > return [totalLoad, systemLoad]+ -- >+ -- > cpuButtons = do+ -- > e <- Gtk.eventButton+ -- > case e of+ -- > Gtk.LeftButton -> unsafeSpawn "terminator -e glances"+ -- > Gtk.RightButton -> unsafeSpawn "terminator -e top"+ -- > Gtk.MiddleButton -> unsafeSpawn "gnome-system-monitor"+ -- > _ -> return ()+ -- > return True+ -- >+ -- > cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1)+ -- > , (1, 0, 1, 0.5)+ -- > ]+ -- > }+ -- >+ -- >+ -- > cpu = do+ -- > ebox <- Gtk.eventBoxNew+ -- > btn <- pollingGraphNew cpuCfg 0.5 $ cpuReader $ Gtk.toWidget ebox+ -- > Gtk.containerAdd ebox btn+ -- > _ <- Gtk.on ebox Gtk.buttonPressEvent systemEvents+ -- > Gtk.widgetShowAll ebox+ -- > return $ Gtk.toWidget ebox+ --+ -- The resulting widget can be used like normal widgets, but you can use+ -- different mouse buttons to run various programs and it has a useful tooltip+ -- which shows the concrete numbers, which may not be clear in the graph+ -- itself.+ TaffybarConfig(..),+ TaffybarConfigEQ, defaultTaffybar, defaultTaffybarConfig, Position(..),- taffybarMain+ taffybarMain,+ allMonitors,+ useMonitorNumber,+ realMain,+ usePrimaryMonitor, ) where import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre-import Control.Monad ( when )+import qualified Control.Concurrent.MVar as MV+import Control.Monad ( when, foldM, void )+import Data.List+import qualified Data.Map as M import Data.Maybe ( fromMaybe )-import System.Environment.XDG.BaseDir ( getUserConfigFile )-import System.FilePath ( (</>) )-import Graphics.UI.Gtk+import Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.General.StyleContext+import Graphics.X11.Xlib.Misc import Safe ( atMay )+import System.Directory+import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.Exit ( exitFailure )+import System.FilePath ( (</>) )+import System.Information.X11DesktopInfo import qualified System.IO as IO+import System.Mem.StableName import Text.Printf ( printf ) +import Graphics.UI.Gtk.General.CssProvider import Paths_taffybar ( getDataDir ) import System.Taffybar.StrutProperties data Position = Top | Bottom deriving (Show, Eq) - strutProperties :: Position -- ^ Bar position -> Int -- ^ Bar height -> Rectangle -- ^ Current monitor rectangle@@ -162,22 +227,42 @@ Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0, 0, x, x+w) data TaffybarConfig =- TaffybarConfig { screenNumber :: Int -- ^ The screen number to run the bar on (default is almost always fine)- , monitorNumber :: Int -- ^ The xinerama/xrandr monitor number to put the bar on (default: 0)- , barHeight :: Int -- ^ Number of pixels to reserve for the bar (default: 25 pixels)- , barPosition :: Position -- ^ The position of the bar on the screen (default: Top)- , widgetSpacing :: Int -- ^ The number of pixels between widgets- , errorMsg :: Maybe String -- ^ Used by the application- , startWidgets :: [IO Widget] -- ^ Widgets that are packed in order at the left end of the bar- , endWidgets :: [IO Widget] -- ^ Widgets that are packed from right-to-left in the bar+ TaffybarConfig { -- | The screen number to run the bar on (default is almost always fine)+ screenNumber :: Int+ -- | The xinerama/xrandr monitor number to put the bar on (default: 0)+ , monitorNumber :: Int+ -- | Provides a way to specify which screens taffybar should appear on.+ , getMonitorConfig :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)+ -- | A function providing a way to call back in to taffybar to+ -- refresh its configs/open closed state on each monitor.+ , startRefresher :: IO () -> IO ()+ -- | Number of pixels to reserve for the bar (default: 25 pixels)+ , barHeight :: Int+ -- | Number of additional pixels to reserve for the bar strut (default: 0)+ , barPadding :: Int+ -- | The position of the bar on the screen (default: Top)+ , barPosition :: Position+ -- | The number of pixels between widgets+ , widgetSpacing :: Int+ -- | Used by the application+ , errorMsg :: Maybe String+ -- | Widgets that are packed in order at the left end of the bar+ , startWidgets :: [IO Widget]+ -- | Widgets that are packed from right-to-left in the bar+ , endWidgets :: [IO Widget] } +type TaffybarConfigEQ = (TaffybarConfig, StableName TaffybarConfig)+ -- | The default configuration gives an empty bar 25 pixels high on monitor 0. defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { screenNumber = 0 , monitorNumber = 0+ , getMonitorConfig = useMonitorNumber+ , startRefresher = const $ return () , barHeight = 25+ , barPadding = 0 , barPosition = Top , widgetSpacing = 10 , errorMsg = Nothing@@ -185,6 +270,22 @@ , endWidgets = [] } +useMonitorNumber :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)+useMonitorNumber c@(cfg, _) = return umn+ where umn mnumber+ | mnumber == monitorNumber cfg = Just c+ | otherwise = Nothing++-- | Use the primary monitor as set by Xrandr.+usePrimaryMonitor :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)+usePrimaryMonitor c@(cfg, _) = do+ maybePrimary <- withDefaultCtx getPrimaryOutputNumber+ let primary = maybe (monitorNumber cfg) id maybePrimary+ return $ \mnumber -> if mnumber == primary then Just c else Nothing++allMonitors :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)+allMonitors cfg = return $ const $ Just cfg+ showError :: TaffybarConfig -> String -> TaffybarConfig showError cfg msg = cfg { errorMsg = Just msg } @@ -192,19 +293,21 @@ -- -threaded so that the GTK event loops doesn't block all of the -- widgets defaultParams :: Dyre.Params TaffybarConfig-defaultParams = Dyre.defaultParams { Dyre.projectName = "taffybar"- , Dyre.realMain = realMain- , Dyre.showError = showError- , Dyre.ghcOpts = ["-threaded", "-rtsopts"]- , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]- }+defaultParams =+ Dyre.defaultParams+ { Dyre.projectName = "taffybar"+ , Dyre.realMain = realMain+ , Dyre.showError = showError+ , Dyre.ghcOpts = ["-threaded", "-rtsopts"]+ , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"]+ } -- | The entry point of the application. Feed it a custom config. defaultTaffybar :: TaffybarConfig -> IO () defaultTaffybar = Dyre.wrapMain defaultParams realMain :: TaffybarConfig -> IO ()-realMain cfg = do+realMain cfg = case errorMsg cfg of Nothing -> taffybarMain cfg Just err -> do@@ -219,87 +322,156 @@ -- | Given a Taffybar configuration and the Taffybar window, this -- action sets up the window size and strut properties. May be called -- multiple times, e.g., when the monitor resolution changes.-setTaffybarSize :: TaffybarConfig -> Window -> IO ()-setTaffybarSize cfg window = do+setTaffybarSize :: TaffybarConfig -> Window -> Int -> IO ()+setTaffybarSize cfg window monNumber = do screen <- windowGetScreen window nmonitors <- screenGetNMonitors screen- allMonitorSizes <- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)]-- when (monitorNumber cfg >= nmonitors) $ do- IO.hPutStrLn IO.stderr $ printf "Monitor %d is not available in the selected screen" (monitorNumber cfg)-- let monitorSize = fromMaybe (allMonitorSizes !! 0) $ do- allMonitorSizes `atMay` monitorNumber cfg-+ allMonitorSizes <-+ mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)]+ when (monNumber >= nmonitors) $+ IO.hPutStrLn IO.stderr $+ printf+ "Monitor %d is not available in the selected screen"+ monNumber+ let monitorSize =+ fromMaybe (head allMonitorSizes) $+ allMonitorSizes `atMay` monNumber let Rectangle x y w h = monitorSize- yoff = case barPosition cfg of- Top -> 0- Bottom -> h - barHeight cfg+ strutHeight = barHeight cfg + (2 * barPadding cfg)+ yoff =+ case barPosition cfg of+ Top -> barPadding cfg+ Bottom -> h - strutHeight windowMove window x (y + yoff)- -- Set up the window size using fixed min and max sizes. This -- prevents the contained horizontal box from affecting the window -- size.- windowSetGeometryHints window- (Nothing :: Maybe Widget)- (Just (w, barHeight cfg)) -- Min size.- (Just (w, barHeight cfg)) -- Max size.- Nothing- Nothing- Nothing-- let setStrutProps = setStrutProperties window- $ strutProperties (barPosition cfg)- (barHeight cfg)- monitorSize- allMonitorSizes+ windowSetGeometryHints+ window+ (Nothing :: Maybe Widget)+ (Just (w, barHeight cfg)) -- Min size.+ (Just (w, barHeight cfg)) -- Max size.+ Nothing+ Nothing+ Nothing+ let setStrutProps =+ setStrutProperties window $+ strutProperties+ (barPosition cfg)+ strutHeight+ monitorSize+ allMonitorSizes winRealized <- widgetGetRealized window if winRealized then setStrutProps- else onRealize window setStrutProps >> return ()+ else void $ on window realize setStrutProps +startCSS :: IO CssProvider+startCSS = do+ -- Override the default GTK theme path settings. This causes the+ -- bar (by design) to ignore the real GTK theme and just use the+ -- provided minimal theme to set the background and text colors.+ -- Users can override this default.+ taffybarProvider <- cssProviderNew+ let loadIfExists filePath =+ doesFileExist filePath >>= flip when (cssProviderLoadFromPath taffybarProvider filePath)+ loadIfExists =<< getDefaultConfigFile "taffybar.css"+ loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css"+ Just scr <- screenGetDefault+ styleContextAddProviderForScreen scr taffybarProvider 800+ return taffybarProvider+ taffybarMain :: TaffybarConfig -> IO () taffybarMain cfg = do + _ <- initThreads _ <- initGUI-- -- Load default and user gtk resources- defaultGtkConfig <- getDefaultConfigFile "taffybar.rc"- userGtkConfig <- getUserConfigFile "taffybar" "taffybar.rc"- rcParse defaultGtkConfig- rcParse userGtkConfig+ _ <- startCSS Just disp <- displayGetDefault nscreens <- displayGetNScreens disp- screen <- case screenNumber cfg < nscreens of- False -> error $ printf "Screen %d is not available in the default display" (screenNumber cfg)- True -> displayGetScreen disp (screenNumber cfg)+ screen <- if screenNumber cfg < nscreens+ then displayGetScreen disp (screenNumber cfg)+ else error $ printf "Screen %d is not available in the default display"+ (screenNumber cfg) - window <- windowNew- widgetSetName window "Taffybar"- windowSetTypeHint window WindowTypeHintDock- windowSetScreen window screen- setTaffybarSize cfg window+ cfgEq <- makeStableName cfg+ taffyWindowsVar <- MV.newMVar M.empty - -- Reset the size of the Taffybar window if the monitor setup has- -- changed, e.g., after a laptop user has attached an external- -- monitor.- _ <- on screen screenMonitorsChanged (setTaffybarSize cfg window)+ let refreshTaffyWindows = do+ nmonitors <- screenGetNMonitors screen+ getConfig <- getMonitorConfig cfg (cfg, cfgEq)+ MV.modifyMVar_ taffyWindowsVar $ \monitorToWindow ->+ do+ let monitors = union [0 .. (nmonitors - 1)] $ M.keys monitorToWindow+ updateBarOnWindow mapToUpdate monNum+ | monNum >= nmonitors = maybeDeleteWindow+ | otherwise = case M.lookup monNum monitorToWindow of+ Just (currentConfig, window) ->+ case getConfig monNum of+ Just configEq@(_, newConfigEq) ->+ if currentConfig == newConfigEq+ then+ return mapToUpdate+ else+ widgetDestroy window >>+ makeAndAddWindow configEq+ Nothing -> maybeDeleteWindow+ Nothing ->+ case getConfig monNum of+ Just configEq -> makeAndAddWindow configEq+ Nothing -> return mapToUpdate+ where makeAndAddWindow (newConfig, eqcfg) =+ do+ window <- makeTaffyWindow newConfig monNum+ return $ M.insert monNum (eqcfg, window) mapToUpdate+ deleteWindow (_, window) =+ widgetDestroy window >> return (M.delete monNum mapToUpdate)+ maybeDeleteWindow = maybe (return mapToUpdate) deleteWindow $+ M.lookup monNum mapToUpdate+ foldM updateBarOnWindow monitorToWindow monitors - box <- hBoxNew False $ widgetSpacing cfg- containerAdd window box+ makeTaffyWindow wcfg monNumber = do+ window <- windowNew+ let windowName = printf "Taffybar-%s" $ show monNumber :: String - mapM_ (\io -> do- wid <- io- widgetSetSizeRequest wid (-1) (barHeight cfg)- boxPackStart box wid PackNatural 0) (startWidgets cfg)- mapM_ (\io -> do- wid <- io- widgetSetSizeRequest wid (-1) (barHeight cfg)- boxPackEnd box wid PackNatural 0) (endWidgets cfg)+ styleContext <- Gtk.widgetGetStyleContext window+ styleContextAddClass styleContext "Taffybar"+ widgetSetName window windowName - widgetShow window- widgetShow box+ windowSetTypeHint window WindowTypeHintDock+ windowSetScreen window screen+ setTaffybarSize wcfg window monNumber++ box <- hBoxNew False $ widgetSpacing wcfg+ containerAdd window box++ mapM_+ (\io -> do+ wid <- io+ widgetSetSizeRequest wid (-1) (barHeight wcfg)+ boxPackStart box wid PackNatural 0)+ (startWidgets wcfg)++ mapM_+ (\io -> do+ wid <- io+ widgetSetSizeRequest wid (-1) (barHeight wcfg)+ boxPackEnd box wid PackNatural 0)+ (endWidgets wcfg)++ widgetShow window+ widgetShow box+ return window++ _ <- on screen screenMonitorsChanged refreshTaffyWindows++ startRefresher cfg $ postGUIAsync refreshTaffyWindows++ refreshTaffyWindows+ -- Reset the size of the Taffybar window if the monitor setup has+ -- changed, e.g., after a laptop user has attached an external+ -- monitor. mainGUI return ()
src/System/Taffybar/Battery.hs view
@@ -1,97 +1,153 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | 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 batterym it just returns an obnoxious widget with+-- 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.Battery ( batteryBarNew,+ batteryBarNewWithFormat, textBatteryNew, defaultBatteryConfig ) where -import qualified Control.Exception.Enclosed as E-import Data.Int ( Int64 )-import Data.IORef-import Graphics.UI.Gtk-import qualified System.IO as IO-import Text.Printf ( printf )-import Text.StringTemplate+import Control.Applicative+import qualified Control.Exception.Enclosed as E+import Data.Int (Int64)+import Data.IORef+import Graphics.UI.Gtk+import Safe (atMay)+import qualified System.IO as IO+import Text.Printf (printf)+import Text.StringTemplate -import System.Information.Battery-import System.Taffybar.Widgets.PollingBar-import System.Taffybar.Widgets.PollingLabel+import Prelude -safeGetBatteryInfo :: IORef BatteryContext -> IO (Maybe BatteryInfo)-safeGetBatteryInfo mv = do+import System.Information.Battery+import System.Taffybar.Widgets.PollingBar+import System.Taffybar.Widgets.PollingLabel+++-- | Just the battery info that will be used for display (this makes combining several easier).+data BatteryWidgetInfo = BWI { seconds :: Maybe Int64+ , percent :: Int+ , 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 = ""+formatDuration (Just secs) = let minutes = secs `div` 60+ hours = minutes `div` 60+ 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) $ \_ -> reconnect where reconnect = do- mctxt <- batteryContextNew+ 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+ Just ctxt ->+ writeIORef mv ctxt return Nothing -battInfo :: IORef BatteryContext -> String -> IO String-battInfo r fmt = do- minfo <- safeGetBatteryInfo r+getBatteryWidgetInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryWidgetInfo)+getBatteryWidgetInfo r i = do+ minfo <- safeGetBatteryInfo r i case minfo of- Nothing -> return ""+ Nothing -> return Nothing Just info -> do let battPctNum :: Int battPctNum = floor (batteryPercentage info)- formatTime :: Int64 -> String- formatTime seconds =- let minutes = seconds `div` 60- hours = minutes `div` 60- minutes' = minutes `mod` 60- in printf "%02d:%02d" hours minutes'+ 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+ } - battTime :: String- battTime = case (batteryState info) of- BatteryStateCharging -> (formatTime $ batteryTimeToFull info)- BatteryStateDischarging -> (formatTime $ batteryTimeToEmpty info)- _ -> "-" - tpl = newSTMP fmt- tpl' = setManyAttrib [ ("percentage", show battPctNum)- , ("time", battTime)- ] tpl- return $ render tpl'+-- | Given (maybe summarized) battery info and format: provides the string to display+formatBattInfo :: Maybe BatteryWidgetInfo -> String -> String+formatBattInfo Nothing _ = ""+formatBattInfo (Just info) fmt =+ let tpl = newSTMP fmt+ tpl' = setManyAttrib [ ("percentage", (show . percent) info)+ , ("time", formatDuration (seconds info))+ , ("status", status info)+ ] tpl+ in render tpl' +-- | Provides textual information regarding multiple batteries+battSumm :: [IORef BatteryContext] -> String -> IO String+battSumm rs fmt = do+ winfos <- sequence $ fmap (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.-textBatteryNew :: String -- ^ Display format- -> Double -- ^ Poll period in seconds- -> IO Widget-textBatteryNew fmt pollSeconds = do- battCtxt <- batteryContextNew- case battCtxt of- Nothing -> do- let lbl :: Maybe String- lbl = Just "No battery"- labelNew lbl >>= return . toWidget- Just ctxt -> do- r <- newIORef ctxt- l <- pollingLabelNew "" pollSeconds (battInfo r fmt)- widgetShowAll l- return l+--+-- 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 labelNew lbl >>= return . toWidget+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 -> IO Double-battPct r = do- minfo <- safeGetBatteryInfo r+battPct :: IORef BatteryContext -> Int -> IO Double+battPct i r = do+ minfo <- safeGetBatteryInfo i r case minfo of- Nothing -> return 0+ Nothing -> return 0 Just info -> return (batteryPercentage info / 100) -- | A default configuration for the graphical battery display. The@@ -108,30 +164,34 @@ | pct < 0.9 = (0.5, 0.5, 0.5) | otherwise = (0, 1, 0) --- | A fancy graphical battery widget that represents the current--- charge as a colored vertical bar. There is also a textual--- percentage readout next to the bar.-batteryBarNew :: BarConfig -- ^ Configuration options for the bar display- -> Double -- ^ Polling period in seconds- -> IO Widget-batteryBarNew battCfg pollSeconds = do- battCtxt <- batteryContextNew++-- | 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 :: BarConfig -> Double -> IO Widget+batteryBarNew battCfg pollSeconds =+ batteryBarNewWithFormat battCfg "$percentage$%" pollSeconds++-- | 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 :: BarConfig -> String -> Double -> IO Widget+batteryBarNewWithFormat battCfg formatString pollSeconds = do+ battCtxt <- batteryContextsNew case battCtxt of- Nothing -> do+ [] -> do let lbl :: Maybe String lbl = Just "No battery"- labelNew lbl >>= return . toWidget- Just ctxt -> do- -- This is currently pretty inefficient - each poll period it- -- queries the battery twice (once for the label and once for- -- the bar).- --- -- Converting it to combine the two shouldn't be hard.+ toWidget <$> labelNew lbl+ cs -> do b <- hBoxNew False 1- txt <- textBatteryNew "$percentage$%" pollSeconds- r <- newIORef ctxt- bar <- pollingBarNew battCfg pollSeconds (battPct r)- boxPackStart b bar PackNatural 0+ rs <- sequence $ fmap newIORef cs+ txt <- textBatteryNew rs formatString pollSeconds+ let ris :: [(IORef BatteryContext, Int)]+ ris = rs `zip` [0..]+ bars <- sequence $ fmap (\(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)
src/System/Taffybar/FreedesktopNotifications.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for freedesktop notifications -- (http://developer.gnome.org/notification-spec/). Currently it is@@ -7,6 +9,18 @@ -- -- The widget only displays one notification at a time and -- notifications are cancellable.++-- The notificationDaemon thread handles new notifications+-- and cancellation requests, adding or removing the notification+-- to or from the queue. It additionally starts a timeout thread+-- for each notification added to queue.+--+-- The display thread blocks idling until it is awakened to refresh the GUI+--+-- A timeout thread is associated with a notification id.+-- It sleeps until the specific timeout and then removes every notification+-- with that id from the queue+ module System.Taffybar.FreedesktopNotifications ( -- * Types Notification(..),@@ -18,11 +32,12 @@ import Control.Concurrent import Control.Concurrent.STM-import Control.Monad ( forever )+import Control.Monad ( forever, void ) import Control.Monad.Trans ( liftIO ) import Data.Int ( Int32 )+import Data.Foldable import Data.Map ( Map )-import Data.Monoid ( mconcat )+import Data.Monoid import qualified Data.Sequence as S import Data.Sequence ( Seq, (|>), viewl, ViewL(..) ) import Data.Text ( Text )@@ -37,7 +52,7 @@ , noteReplaceId :: Word32 , noteSummary :: Text , noteBody :: Text- , noteExpireTimeout :: Int32+ , noteExpireTimeout :: Maybe Int32 , noteId :: Word32 } deriving (Show, Eq)@@ -45,224 +60,172 @@ data NotifyState = NotifyState { noteWidget :: Label , noteContainer :: Widget , noteConfig :: NotificationConfig+ -- ^ The associated configuration , noteQueue :: TVar (Seq Notification)- -- ^ The queue of active (but not yet- -- displayed) notifications+ -- ^ The queue of active notifications , noteIdSource :: TVar Word32- -- ^ A source of new notification ids- , noteCurrent :: TVar (Maybe Notification)- -- ^ The current note being displayed+ -- ^ A source of fresh notification ids , noteChan :: Chan ()- -- ^ Wakes up the GUI update thread+ -- ^ Writing to this channel wakes up the display thread } initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do m <- newTVarIO 1 q <- newTVarIO S.empty- c <- newTVarIO Nothing ch <- newChan return NotifyState { noteQueue = q , noteIdSource = m , noteWidget = l , noteContainer = wrapper- , noteCurrent = c , noteConfig = cfg , noteChan = ch } -getServerInformation :: IO (Text, Text, Text, Text)-getServerInformation =- return ("haskell-notification-daemon",- "nochair.net",- "0.0.1",- "1.1")--getCapabilities :: IO [Text]-getCapabilities = return ["body", "body-markup"]--nextNotification :: NotifyState -> STM ()-nextNotification s = do- q <- readTVar (noteQueue s)- case viewl q of- EmptyL -> do- writeTVar (noteCurrent s) Nothing- next :< rest -> do- writeTVar (noteQueue s) rest- writeTVar (noteCurrent s) (Just next)+-- | Removes every notification with id 'nId' from the queue+notePurge :: NotifyState -> Word32 -> IO ()+notePurge s nId = atomically . modifyTVar' (noteQueue s) $+ S.filter ((nId /=) . noteId) --- | Filter any notifications with this id from the current queue. If--- it is the current notification, replace it with the next, if any.-closeNotification :: NotifyState -> Word32 -> IO ()-closeNotification istate nid = do- atomically $ do- modifyTVar' (noteQueue istate) removeNote- curNote <- readTVar (noteCurrent istate)- case curNote of- Nothing -> return ()- Just cnote- | noteId cnote /= nid -> return ()- | otherwise ->- -- in this case, the note was current so we take the next,- -- if any- nextNotification istate- wakeupDisplayThread istate+-- | Removes the first (oldest) notification from the queue+noteNext :: NotifyState -> IO ()+noteNext s = atomically $ modifyTVar' (noteQueue s) aux where- removeNote = S.filter (\n -> noteId n /= nid)+ aux queue = case viewl queue of+ EmptyL -> S.empty+ _ :< ns -> ns --- | Apply the user's formatter and truncate the result with the--- specified maxlen.-formatMessage :: NotifyState -> Notification -> String-formatMessage s = fmt- where- fmt = notificationFormatter $ noteConfig s+-- | Generates a fresh notification id+noteFreshId :: NotifyState -> IO Word32+noteFreshId (NotifyState { noteIdSource }) = atomically $ do+ nId <- readTVar noteIdSource+ writeTVar noteIdSource (succ nId)+ return nId --- | The notificationDaemon thread looks at the notification queue.--- If the queue is empty and there is no current message, it sets the--- new message as the current message in a TVar (Just Notification)--- and displays the message itself and sets up a thread to remove the--- message after its timeout.------ If there is a current message, add the new message to the queue.------ The timeout thread just sleeps for its timeout and then atomically--- replaces the current message with the next one from the queue. It--- then displays the new current message. However, if the current--- message has changed (because of a user cancellation), the timer--- thread just exits.------ User cancellation atomically reads (and replaces) the current--- notification (if there is another in the queue). If it found a new--- notification, that node is then displayed.+--------------------------------------------------------------------------------+-- | Handles a new notification notify :: NotifyState- -> Text -- ^ Application name- -> Word32 -- ^ Replaces id- -> Text -- ^ App icon- -> Text -- ^ Summary- -> Text -- ^ Body- -> [Text] -- ^ Actions- -> Map Text Variant -- ^ Hints- -> Int32 -- ^ Expires timeout (milliseconds)- -> IO Word32-notify istate appName replaceId _ summary body _ _ timeout = do- nid <- atomically $ do- tid <- readTVar idsrc- modifyTVar' idsrc (+1)- return tid- let realId = if replaceId == 0 then fromIntegral nid else replaceId+ -> Text -- ^ Application name+ -> Word32 -- ^ Replaces id+ -> Text -- ^ App icon+ -> Text -- ^ Summary+ -> Text -- ^ Body+ -> [Text] -- ^ Actions+ -> Map Text Variant -- ^ Hints+ -> Int32 -- ^ Expires timeout (milliseconds)+ -> IO Word32+notify s appName replaceId _ summary body _ _ timeout = do+ realId <- if replaceId == 0 then noteFreshId s else return replaceId+ let escapeText = T.pack . escapeMarkup . T.unpack+ configTimeout = notificationMaxTimeout (noteConfig s)+ realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values+ then configTimeout+ else case configTimeout of+ Nothing -> Just timeout+ Just maxTimeout -> Just (min maxTimeout timeout) n = Notification { noteAppName = appName , noteReplaceId = replaceId , noteSummary = escapeText summary , noteBody = escapeText body- , noteExpireTimeout = tout+ , noteExpireTimeout = realTimeout , noteId = realId }- -- If we are replacing an existing note, atomically do the swap in- -- the note queue and then make this the new current if the queue is- -- empty OR if the current has this id.- dn <- atomically $ do- modifyTVar' (noteQueue istate) (replaceNote n)- cnote <- readTVar (noteCurrent istate)- case cnote of- Nothing -> do- writeTVar (noteCurrent istate) (Just n)- return (Just n)- Just curNote- | noteId curNote == realId -> do- writeTVar (noteCurrent istate) (Just n)- return (Just n)- | otherwise -> do- modifyTVar' (noteQueue istate) (|>n)- return Nothing- -- This is a little gross - if we added the new notification to the- -- queue, we can't call displayNote on it because that will- -- obliterate the current active notification.- case dn of- -- take no action; timeout threads will handle it- Nothing -> return ()- Just _ -> wakeupDisplayThread istate+ -- Either add the new note to the queue or replace an existing note if their ids match+ atomically $ do+ queue <- readTVar $ noteQueue s+ writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of+ Nothing -> queue |> n+ Just index -> S.update index n queue+ startTimeoutThread s n+ wakeupDisplayThread s return realId- where- replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n)- idsrc = noteIdSource istate- escapeText = T.pack . escapeMarkup . T.unpack- maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)- tout = case timeout of- 0 -> maxtout- (-1) -> maxtout- _ -> min maxtout timeout +-- | Handles user cancellation of a notification+closeNotification :: NotifyState -> Word32 -> IO ()+closeNotification s nId = do+ notePurge s nId+ wakeupDisplayThread s+ notificationDaemon :: (AutoMethod f1, AutoMethod f2) => f1 -> f2 -> IO () notificationDaemon onNote onCloseNote = do client <- connectSession _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]- export client "/org/freedesktop/Notifications"- [ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation- , autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities- , autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote- , autoMethod "org.freedesktop.Notifications" "Notify" onNote- ]+ export client "/org/freedesktop/Notifications" interface+ where+ getServerInformation :: IO (Text, Text, Text, Text)+ getServerInformation = return ("haskell-notification-daemon",+ "nochair.net",+ "0.0.1",+ "1.1")+ getCapabilities :: IO [Text]+ getCapabilities = return ["body", "body-markup"]+ interface = defaultInterface+ { interfaceName = "org.freedesktop.Notifications"+ , interfaceMethods =+ [ autoMethod "GetServerInformation" getServerInformation+ , autoMethod "GetCapabilities" getCapabilities+ , autoMethod "CloseNotification" onCloseNote+ , autoMethod "Notify" onNote+ ]+ } --- | Wakeup the display thread and have it switch out the displayed--- message for the new current message.+-------------------------------------------------------------------------------- wakeupDisplayThread :: NotifyState -> IO () wakeupDisplayThread s = writeChan (noteChan s) () --- | This thread+-- | Refreshes the GUI displayThread :: NotifyState -> IO () displayThread s = forever $ do- _ <- readChan (noteChan s)- cur <- atomically $ readTVar (noteCurrent s)- case cur of- Nothing -> postGUIAsync (widgetHideAll (noteContainer s))- Just n -> postGUIAsync $ do- labelSetMarkup (noteWidget s) (formatMessage s n)+ () <- readChan (noteChan s)+ ns <- readTVarIO (noteQueue s)+ postGUIAsync $+ if S.length ns == 0+ then widgetHide (noteContainer s)+ else do+ labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns) widgetShowAll (noteContainer s)- startTimeoutThread s n+ where+ formatMessage (NotificationConfig {..}) ns =+ take notificationMaxLength $ notificationFormatter ns +-------------------------------------------------------------------------------- startTimeoutThread :: NotifyState -> Notification -> IO ()-startTimeoutThread s n = do- _ <- forkIO $ do- let seconds = noteExpireTimeout n- threadDelay (fromIntegral seconds * 1000000)- atomically $ do- curNote <- readTVar (noteCurrent s)- case curNote of- Nothing -> return ()- Just cnote- | cnote /= n -> return ()- | otherwise ->- -- The note was not invalidated or changed since the timeout- -- began, so we replace it with the next (if any)- nextNotification s+startTimeoutThread s (Notification {..}) = case noteExpireTimeout of+ Nothing -> return ()+ Just timeout -> void $ forkIO $ do+ threadDelay (fromIntegral timeout * 10^(6 :: Int))+ notePurge s noteId wakeupDisplayThread s- return () +-------------------------------------------------------------------------------- data NotificationConfig =- NotificationConfig { notificationMaxTimeout :: Int -- ^ Maximum time that a notification will be displayed (in seconds). Default: 10- , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 50- , notificationFormatter :: Notification -> String -- ^ Function used to format notifications+ NotificationConfig { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None+ , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100+ , notificationFormatter :: [Notification] -> String -- ^ Function used to format notifications, takes the notifications from first to last } -defaultFormatter :: Notification -> String-defaultFormatter note = msg- where- msg = case T.null (noteBody note) of- True -> T.unpack $ noteSummary note- False -> T.unpack $ mconcat [ "<span fgcolor='yellow'>Note:</span>"- , noteSummary note, ": ", noteBody note ]+defaultFormatter :: [Notification] -> String+defaultFormatter ns =+ let count = length ns+ n = head ns+ prefix = if count == 1+ then ""+ else "(" <> show count <> ") "+ msg = T.unpack $ if T.null (noteBody n)+ then noteSummary n+ else noteSummary n <> ": " <> noteBody n+ in "<span fgcolor='yellow'>" <> prefix <> "</span>" <> msg -- | The default formatter is one of--- -- * Summary : Body--- -- * Summary------ depending on the presence of a notification body.+-- * (N) Summary : Body+-- * (N) Summary+-- depending on the presence of a notification body, and where N is the number of queued notifications. defaultNotificationConfig :: NotificationConfig defaultNotificationConfig =- NotificationConfig { notificationMaxTimeout = 10+ NotificationConfig { notificationMaxTimeout = Nothing , notificationMaxLength = 100 , notificationFormatter = defaultFormatter }@@ -290,10 +253,10 @@ containerAdd frame box - widgetHideAll frame+ widgetHide frame - istate <- initialNoteState (toWidget frame) textArea cfg- _ <- on button buttonReleaseEvent (userCancel istate)+ s <- initialNoteState (toWidget frame) textArea cfg+ _ <- on button buttonReleaseEvent (userCancel s) realizableWrapper <- hBoxNew False 0 boxPackStart realizableWrapper frame PackNatural 0@@ -303,16 +266,15 @@ -- main loop, otherwise things are prone to lock up and block -- infinitely on an mvar. Bad stuff - only start the dbus thread -- after the fake invisible wrapper widget is realized.- _ <- on realizableWrapper realize $ do- _ <- forkIO (displayThread istate)- notificationDaemon (notify istate) (closeNotification istate)+ void $ on realizableWrapper realize $ do+ void $ forkIO (displayThread s)+ notificationDaemon (notify s) (closeNotification s) -- Don't show the widget by default - it will appear when needed return (toWidget realizableWrapper) where -- | Close the current note and pull up the next, if any- userCancel s = do- liftIO $ do- atomically $ nextNotification s- wakeupDisplayThread s+ userCancel s = liftIO $ do+ noteNext s+ wakeupDisplayThread s return True
src/System/Taffybar/Hooks/PagerHints.hs view
@@ -54,11 +54,11 @@ -- | The \"Current Layout\" custom hint. xLayoutProp :: X Atom-xLayoutProp = return =<< getAtom "_XMONAD_CURRENT_LAYOUT"+xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT" -- | The \"Visible Workspaces\" custom hint. xVisibleProp :: X Atom-xVisibleProp = return =<< getAtom "_XMONAD_VISIBLE_WORKSPACES"+xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES" -- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom -- hints to the given config.@@ -96,10 +96,10 @@ -- | Handle all \"Current Layout\" events received from pager widgets, and -- set the current layout accordingly. pagerHintsEventHook :: Event -> X All-pagerHintsEventHook (ClientMessageEvent {+pagerHintsEventHook ClientMessageEvent { ev_message_type = mt, ev_data = d- }) = withWindowSet $ \_ -> do+ } = withWindowSet $ \_ -> do a <- xLayoutProp when (mt == a) $ sendLayoutMessage d return (All True)
+ src/System/Taffybar/IconImages.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- 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,+ selectEWMHIcon+) where++import Data.Bits+import qualified Data.List as L+import Data.Ord ( comparing )+import Data.Word+import Foreign.C.Types (CUChar(..))+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import qualified Graphics.UI.Gtk as Gtk+import System.Information.EWMHDesktopInfo++type ColorRGBA = (Word8, Word8, Word8, Word8)++-- | Take the passed in pixbuf and ensure its scaled square.+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)+ let pixelsPerRow = w+ bytesPerPixel = 4+ rowStride = pixelsPerRow * bytesPerPixel+ cPtr = castPtr wPtr+ Gtk.pixbufNewFromData cPtr colorspace hasAlpha sampleBits w h rowStride++-- | 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.+pixelsARGBToBytesABGR+ :: (Storable a, Bits a, Num a, Integral a)+ => Ptr a -> Int -> IO (Ptr CUChar)+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++selectEWMHIcon :: Int -> [EWMHIcon] -> EWMHIcon+selectEWMHIcon imgSize icons = head prefIcon+ where sortedIcons = L.sortBy (comparing height) icons+ smallestLargerIcon = take 1 $ dropWhile ((<= imgSize) . height) sortedIcons+ largestIcon = take 1 $ reverse sortedIcons+ prefIcon = smallestLargerIcon ++ largestIcon
src/System/Taffybar/LayoutSwitcher.hs view
@@ -26,7 +26,8 @@ layoutSwitcherNew ) where -import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans+import Control.Monad.Reader import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras (Event) import System.Taffybar.Pager@@ -66,43 +67,44 @@ -- This callback is run in a separate thread and needs to use -- postGUIAsync let cfg = config pager- callback = pagerCallback cfg label+ callback = Gtk.postGUIAsync . (flip runReaderT pager) . (pagerCallback cfg label) subscribe pager callback xLayoutProp- assembleWidget label+ assembleWidget pager label -- | Build a suitable callback function that can be registered as Listener -- of "_XMONAD_CURRENT_LAYOUT" custom events. These events are emitted by -- the PagerHints hook to notify of changes in the current layout.-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()-pagerCallback cfg label _ = Gtk.postGUIAsync $ do- layout <- withDefaultCtx $ readAsString Nothing xLayoutProp- let decorate = activeLayout cfg- Gtk.labelSetMarkup label (decorate layout)+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> PagerIO ()+pagerCallback cfg label _ = do+ layout <- liftPagerX11 $ readAsString Nothing xLayoutProp+ markup <- lift $ activeLayoutIO cfg $ activeLayout cfg layout+ lift $ Gtk.labelSetMarkup label markup -- | Build the graphical representation of the widget.-assembleWidget :: Gtk.Label -> IO Gtk.Widget-assembleWidget label = do+assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget+assembleWidget pager label = do ebox <- Gtk.eventBoxNew Gtk.containerAdd ebox label- _ <- Gtk.on ebox Gtk.buttonPressEvent dispatchButtonEvent+ _ <- Gtk.on ebox Gtk.buttonPressEvent (dispatchButtonEvent pager) Gtk.widgetShowAll ebox return $ Gtk.toWidget ebox -- | Call 'switch' with the appropriate argument (1 for left click, -1 for -- right click), depending on the click event received.-dispatchButtonEvent :: Gtk.EventM Gtk.EButton Bool-dispatchButtonEvent = do+dispatchButtonEvent :: Pager -> Gtk.EventM Gtk.EButton Bool+dispatchButtonEvent pager = do btn <- Gtk.eventButton let trigger = onClick [Gtk.SingleClick]+ run = runWithPager pager case btn of- Gtk.LeftButton -> trigger $ switch 1- Gtk.RightButton -> trigger $ switch (-1)+ Gtk.LeftButton -> trigger $ run $ switch 1+ Gtk.RightButton -> trigger $ run $ switch (-1) _ -> return False -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be -- intercepted by the PagerHints hook, which in turn can instruct XMonad to -- switch to a different layout.-switch :: (MonadIO m) => Int -> m ()-switch n = liftIO $ withDefaultCtx $ do+switch :: Int -> X11Property ()+switch n = do cmd <- getAtom xLayoutProp sendCommandEvent cmd (fromIntegral n)
src/System/Taffybar/MPRIS.hs view
@@ -12,6 +12,7 @@ , mprisNew ) where +import Control.Monad ( void ) import Data.Int ( Int32 ) import qualified Data.Map as M import Data.Text ( Text )@@ -21,6 +22,8 @@ import Graphics.UI.Gtk hiding ( Signal, Variant ) import Text.Printf ++ data TrackInfo = TrackInfo { trackArtist :: Maybe String -- ^ Artist name, if available. , trackTitle :: Maybe String -- ^ Track name, if available.@@ -46,8 +49,8 @@ , matchMember = Just "StatusChange" } client <- connectSession- listen client trackMatcher (trackCallback cfg w)- listen client stateMatcher (stateCallback w)+ void $ addMatch client trackMatcher (trackCallback cfg w)+ void $ addMatch client stateMatcher (stateCallback w) variantDictLookup :: (IsVariant b, Ord k) => k -> M.Map k Variant -> Maybe b variantDictLookup k m = do@@ -80,8 +83,8 @@ case fromVariant (signalBody s !! 0) of Just st -> case structureItems st of (pstate:_) -> case (fromVariant pstate) :: Maybe Int32 of- Just 2 -> postGUIAsync $ widgetHideAll w- Just 1 -> postGUIAsync $ widgetHideAll w+ Just 2 -> postGUIAsync $ widgetHide w+ Just 1 -> postGUIAsync $ widgetHide w Just 0 -> postGUIAsync $ widgetShowAll w _ -> return () _ -> return ()
src/System/Taffybar/MPRIS2.hs view
@@ -7,9 +7,10 @@ -- module System.Taffybar.MPRIS2 ( mpris2New ) where +import Control.Monad ( void ) import Data.Maybe ( listToMaybe ) import DBus-import DBus.Client+import DBus.Client hiding (getProperty) import Data.List (isPrefixOf) import Graphics.UI.Gtk hiding ( Signal, Variant ) import Text.Printf@@ -17,7 +18,7 @@ mpris2New :: IO Widget mpris2New = do label <- labelNew (Nothing :: Maybe String)- widgetShowAll label+ widgetHide label _ <- on label realize $ initLabel label return (toWidget label) @@ -31,7 +32,7 @@ client <- connectSession -- Set initial song state/info reqSongInfo w client- listen client propMatcher (callBack w)+ void $ addMatch client propMatcher (callBack w) return () where callBack label s = do let items = dictionaryItems $ unpack (signalBody s !! 1)@@ -59,9 +60,9 @@ reply' <- getProperty client (players !! 0) "PlaybackStatus" let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String case status of- "Playing" -> postGUIAsync $ widgetShowAll w- "Paused" -> postGUIAsync $ widgetHideAll w- "Stopped" -> postGUIAsync $ widgetHideAll w+ "Playing" -> postGUIAsync $ widgetShow w+ "Paused" -> postGUIAsync $ widgetHide w+ "Stopped" -> postGUIAsync $ widgetHide w _ -> return () getProperty :: Client -> String -> String -> IO MethodReturn@@ -91,9 +92,9 @@ case lookup (toVariant ("PlaybackStatus" :: String)) items of Just a -> do case (unpack . unpack) a :: String of- "Playing" -> postGUIAsync $ widgetShowAll w- "Paused" -> postGUIAsync $ widgetHideAll w- "Stopped" -> postGUIAsync $ widgetHideAll w+ "Playing" -> postGUIAsync $ widgetShow w+ "Paused" -> postGUIAsync $ widgetHide w+ "Stopped" -> postGUIAsync $ widgetHide w _ -> return () Nothing -> do return ()
+ src/System/Taffybar/Menu/DesktopEntry.hs view
@@ -0,0 +1,179 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Menu.DesktopEntry+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- 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.+--+-- See also 'MenuWidget'.+-----------------------------------------------------------------------------++module System.Taffybar.Menu.DesktopEntry (+ DesktopEntry(..),+ listDesktopEntries,+ getDirectoryEntry,+ deHasCategory,+ deName,+ deOnlyShowIn,+ deNotShowIn,+ deComment,+ deCommand,+ deIcon,+ deNoDisplay)++where++import Control.Monad.Except+import Data.Char+import qualified Data.ConfigFile as CF+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath.Posix++data DesktopEntryType = Application | Link | Directory+ deriving (Read, Show, Eq)++-- | Desktop Entry. All attributes (key-value-pairs) are stored in an+-- association list.+data DesktopEntry = DesktopEntry {+ deType :: DesktopEntryType,+ deFilename :: FilePath, -- ^ unqualified filename, e.g. "taffybar.desktop"+ deAttributes :: [(String, String)], -- ^ Key-value pairs+ deAllocated :: Bool -- ^ already contained in some menu?+ }+ deriving (Read, Show, Eq)++-- | Determine whether the Category attribute of a desktop entry+-- contains a given value.+deHasCategory :: DesktopEntry -- ^ desktop entry+ -> String -- ^ category to be checked+ -> Bool+deHasCategory de cat = case lookup "Categories" (deAttributes de) of+ Nothing -> False+ Just cats -> cat `elem` splitAtSemicolon cats++splitAtSemicolon :: String -> [String]+splitAtSemicolon = lines . (map (\c -> if c == ';' then '\n' else c))++-- | Return the proper name of the desktop entry, depending on the+-- list of preferred languages.+deName :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> String+deName langs de = fromMaybe (deFilename de) $ deLocalisedAtt langs de "Name" ++-- | Return the categories in which the entry shall be shown+deOnlyShowIn :: DesktopEntry -> [String]+deOnlyShowIn = maybe [] (splitAtSemicolon) . deAtt "OnlyShowIn" ++-- | Return the categories in which the entry shall not be shown+deNotShowIn :: DesktopEntry -> [String]+deNotShowIn = maybe [] (splitAtSemicolon) . deAtt "NotShowIn" ++-- | Return the value of the given attribute key+deAtt :: String -> DesktopEntry -> Maybe String+deAtt att = lookup att . deAttributes++-- | Return the Icon attribute+deIcon :: DesktopEntry -> Maybe String+deIcon = deAtt "Icon"++-- | Return True if the entry must not be displayed+deNoDisplay :: DesktopEntry -> Bool+deNoDisplay de = maybe False (("true" ==) . (map toLower)) $ deAtt "NoDisplay" de++deLocalisedAtt :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> String+ -> Maybe String+deLocalisedAtt langs de att = + let localeMatches = catMaybes $ map (\l -> lookup (att ++ "[" ++ l ++ "]") (deAttributes de)) langs+ in if null localeMatches+ then lookup att $ deAttributes de+ else Just $ head localeMatches++-- | Return the proper comment of the desktop entry, depending on the+-- list of preferred languages.+deComment :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> Maybe String+deComment langs de = deLocalisedAtt langs de "Comment"++-- | Return the command defined by the given desktop entry. FIXME:+-- should check the dbus thing. FIXME: are there "field codes",+-- i.e. %<char> things, that should be respected?+deCommand :: DesktopEntry -> Maybe String+deCommand de = + case lookup "Exec" (deAttributes de) of+ Nothing -> Nothing+ Just cmd -> Just $ reverse $ dropWhile (== ' ') $ reverse $ takeWhile (/= '%') cmd++-- | Return a list of all desktop entries in the given directory.+listDesktopEntries :: String -> FilePath -> IO [DesktopEntry]+listDesktopEntries extension dir = do+ let ndir = normalise dir+ putStrLn $ "Listing desktop entries in " ++ ndir+ ex <- doesDirectoryExist ndir+ if ex+ then do files <- mapM (return . (ndir </>))+ =<< return . filter (/= ".")+ =<< return . filter (/= "..")+ =<< getDirectoryContents dir+ mEntries <- mapM (readDesktopEntry) $ filter (extension `isSuffixOf`) files+ let entries = nub $ catMaybes mEntries+ subDirs <- filterM doesDirectoryExist files+ subEntries <- return . concat =<< mapM (listDesktopEntries extension) subDirs + return $ entries ++ subEntries+ else do putStrLn $ "Does not exist: " ++ ndir+ return []++-- | Return a list of all desktop entries in the given directory.+getDirectoryEntry :: String -> [FilePath] -> IO (Maybe DesktopEntry)+getDirectoryEntry name dirs = do+ exFiles <- filterM doesFileExist $ map ((</> name) . normalise) dirs+ if null exFiles+ then return Nothing+ else readDesktopEntry $ head exFiles++-- | Main section of a desktop entry file.+sectionMain :: String+sectionMain = "Desktop Entry"++-- | Read a desktop entry from a file.+readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)+readDesktopEntry fp = do+ ex <- doesFileExist fp+ if ex+ then doReadDesktopEntry fp+ else do putStrLn $ "File does not exist: '" ++ fp ++ "'"+ return Nothing++ where doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)+ doReadDesktopEntry f = do+ eResult <- runExceptT $ do+ cp <- join $ liftIO $ CF.readfile CF.emptyCP f+ items <- CF.items cp sectionMain+ return items++ case eResult of+ Left _ -> return Nothing+ Right r -> return $ Just $ DesktopEntry+ {deType = maybe Application read (lookup "Type" r),+ deFilename = f,+ deAttributes = r,+ deAllocated = False}++-- -- | Test+-- testDesktopEntry :: IO ()+-- testDesktopEntry = do+-- print =<< readDesktopEntry "/usr/share/applications/taffybar.desktop"+
+ src/System/Taffybar/Menu/Menu.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Menu.Menu+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- Implementation of version 1.1 of the freedesktop "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+--+-- See also 'MenuWidget'.+-----------------------------------------------------------------------------++module System.Taffybar.Menu.Menu (+ Menu(..),+ MenuEntry(..),+ buildMenu,+ getApplicationEntries)+where++import Data.Char (toLower)+import Data.List+import Data.Maybe+import System.Taffybar.Menu.DesktopEntry+import System.Taffybar.Menu.XdgMenu++-- | Displayable menu+data Menu = Menu {+ fmName :: String,+ fmComment :: String,+ fmIcon :: Maybe String,+ fmSubmenus :: [Menu],+ fmEntries :: [MenuEntry],+ fmOnlyUnallocated :: Bool}+ deriving (Show)++-- | Displayable menu entry+data MenuEntry = MenuEntry {+ feName :: String,+ feComment :: String,+ feCommand :: String,+ feIcon :: Maybe String}+ deriving (Eq, Show)+++-- | Fetch menus and desktop entries and assemble the menu.+buildMenu :: Maybe String -> IO Menu+buildMenu mMenuPrefix = do+ mMenuDes <- readXdgMenu mMenuPrefix+ case mMenuDes of+ Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False+ Just (menu, des) -> do dt <- getXdgDesktop+ dirDirs <- getDirectoryDirs+ langs <- getPreferredLanguages+ (fm, ae) <- xdgToMenu dt langs dirDirs des menu+ let fm' = fixOnlyUnallocated ae fm+ return fm'++-- | Convert xdg menu to displayable menu+xdgToMenu :: String -> [String] -> [FilePath] -> [DesktopEntry] -> XdgMenu+ -> IO (Menu, [MenuEntry])+xdgToMenu desktop langs dirDirs des xm = do+ dirEntry <- getDirectoryEntry (xmDirectory xm) dirDirs+ mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)+ let (menus, subaes) = unzip mas+ menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)+ (map toLower $ fmName fm2)) menus+ entries = map (xdgToMenuEntry langs) $+ -- hide NoDisplay+ filter (not . deNoDisplay) $+ -- onlyshowin+ filter (matchesOnlyShowIn desktop) $+ -- excludes+ filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $+ -- includes+ filter (flip matchesCondition (fromMaybe None (xmInclude xm))) des+ onlyUnallocated = xmOnlyUnallocated xm+ aes = if onlyUnallocated then [] else entries ++ concat subaes+ let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,+ fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,+ fmIcon = deIcon =<< dirEntry,+ fmSubmenus = menus',+ fmEntries = entries,+ fmOnlyUnallocated = onlyUnallocated}+ return (fm, aes)++-- | Check the "only show in" logic+matchesOnlyShowIn :: String -> DesktopEntry -> Bool+matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn+ where matchesShowIn = case deOnlyShowIn de of+ [] -> True+ desktops -> desktop `elem` desktops+ notMatchesNotShowIn = case deNotShowIn de of+ [] -> True+ desktops -> not $ desktop `elem` desktops++-- | convert xdg desktop entry to displayble menu entry+xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry+xdgToMenuEntry langs de = MenuEntry {feName = name,+ feComment = comment,+ feCommand = cmd,+ feIcon = mIcon}+ where mc = case deCommand de of+ Nothing -> Nothing+ Just c -> Just $ "(" ++ c ++ ")"+ comment = fromMaybe "??" $ case deComment langs de of+ Nothing -> mc+ Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc+ cmd = fromMaybe "FIXME" $ deCommand de+ name = deName langs de+ mIcon = deIcon de++-- | postprocess unallocated entries+fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu+fixOnlyUnallocated fes fm = fm {fmEntries = entries,+ fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)}+ where entries = if (fmOnlyUnallocated fm)+ then filter (not . (`elem` fes)) (fmEntries fm)+ else fmEntries fm
+ src/System/Taffybar/Menu/MenuWidget.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Menu.MenuWidget+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- MenuWidget provides a hierachical GTK menu containing all+-- applicable desktop entries found on the system. The menu is built+-- according to the version 1.1 of the XDG "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+-----------------------------------------------------------------------------++module System.Taffybar.Menu.MenuWidget (+ -- * Usage+ -- $usage+ menuWidgetNew)+where++import Control.Monad+import Graphics.UI.Gtk hiding (Menu)+import System.Directory+import System.FilePath.Posix+import System.Process+import System.Taffybar.Menu.Menu++-- $usage+--+-- In order to use this widget add the following line to your+-- @taffybar.hs@ file:+--+-- > import System.Taffybar.Menu.MenuWidget+-- > main = do+-- > let menu = menuWidgetNew $ Just "PREFIX-"+--+-- The menu will look for a file named "PREFIX-applications.menu" in+-- the (subdirectory "menus" of the) directories specified by the+-- environment variable XDG_CONFIG_DIRS and "/etc/xdg". If no prefix+-- is given (i.e. if you pass Nothing) then the value of the+-- environment variable XDG_MENU_PREFIX is used, if it is set. If+-- taffybar is running inside a desktop environment like Mate, Gnome,+-- XFCE etc. the environment variables XDG_CONFIG_DIRS and+-- XDG_MENU_PREFIX should be set and you may create the menu like this:+--+-- > let menu = menuWidgetNew Nothing+--+-- Now you can use @menu@ as any other Taffybar widget.+++-- | Add a desktop entry to a gtk menu by appending a gtk menu item.+addItem :: (MenuShellClass msc) =>+ msc -- ^ GTK menu+ -> MenuEntry -- ^ Desktop entry+ -> IO ()+addItem ms de = do+ item <- imageMenuItemNewWithLabel (feName de)+ set item [ widgetTooltipText := Just (feComment de)]+ setIcon item (feIcon de)+ menuShellAppend ms item+ _ <- on item menuItemActivated $ do+ let cmd = feCommand de+ putStrLn $ "Launching '" ++ cmd ++ "'"+ _ <- spawnCommand cmd+ return ()+ return ()++-- | Add an xdg menu to a gtk menu by appending gtk menu items and+-- submenus.+addMenu :: (MenuShellClass msc) =>+ msc -- ^ GTK menu+ -> Menu -- ^ menu+ -> IO ()+addMenu ms fm = do+ let subMenus = fmSubmenus fm+ items = fmEntries fm+ when (not (null items) || not (null subMenus)) $ do+ item <- imageMenuItemNewWithLabel (fmName fm)+ setIcon item (fmIcon fm)+ menuShellAppend ms item+ subMenu <- menuNew+ menuItemSetSubmenu item subMenu+ mapM_ (addMenu subMenu) subMenus+ mapM_ (addItem subMenu) $ items++setIcon :: ImageMenuItem -> Maybe String -> IO ()+setIcon _ Nothing = return ()+setIcon item (Just iconName) = do+ iconTheme <- iconThemeGetDefault+ hasIcon <- iconThemeHasIcon iconTheme iconName+ mImg <- if hasIcon+ then return . Just =<< imageNewFromIconName iconName IconSizeMenu+ else if isAbsolute iconName+ then do ex <- doesFileExist iconName+ if ex+ then do let defaultSize = 24 -- FIXME should auto-adjust to font size+ pb <- pixbufNewFromFileAtScale iconName+ defaultSize defaultSize True+ return . Just =<< imageNewFromPixbuf pb+ else return Nothing+ else return Nothing+ case mImg of+ Just img -> imageMenuItemSetImage item img+ Nothing -> putStrLn $ "Icon not found: " ++ iconName+++-- | Create a new XDG Menu Widget.+menuWidgetNew :: Maybe String -- ^ menu name, must end with a dash,+ -- e.g. "mate-" or "gnome-"+ -> IO Widget+menuWidgetNew mMenuPrefix = do+ mb <- menuBarNew+ m <- buildMenu mMenuPrefix+ addMenu mb m+ widgetShowAll mb+ return (toWidget mb)++-- -- | Show Xdg Menu Widget in a standalone frame.+-- testMenuWidget :: IO ()+-- testMenuWidget = do+-- _ <- initGUI+-- window <- windowNew+-- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False+-- containerAdd window =<< menuWidgetNew Nothing+-- widgetShowAll window+-- mainGUI
+ src/System/Taffybar/Menu/XdgMenu.hs view
@@ -0,0 +1,277 @@+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Menu.XdgMenu+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- Implementation of version 1.1 of the XDG "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+---- specification, see+-- See also 'MenuWidget'.+--+-----------------------------------------------------------------------------+module System.Taffybar.Menu.XdgMenu (+ XdgMenu(..),+ DesktopEntryCondition(..),+ readXdgMenu,+ matchesCondition,+ getXdgDesktop,+ getDirectoryDirs,+ getApplicationEntries,+ getPreferredLanguages)+where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.Char (toLower)+import Data.List+import Data.Maybe+import qualified Data.Set as S+import qualified Debug.Trace as D+import GHC.IO.Encoding+import Prelude+import Safe (headMay)+import System.Directory+import System.Environment+import System.FilePath.Posix+import System.Posix.Files+import System.Taffybar.Menu.DesktopEntry+import System.Taffybar.Util+import Text.XML.Light+import Text.XML.Light.Helpers++-- Environment Variables++-- | Produce a list of config locations to search, starting with+-- XDG_CONFIG_HOME and XDG_CONFIG_DIRS, with fallback to /etc/xdg+getXdgConfigDirs :: IO [String]+getXdgConfigDirs = do+ ch <- lookupEnv "XDG_CONFIG_HOME"+ cd <- lookupEnv "XDG_CONFIG_DIRS"+ let dirs = catMaybes [ch]+ ++ maybe [] splitSearchPath cd+ exDirs <- existingDirs dirs+ return $ if null exDirs+ then ["/etc/xdg/"]+ else map normalise exDirs++existingDirs :: [FilePath] -> IO [FilePath]+existingDirs dirs = do+ exs <- mapM fileExist dirs+ return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs++getXdgMenuPrefix :: IO (Maybe String)+getXdgMenuPrefix = lookupEnv "XDG_MENU_PREFIX"++getXdgDataDirs :: IO [String]+getXdgDataDirs = do+ mDh <- lookupEnv "XDG_DATA_HOME"+ dh <- case mDh of+ Nothing -> do h <- getHomeDirectory+ return $ h </> ".local" </> "share"+ Just d -> return d+ mPf <- lookupEnv "XDG_DATA_DIRS"+ let dirs = maybe [] (map normalise . splitSearchPath) mPf+ ++ ["/usr/local/share", "/usr/share"]+ nubBy equalFilePath <$> existingDirs (dh:dirs)++-- | Find filename(s) of the application menu(s).+getXdgMenuFilenames :: Maybe String+ -- ^ Overrides the value of the environment variable XDG_MENU_PREFIX.+ -- Specifies the prefix for the menu (e.g. 'Just "mate-"'). FIXME+ -> IO [FilePath]+getXdgMenuFilenames mMenuPrefix = do+ configDirs <- getXdgConfigDirs+ maybePrefix <- (mMenuPrefix <|>) <$> getXdgMenuPrefix+ let maybeAddDash t = if last t == '-' then t else t ++ "-"+ dashedPrefix = maybe "" maybeAddDash maybePrefix+ return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs++-- | XDG Menu, cf. "Desktop Menu Specification".+data XdgMenu = XdgMenu {+ xmAppDir :: Maybe String,+ xmDefaultAppDirs :: Bool, -- Use $XDG_DATA_DIRS/applications+ xmDirectoryDir :: Maybe String,+ xmDefaultDirectoryDirs :: Bool, -- Use $XDG_DATA_DIRS/desktop-directories+ xmLegacyDirs :: [String],+ xmName :: String,+ xmDirectory :: String,+ xmOnlyUnallocated :: Bool,+ xmDeleted :: Bool,+ xmInclude :: Maybe DesktopEntryCondition,+ xmExclude :: Maybe DesktopEntryCondition,+ xmSubmenus :: [XdgMenu],+ xmLayout :: [XdgLayoutItem]}+ deriving(Show)++data XdgLayoutItem =+ XliFile String | XliSeparator | XliMenu String | XliMerge String+ deriving(Show)++-- | Return a list of all available desktop entries for a given xdg menu.+getApplicationEntries :: [String] -- ^ Preferred languages+ -> XdgMenu+ -> IO [DesktopEntry]+getApplicationEntries langs xm = do+ defEntries <- if xmDefaultAppDirs xm+ then do dataDirs <- getXdgDataDirs+ putStrLn $ "DataDirs=" ++ show dataDirs+ concat <$> mapM (listDesktopEntries ".desktop" .+ (</> "applications")) dataDirs+ else return []+ return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))+ (map toLower (deName langs de2))) defEntries++-- | Parse menu.+parseMenu :: Element -> Maybe XdgMenu+parseMenu elt =+ let appDir = getChildData "AppDir" elt+ defaultAppDirs = case getChildData "DefaultAppDirs" elt of+ Nothing -> False+ Just _ -> True+ directoryDir = getChildData "DirectoryDir" elt+ defaultDirectoryDirs = case getChildData "DefaultDirectoryDirs" elt of+ Nothing -> False+ Just _ -> True+ name = fromMaybe "Name?" $ getChildData "Name" elt+ dir = fromMaybe "Dir?" $ getChildData "Directory" elt+ onlyUnallocated = case (getChildData "OnlyUnallocated" elt,+ getChildData "NotOnlyUnallocated" elt) of+ (Nothing, Nothing) -> False -- ?!+ (Nothing, Just _) -> False+ (Just _, Nothing) -> True+ (Just _, Just _) -> False -- ?!+ deleted = False -- FIXME+ include = parseConditions "Include" elt+ exclude = parseConditions "Exclude" elt+ layout = parseLayout elt+ subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu+ in Just XdgMenu {xmAppDir = appDir,+ xmDefaultAppDirs = defaultAppDirs,+ xmDirectoryDir = directoryDir,+ xmDefaultDirectoryDirs = defaultDirectoryDirs,+ xmLegacyDirs = [],+ xmName = name,+ xmDirectory = dir,+ xmOnlyUnallocated = onlyUnallocated,+ xmDeleted = deleted,+ xmInclude = include,+ xmExclude = exclude,+ xmSubmenus = subMenus,+ xmLayout = layout} -- FIXME++-- | Parse Desktop Entry conditions for Include/Exclude clauses.+parseConditions :: String -> Element -> Maybe DesktopEntryCondition+parseConditions key elt = case findChild (unqual key) elt of+ Nothing -> Nothing+ Just inc -> doParseConditions (elChildren inc)+ where doParseConditions :: [Element] -> Maybe DesktopEntryCondition+ doParseConditions [] = Nothing+ doParseConditions [e] = parseSingleItem e+ doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts++ parseSingleItem e = case qName (elName e) of+ "Category" -> Just $ Category $ strContent e+ "Filename" -> Just $ Filename $ strContent e+ "And" -> Just $ And $ mapMaybe parseSingleItem+ $ elChildren e+ "Or" -> Just $ Or $ mapMaybe parseSingleItem+ $ elChildren e+ "Not" -> case parseSingleItem (head (elChildren e)) of+ Nothing -> Nothing+ Just rule -> Just $ Not rule+ unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing++-- | Combinable conditions for Include and Exclude statements.+data DesktopEntryCondition = Category String+ | Filename String+ | Not DesktopEntryCondition+ | And [DesktopEntryCondition]+ | Or [DesktopEntryCondition]+ | All+ | None+ deriving (Read, Show, Eq)++parseLayout :: Element -> [XdgLayoutItem]+parseLayout elt = case findChild (unqual "Layout") elt of+ Nothing -> []+ Just lt -> mapMaybe parseLayoutItem (elChildren lt)+ where parseLayoutItem :: Element -> Maybe XdgLayoutItem+ parseLayoutItem e = case qName (elName e) of+ "Separator" -> Just XliSeparator+ "Filename" -> Just $ XliFile $ strContent e+ unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing++-- | Determine whether a desktop entry fulfils a condition.+matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool+matchesCondition de (Category cat) = deHasCategory de cat+matchesCondition de (Filename fn) = fn == deFilename de+matchesCondition de (Not cond) = not $ matchesCondition de cond+matchesCondition de (And conds) = all (matchesCondition de) conds+matchesCondition de (Or conds) = any (matchesCondition de) conds+matchesCondition _ All = True+matchesCondition _ None = False++-- | Determine locale language settings+getPreferredLanguages :: IO [String]+getPreferredLanguages = do+ mLcMessages <- lookupEnv "LC_MESSAGES"+ lang <- case mLcMessages of+ Nothing -> lookupEnv "LANG" -- FIXME?+ Just lm -> return (Just lm)+ case lang of+ Nothing -> return []+ Just l -> return $+ let woEncoding = takeWhile (/= '.') l+ (language, _cm) = span (/= '_') woEncoding+ (country, _m) = span (/= '@') (if null _cm then "" else tail _cm)+ modifier = if null _m then "" else tail _m+ in dgl language country modifier+ where dgl "" "" "" = []+ dgl l "" "" = [l]+ dgl l c "" = [l ++ "_" ++ c, l]+ dgl l "" m = [l ++ "@" ++ m, l]+ dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,+ l ++ "@" ++ m]++-- | Determine current Desktop+getXdgDesktop :: IO String+getXdgDesktop = do+ mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"+ return $ fromMaybe "???" mCurDt++-- | Return desktop directories+getDirectoryDirs :: IO [FilePath]+getDirectoryDirs = do+ dataDirs <- getXdgDataDirs+ existingDirs $ map (</> "desktop-directories") dataDirs++-- | Fetch menus and desktop entries and assemble the XDG menu.+readXdgMenu :: Maybe String -> IO (Maybe (XdgMenu, [DesktopEntry]))+readXdgMenu mMenuPrefix = do+ setLocaleEncoding utf8+ filenames <- getXdgMenuFilenames mMenuPrefix+ headMay . catMaybes <$> traverse maybeMenu filenames++-- | Load and assemble the XDG menu from a specific file, if it exists.+maybeMenu :: FilePath -> IO (Maybe (XdgMenu, [DesktopEntry]))+maybeMenu filename =+ ifM (doesFileExist filename)+ (do+ putStrLn $ "Reading " ++ filename+ contents <- readFile filename+ langs <- getPreferredLanguages+ runMaybeT $ do+ m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu+ des <- lift $ getApplicationEntries langs m+ return (m, des))+ (do+ putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"+ return Nothing)
src/System/Taffybar/NetMonitor.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.NetMonitor@@ -17,6 +19,8 @@ module System.Taffybar.NetMonitor ( netMonitorNew, netMonitorNewWith,+ netMonitorMultiNew,+ netMonitorMultiNewWith, defaultNetFormat ) where @@ -26,9 +30,11 @@ import System.Taffybar.Widgets.PollingLabel import Text.Printf (printf) import Text.StringTemplate+import Data.Maybe (catMaybes)+import qualified Data.Traversable as T defaultNetFormat :: String-defaultNetFormat = "▼ $inKB$kb/s ▲ $outKB$kb/s"+defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$" -- | 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@@ -36,50 +42,97 @@ netMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 1.5) -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\") -> IO Widget-netMonitorNew interval interface =- netMonitorNewWith interval interface 2 defaultNetFormat+netMonitorNew interval interface = netMonitorMultiNew interval [interface] -- | Creates a new network monitor widget with custom template and precision. -- Similar to 'netMonitorNew'. ----- The format template currently supports three units: bytes,--- kilobytes, and megabytes. Automatic intelligent unit selection is--- planned, eventually.+-- The format template currently supports four units: bytes,+-- kilobytes, megabytes, and auto. netMonitorNewWith :: Double -- ^ Polling interval (in seconds, e.g. 1.5) -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")- -> Integer -- ^ Precision for an output- -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $outB$, $outKB$, $outMB$+ -> Int -- ^ Precision for an output+ -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$ -> IO Widget-netMonitorNewWith interval interface prec template = do- sample <- newIORef [0, 0]- label <- pollingLabelNew "" interval $ showInfo sample interval interface template prec- widgetShowAll label- return $ toWidget label+netMonitorNewWith interval interface prec template = netMonitorMultiNewWith interval [interface] prec template -showInfo :: IORef [Integer] -> Double -> String -> String -> Integer -> IO String-showInfo sample interval interface template prec = do- maybeThisSample <- getNetInfo interface- case maybeThisSample of- Nothing -> return ""- Just thisSample -> do- lastSample <- readIORef sample- writeIORef sample thisSample- let deltas = map (max 0 . fromIntegral) $ zipWith (-) thisSample lastSample- speed@[incomingb, outgoingb] = map (/(interval)) deltas- [incomingkb, outgoingkb] = map (setDigits prec . (/1024)) speed- [incomingmb, outgoingmb] = map (setDigits prec . (/square 1024)) speed- attribs = [ ("inB", show incomingb)- , ("inKB", incomingkb)- , ("inMB", incomingmb)- , ("outB", show outgoingb)- , ("outKB", outgoingkb)- , ("outMB", outgoingmb)- ]- return . render . setManyAttrib attribs $ newSTMP 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 :: Double -- ^ Polling interval (in seconds, e.g. 1.5)+ -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")+ -> IO Widget+netMonitorMultiNew interval interfaces = netMonitorMultiNewWith interval interfaces 3 defaultNetFormat -square :: Double -> Double-square x = x ^ (2 :: Int)+-- | Like `newMonitorNewWith` but for multiple interfaces.+netMonitorMultiNewWith :: 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$+ -> IO Widget+netMonitorMultiNewWith interval interfaces prec template = 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) -> do+ mIfaceInfo <- getNetInfo i+ return $ fmap (\ifaceInfo -> (ref, ifaceInfo)) mIfaceInfo+ 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 -setDigits :: Integer -> Double -> String+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))++showInfo :: String -> Int -> (Double, Double) -> String+showInfo template prec (incomingb, outgoingb) =+ let+ attribs = [ ("inB", show incomingb)+ , ("inKB", toKB prec incomingb)+ , ("inMB", toMB prec incomingb)+ , ("inAuto", toAuto prec incomingb)+ , ("outB", show outgoingb)+ , ("outKB", toKB prec outgoingb)+ , ("outMB", toMB prec outgoingb)+ , ("outAuto", toAuto prec outgoingb)+ ]+ in+ render . setManyAttrib attribs $ newSTMP template++toKB :: Int -> Double -> String+toKB prec = setDigits prec . (/1024)++toMB :: Int -> Double -> String+toMB prec = setDigits prec . (/ (1024 * 1024))++setDigits :: Int -> Double -> String setDigits dig a = printf format a where format = "%." ++ show dig ++ "f"++toAuto :: Int -> Double -> String+toAuto prec value = printf "%.*f%s" p v unit+ where value' = max 0 value+ mag :: Int+ mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'+ v = value' / 1024 ** fromIntegral mag+ unit = case mag of+ 0 -> "B/s"+ 1 -> "KiB/s"+ 2 -> "MiB/s"+ 3 -> "GiB/s"+ 4 -> "TiB/s"+ _ -> "??B/s" -- unreachable+ p :: Int+ p = max 0 $ floor $ fromIntegral prec - logBase 10 v
src/System/Taffybar/Pager.hs view
@@ -29,12 +29,16 @@ ----------------------------------------------------------------------------- module System.Taffybar.Pager- ( Pager (config)+ ( Pager (..) , PagerConfig (..)+ , PagerIO , defaultPagerConfig , pagerNew , subscribe , colorize+ , liftPagerX11+ , liftPagerX11Def+ , runWithPager , shorten , wrap , escape@@ -45,12 +49,15 @@ import Control.Exception.Enclosed (catchAny) import Control.Monad.Reader import Data.IORef+import qualified Data.Map as M import Graphics.UI.Gtk (escapeMarkup) import Graphics.X11.Types import Graphics.X11.Xlib.Extras-import Text.Printf (printf)-+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32)+import System.Information.EWMHDesktopInfo import System.Information.X11DesktopInfo+import Text.Printf (printf) type Listener = Event -> IO () type Filter = Atom@@ -59,42 +66,110 @@ -- | Structure contanining functions to customize the pretty printing of -- different widget elements. data PagerConfig = PagerConfig- { activeWindow :: String -> String -- ^ the name of the active window.- , activeLayout :: String -> String -- ^ the currently active layout.- , activeWorkspace :: String -> String -- ^ the currently active workspace.- , hiddenWorkspace :: String -> String -- ^ inactive workspace with windows.- , emptyWorkspace :: String -> String -- ^ inactive workspace with no windows.- , visibleWorkspace :: String -> String -- ^ all other visible workspaces (Xinerama or XRandR).- , urgentWorkspace :: String -> String -- ^ workspaces containing windows with the urgency hint set.- , widgetSep :: String -- ^ separator to use between desktop widgets in 'TaffyPager'.+ { activeWindow :: String -> String+ -- ^ the name of the active window.+ , activeLayout :: String -> String+ -- ^ the currently active layout.+ , activeLayoutIO :: String -> IO String+ -- ^ IO action to modify active layout.+ , activeWorkspace :: String -> String+ -- ^ the currently active workspace.+ , hiddenWorkspace :: String -> String+ -- ^ inactive workspace with windows.+ , emptyWorkspace :: String -> String+ -- ^ inactive workspace with no windows.+ , visibleWorkspace :: String -> String+ -- ^ all other visible workspaces (Xinerama or XRandR).+ , urgentWorkspace :: String -> String+ -- ^ workspaces containing windows with the urgency hint set.+ , widgetSep :: String+ -- ^ separator to use between desktop widgets in 'TaffyPager'.+ , workspaceBorder :: Bool+ -- ^ wrap workspace buttons in a frame+ , workspaceGap :: Int+ -- ^ space in pixels between workspace buttons+ , workspacePad :: Bool+ -- ^ pad workspace name in button+ , useImages :: Bool+ -- ^ use images in the workspace switcher+ , imageSize :: Int+ -- ^ image height and width in pixels+ , fillEmptyImages :: Bool+ -- ^ fill empty images instead of clearing them+ , customIcon :: Bool -> String -> String -> Maybe FilePath+ -- ^ get custom icon based on: has-EWMH-icon, window-title, window-class+ , windowSwitcherFormatter :: M.Map WorkspaceIdx String -> X11WindowHandle -> String+ -- ^ title windows for WindowSwitcher } -- | Structure containing the state of the Pager. data Pager = Pager { config :: PagerConfig -- ^ the configuration settings. , clients :: SubscriptionList -- ^ functions to apply on incoming events depending on their types.+ , pagerX11ContextVar :: IORef X11Context } +type PagerIO a = ReaderT Pager IO a++liftPagerX11 :: X11Property a -> PagerIO a+liftPagerX11 prop = ask >>= lift . flip runWithPager prop++liftPagerX11Def :: a -> X11Property a -> PagerIO a+liftPagerX11Def def prop = liftPagerX11 $ postX11RequestSyncProp prop def++runWithPager :: Pager -> X11Property a -> IO a+runWithPager pager prop = do+ x11Ctx <- readIORef $ pagerX11ContextVar pager+ -- runWithPager should probably changed so that it takes a default value+ runReaderT prop x11Ctx+ -- | Default pretty printing options. defaultPagerConfig :: PagerConfig-defaultPagerConfig = PagerConfig- { activeWindow = escape . shorten 40- , activeLayout = escape- , activeWorkspace = colorize "yellow" "" . wrap "[" "]" . escape- , hiddenWorkspace = escape- , emptyWorkspace = const ""- , visibleWorkspace = wrap "(" ")" . escape- , urgentWorkspace = colorize "red" "yellow" . escape- , widgetSep = " : "+defaultPagerConfig = PagerConfig+ { activeWindow = escape . shorten 40+ , activeLayout = escape+ , activeLayoutIO = return+ , activeWorkspace = colorize "yellow" "" . wrap "[" "]" . escape+ , hiddenWorkspace = escape+ , emptyWorkspace = const ""+ , visibleWorkspace = wrap "(" ")" . escape+ , urgentWorkspace = colorize "red" "yellow" . escape+ , widgetSep = " : "+ , workspaceBorder = False+ , workspaceGap = 0+ , workspacePad = True+ , useImages = False+ , imageSize = 16+ , fillEmptyImages = False+ , customIcon = \_ _ _ -> Nothing+ , windowSwitcherFormatter = defaultFormatEntry } +-- | Build the name to display in the list of windows by prepending the name+-- of the workspace it is currently in to the name of the window itself+defaultFormatEntry+ :: M.Map WorkspaceIdx String -- ^ List $ names of all available workspaces+ -> X11WindowHandle -- ^ Handle of the window to name+ -> String+defaultFormatEntry wsNames ((ws, wtitle, _), _) =+ printf "%s: %s " wsName $ nonEmpty wtitle+ where+ wsName = M.findWithDefault ("WS#" ++ show wsN) ws wsNames+ WSIdx wsN = ws+ nonEmpty x =+ case x of+ [] -> "(nameless window)"+ _ -> x+ -- | Creates a new Pager component (wrapped in the IO Monad) that can be -- used by widgets for subscribing X11 events. pagerNew :: PagerConfig -> IO Pager pagerNew cfg = do ref <- newIORef []- let pager = Pager cfg ref- _ <- forkIO $ withDefaultCtx $ eventLoop (handleEvent ref)+ ctx <- getDefaultCtx+ ctxVar <- newIORef ctx+ let pager = Pager cfg ref ctxVar+ _ <- forkIO $ withDefaultCtx (eventLoop $ handleEvent ref) return pager where handleEvent :: SubscriptionList -> Event -> IO () handleEvent ref event = do@@ -115,7 +190,7 @@ -- the Pager, it will execute Listener on it. subscribe :: Pager -> Listener -> String -> IO () subscribe pager listener filterName = do- eventFilter <- withDefaultCtx $ getAtom filterName+ eventFilter <- runWithPager pager $ getAtom filterName registered <- readIORef (clients pager) let next = (listener, eventFilter) writeIORef (clients pager) (next : registered)
src/System/Taffybar/SimpleClock.hs view
@@ -10,7 +10,7 @@ ClockConfig(..) ) where -import Control.Monad.Trans ( MonadIO, liftIO )+import Control.Monad.Trans ( liftIO ) import Data.Time.Calendar ( toGregorian ) import qualified Data.Time.Clock as Clock import Data.Time.Format@@ -21,22 +21,24 @@ import System.Taffybar.Widgets.PollingLabel import System.Taffybar.Widgets.Util -makeCalendar :: IO Window-makeCalendar = do+makeCalendar :: IO TimeZone -> IO Window+makeCalendar tzfn = do container <- windowNew cal <- calendarNew containerAdd container cal -- update the date on show- _ <- onShow container $ liftIO $ resetCalendarDate cal+ _ <- on container showSignal $ resetCalendarDate cal tzfn -- prevent calendar from being destroyed, it can be only hidden: _ <- on container deleteEvent $ do- liftIO (widgetHideAll container)+ liftIO (widgetHide container) return True return container -resetCalendarDate :: Calendar -> IO ()-resetCalendarDate cal = do- (y,m,d) <- Clock.getCurrentTime >>= return . toGregorian . Clock.utctDay+resetCalendarDate :: Calendar -> IO TimeZone -> IO ()+resetCalendarDate cal tzfn = do+ tz <- tzfn+ current <- Clock.getCurrentTime+ let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y) calendarSelectDay cal (fromIntegral d) @@ -44,7 +46,7 @@ toggleCalendar w c = do isVis <- get c widgetVisible if isVis- then widgetHideAll c+ then widgetHide c else do attachPopup w "Calendar" c displayPopup w c@@ -100,7 +102,7 @@ ebox <- eventBoxNew containerAdd ebox l eventBoxSetVisibleWindow ebox False- cal <- makeCalendar+ cal <- makeCalendar $ getTZ ti _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal) widgetShowAll ebox return (toWidget ebox)
src/System/Taffybar/Systray.hs view
@@ -17,8 +17,5 @@ widgetShowAll w boxPackStart box w PackNatural 0 - _ <- on trayManager trayIconRemoved $ \_ -> do- putStrLn "Tray icon removed"- widgetShowAll box return (toWidget box)
src/System/Taffybar/TaffyPager.hs view
@@ -24,8 +24,8 @@ -- hints and X11 events. -- -- This widget is actually only a convenience wrapper around a Pager, a--- WorkspaceSwitcher, a LayoutSwitcher and a WindowSwitcher. If you are--- looking for more advanced configurations (like having components+-- WorkspaceSwitcher (now WorkspaceHUD), a LayoutSwitcher and a WindowSwitcher.+-- If you are looking for more advanced configurations (like having components -- displayed separately, or using only part of them), consult directly the -- documentation for each of the components. --@@ -34,16 +34,18 @@ module System.Taffybar.TaffyPager ( -- * Usage -- $usage- taffyPagerNew-, PagerConfig (..)+ PagerConfig (..) , defaultPagerConfig+, taffyPagerHUDLegacy+, taffyPagerHUDNew+, taffyPagerNew ) where import Graphics.UI.Gtk-import System.Taffybar.Pager-import System.Taffybar.WorkspaceSwitcher import System.Taffybar.LayoutSwitcher+import System.Taffybar.Pager import System.Taffybar.WindowSwitcher+import System.Taffybar.WorkspaceHUD -- $usage --@@ -68,17 +70,41 @@ -- now you can use @pager@ as any other Taffybar widget. -- | Create a new TaffyPager widget.+{-# DEPRECATED taffyPagerNew, taffyPagerHUDLegacy+ "Using PagerConfig is deprecated; Use WorkspaceHUDConfig instead." #-} taffyPagerNew :: PagerConfig -> IO Widget-taffyPagerNew cfg = do+taffyPagerNew = taffyPagerHUDLegacy++taffyPagerHUDNew :: PagerConfig -> WorkspaceHUDConfig -> IO Widget+taffyPagerHUDNew cfg hudConf = do pgr <- pagerNew cfg- wss <- wspaceSwitcherNew pgr+ whud <- buildWorkspaceHUD hudConf pgr los <- layoutSwitcherNew pgr wnd <- windowSwitcherNew pgr sp1 <- separator cfg sp2 <- separator cfg box <- hBoxNew False 0 - boxPackStart box wss PackNatural 0+ boxPackStart box whud PackNatural 0+ boxPackStart box sp1 PackNatural 0+ boxPackStart box los PackNatural 0+ boxPackStart box sp2 PackNatural 0+ boxPackStart box wnd PackNatural 0++ widgetShowAll box+ return (toWidget box)++taffyPagerHUDLegacy :: PagerConfig -> IO Widget+taffyPagerHUDLegacy cfg = do+ pgr <- pagerNew cfg+ whud <- buildWorkspaceHUD (hudFromPagerConfig cfg) pgr+ los <- layoutSwitcherNew pgr+ wnd <- windowSwitcherNew pgr+ sp1 <- separator cfg+ sp2 <- separator cfg+ box <- hBoxNew False 0++ boxPackStart box whud PackNatural 0 boxPackStart box sp1 PackNatural 0 boxPackStart box los PackNatural 0 boxPackStart box sp2 PackNatural 0
+ src/System/Taffybar/ToggleMonitor.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.ToggleMonitor+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides a dbus interface that allows users to toggle the display+-- of taffybar on each monitor while it is running.++module System.Taffybar.ToggleMonitor (+ handleToggleRequests,+ toggleableMonitors,+ withToggleSupport+) where++import Control.Applicative+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import DBus+import DBus.Client+import Data.Int+import qualified Data.Map as M+import Data.Maybe+import Graphics.UI.Gtk.Gdk.Screen+import Paths_taffybar ( getDataDir )+import Prelude+import System.Directory+import System.FilePath.Posix+import System.Taffybar+import Text.Read ( readMaybe )++-- $usage+--+-- To use this module, import it in your taffybar.hs and use the+-- 'withToggleSupport' function to start taffybar, where you might otherwise+-- have used 'defaultTaffybar', like so:+--+-- > main = withToggleSupport defaultTaffybarConfig {}+--+-- To toggle taffybar on the monitor that is currently active, issue the+-- following command:+--+-- > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent+++toggleableMonitors+ :: MV.MVar (M.Map Int Bool)+ -> TaffybarConfigEQ+ -> IO (Int -> Maybe TaffybarConfigEQ)+toggleableMonitors enabledVar cfg = do+ numToEnabled <- MV.readMVar enabledVar+ let fn monNumber =+ if fromMaybe True $ M.lookup monNumber numToEnabled+ then Just cfg+ else Nothing+ return fn++getActiveScreenNumber :: MaybeT IO Int+getActiveScreenNumber = do+ screen <- MaybeT screenGetDefault+ window <- MaybeT $ screenGetActiveWindow screen+ lift $ screenGetMonitorAtWindow screen window++taffybarTogglePath :: ObjectPath+taffybarTogglePath = "/taffybar/toggle"++taffybarToggleInterface :: InterfaceName+taffybarToggleInterface = "taffybar.toggle"++toggleStateFile :: IO FilePath+toggleStateFile = (</> "toggleState.hs") <$> getDataDir++handleToggleRequests :: MV.MVar (M.Map Int Bool) -> IO () -> IO ()+handleToggleRequests enabledVar refreshTaffyWindows = do+ let toggleTaffyOnMon fn mon = do+ MV.modifyMVar_ enabledVar $ \numToEnabled -> do+ let current = fromMaybe True $ M.lookup mon numToEnabled+ result = M.insert mon (fn current) numToEnabled+ flip writeFile (show result) =<< toggleStateFile+ return result+ refreshTaffyWindows+ toggleTaffy = do+ num <- runMaybeT getActiveScreenNumber+ toggleTaffyOnMon not $ fromMaybe 0 num+ takeInt :: (Int -> a) -> (Int32 -> a)+ takeInt = (. fromIntegral)+ client <- connectSession+ _ <- requestName client "taffybar.toggle"+ [nameAllowReplacement, nameReplaceExisting]+ let interface =+ defaultInterface+ { interfaceName = taffybarToggleInterface+ , interfaceMethods =+ [ autoMethod "toggleCurrent" toggleTaffy+ , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not+ , autoMethod "hideOnMonitor" $+ takeInt $ toggleTaffyOnMon (const False)+ , autoMethod "showOnMonitor" $+ takeInt $ toggleTaffyOnMon (const True)+ ]+ }+ export client taffybarTogglePath interface++withToggleSupport :: TaffybarConfig -> IO ()+withToggleSupport config = do+ stateFilepath <- toggleStateFile+ filepathExists <- doesFileExist stateFilepath+ startingMap <-+ if filepathExists+ then+ readMaybe <$> readFile stateFilepath+ else+ return Nothing+ enabledVar <- MV.newMVar $ fromMaybe M.empty startingMap+ let modified = config { startRefresher = handleToggleRequests enabledVar+ , getMonitorConfig = toggleableMonitors enabledVar+ }+ defaultTaffybar modified
+ src/System/Taffybar/Util.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Util+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable++module System.Taffybar.Util where++infixl 4 ??+(??) :: Functor f => f (a -> b) -> a -> f b+fab ?? a = fmap ($ a) fab+{-# INLINE (??) #-}++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM cond whenTrue whenFalse =+ cond >>= (\bool -> if bool then whenTrue else whenFalse)
+ src/System/Taffybar/Volume.hs view
@@ -0,0 +1,28 @@+module System.Taffybar.Volume (+ volumeTextNew,+ volumeControlNew+) where++import System.Information.Volume+import System.Taffybar.Widgets.PollingLabel+import Graphics.UI.Gtk++-- | Creates a new text volume meter+volumeTextNew :: String+ -> String+ -> Double+ -> IO Widget+volumeTextNew mixer control pollSeconds = 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
src/System/Taffybar/Weather.hs view
@@ -77,6 +77,7 @@ import Text.Parsec import Text.Printf import Text.StringTemplate+import qualified Network.Browser as Browser import System.Taffybar.Widgets.PollingLabel @@ -183,19 +184,17 @@ -- | Simple: download the document at a URL. Taken from Real World -- Haskell.-downloadURL :: String -> IO (Either String String)-downloadURL url = do- resp <- simpleHTTP request- case resp of- Left x -> return $ Left ("Error connecting: " ++ show x)- Right r ->- case rspCode r of- (2,_,_) -> return $ Right (rspBody r)- (3,_,_) -> -- A HTTP redirect- case findHeader HdrLocation r of- Nothing -> return $ Left (show r)- Just url' -> downloadURL url'- _ -> return $ Left (show r)+downloadURL :: Maybe String -> String -> IO (Either String String)+downloadURL mProxy url = do+ (_, r) <- Browser.browse $ do+ case mProxy of+ Just proxy -> Browser.setProxy $ Browser.Proxy proxy Nothing+ Nothing -> return ()+ Browser.setAllowRedirects True+ Browser.request request+ case rspCode r of+ (2,_,_) -> return $ Right (rspBody r)+ _ -> return $ Left (show r) where request = Request { rqURI = uri , rqMethod = GET@@ -204,9 +203,9 @@ } Just uri = parseURI url -getWeather :: String -> IO (Either String WeatherInfo)-getWeather url = do- dat <- downloadURL url+getWeather :: Maybe String -> String -> IO (Either String WeatherInfo)+getWeather mProxy url = do+ dat <- downloadURL mProxy url case dat of Right dat' -> case parse parseData url dat' of Right d -> return (Right d)@@ -234,22 +233,25 @@ getCurrentWeather :: IO (Either String WeatherInfo) -> StringTemplate String+ -> StringTemplate String -> WeatherFormatter- -> IO String-getCurrentWeather getter tpl formatter = do+ -> IO (String, Maybe String)+getCurrentWeather getter labelTpl tooltipTpl formatter = do dat <- getter case dat of- Right wi -> do- case formatter of- DefaultWeatherFormatter -> return (defaultFormatter tpl wi)- WeatherFormatter f -> return (f wi)+ Right wi ->+ return $ case formatter of+ DefaultWeatherFormatter -> (escapeMarkup $ defaultFormatter labelTpl wi,+ Just $ escapeMarkup $ defaultFormatter tooltipTpl wi)+ WeatherFormatter f -> (f wi, Just $ f wi)+ Left err -> do putStrLn err- return "N/A"+ return ("N/A", Nothing) -- | The NOAA URL to get data from baseUrl :: String-baseUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded"+baseUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded" -- | A wrapper to allow users to specify a custom weather formatter. -- The default interpolates variables into a string as described@@ -262,38 +264,55 @@ -- provide a custom function to turn a 'WeatherInfo' into a String via the -- 'weatherFormatter' field. data WeatherConfig =- WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default- , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F- , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)+ WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default+ , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F+ , weatherTemplateTooltip :: String -- ^ Template string, as described above. Default: $tempF$ °F+ , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)+ , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing } -- | A sensible default configuration for the weather widget that just -- renders the temperature. defaultWeatherConfig :: String -> WeatherConfig-defaultWeatherConfig station = WeatherConfig { weatherStation = station- , weatherTemplate = "$tempF$ °F"- , weatherFormatter = DefaultWeatherFormatter- }+defaultWeatherConfig station = WeatherConfig+ { weatherStation = station+ , weatherTemplate = "$tempF$ °F"+ , weatherTemplateTooltip = unlines ["Station: $stationPlace$",+ "Time: $day$.$month$.$year$ $hour$",+ "Temperature: $tempF$ °F",+ "Pressure: $pressure$ hPa",+ "Wind: $wind$",+ "Visibility: $visibility$",+ "Sky Condition: $skyCondition$",+ "Dew Point: $dewPoint$",+ "Humidity: $humidity$"+ ]+ , weatherFormatter = DefaultWeatherFormatter+ , weatherProxy = Nothing} -- | Create a periodically-updating weather widget that polls NOAA. weatherNew :: WeatherConfig -- ^ Configuration to render- -> Double -- ^ Polling period in _minutes_- -> IO Widget+ -> Double -- ^ Polling period in _minutes_+ -> IO Widget weatherNew cfg delayMinutes = do let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)- getter = getWeather url- weatherCustomNew getter (weatherTemplate cfg) (weatherFormatter cfg) delayMinutes+ getter = getWeather (weatherProxy cfg) url+ weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)+ (weatherFormatter cfg) delayMinutes -- | Create a periodically-updating weather widget using custom weather getter weatherCustomNew :: IO (Either String WeatherInfo) -- ^ Weather querying action -> String -- ^ Weather template+ -> String -- ^ Weather template -> WeatherFormatter -- ^ Weather formatter -> Double -- ^ Polling period in _minutes_ -> IO Widget-weatherCustomNew getter tpl formatter delayMinutes = do- let tpl' = newSTMP tpl+weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = do+ let labelTpl' = newSTMP labelTpl+ tooltipTpl' = newSTMP tooltipTpl - l <- pollingLabelNew "N/A" (delayMinutes * 60) (getCurrentWeather getter tpl' formatter)+ l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60)+ (getCurrentWeather getter labelTpl' tooltipTpl' formatter) widgetShowAll l return l
src/System/Taffybar/Widgets/Graph.hs view
@@ -10,24 +10,25 @@ -- -- Note: all of the data fed to this widget should be in the range -- [0,1].-module System.Taffybar.Widgets.Graph (+module System.Taffybar.Widgets.Graph -- * Types- GraphHandle,- GraphConfig(..),- GraphDirection(..),- GraphStyle(..),+ ( GraphHandle+ , GraphConfig(..)+ , GraphDirection(..)+ , GraphStyle(..) -- * Functions- graphNew,- graphAddSample,- defaultGraphConfig+ , graphNew+ , graphAddSample+ , defaultGraphConfig ) where -import Prelude hiding ( mapM_ )-import Control.Concurrent-import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )-import Data.Foldable ( mapM_ )-import Control.Monad ( when )-import Control.Monad.Trans ( liftIO )+import System.Taffybar.Widgets.Util+import Prelude hiding ( mapM_ )+import Control.Concurrent+import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )+import Data.Foldable ( mapM_ )+import Control.Monad ( when )+import Control.Monad.Trans ( liftIO ) import qualified Data.Sequence as S import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as M@@ -51,31 +52,43 @@ -- | The configuration options for the graph. The padding is the -- number of pixels reserved as blank space around the widget in each -- direction.-data GraphConfig =- GraphConfig { graphPadding :: Int -- ^ Number of pixels of padding on each side of the graph widget- , graphBackgroundColor :: (Double, Double, Double) -- ^ The background color of the graph (default black)- , graphBorderColor :: (Double, Double, Double) -- ^ The border color drawn around the graph (default gray)- , graphBorderWidth :: Int -- ^ The width of the border (default 1, use 0 to disable the border)- , graphDataColors :: [(Double, Double, Double, Double)] -- ^ Colors for each data set (default cycles between red, green and blue)- , graphDataStyles :: [GraphStyle] -- ^ How to draw each data point (default @repeat Area@)- , graphHistorySize :: Int -- ^ The number of data points to retain for each data set (default 20)- , graphLabel :: Maybe String -- ^ May contain Pango markup (default @Nothing@)- , graphWidth :: Int -- ^ The width (in pixels) of the graph widget (default 50)- , graphDirection :: GraphDirection- }+data GraphConfig = GraphConfig+ -- | Number of pixels of padding on each side of the graph widget+ { graphPadding :: Int+ -- | The background color of the graph (default black)+ , graphBackgroundColor :: (Double, Double, Double)+ -- | The border color drawn around the graph (default gray)+ , graphBorderColor :: (Double, Double, Double)+ -- | The width of the border (default 1, use 0 to disable the border)+ , graphBorderWidth :: Int+ -- | Colors for each data set (default cycles between red, green and blue)+ , graphDataColors :: [(Double, Double, Double, Double)]+ -- | How to draw each data point (default @repeat Area@)+ , graphDataStyles :: [GraphStyle]+ -- | The number of data points to retain for each data set (default 20)+ , graphHistorySize :: Int+ -- | May contain Pango markup (default @Nothing@)+ , graphLabel :: Maybe String+ -- | The width (in pixels) of the graph widget (default 50)+ , graphWidth :: Int+ -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)+ , graphDirection :: GraphDirection+ } defaultGraphConfig :: GraphConfig-defaultGraphConfig = GraphConfig { graphPadding = 2- , graphBackgroundColor = (0.0, 0.0, 0.0)- , graphBorderColor = (0.5, 0.5, 0.5)- , graphBorderWidth = 1- , graphDataColors = cycle [(1,0,0,0), (0,1,0,0), (0,0,1,0)]- , graphDataStyles = repeat Area- , graphHistorySize = 20- , graphLabel = Nothing- , graphWidth = 50- , graphDirection = LEFT_TO_RIGHT- }+defaultGraphConfig =+ GraphConfig+ { graphPadding = 2+ , graphBackgroundColor = (0.0, 0.0, 0.0)+ , graphBorderColor = (0.5, 0.5, 0.5)+ , graphBorderWidth = 1+ , graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)]+ , graphDataStyles = repeat Area+ , graphHistorySize = 20+ , graphLabel = Nothing+ , graphWidth = 50+ , graphDirection = LEFT_TO_RIGHT+ } -- | Add a data point to the graph for each of the tracked data sets. -- There should be as many values in the list as there are data sets.@@ -177,21 +190,20 @@ sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg) -drawBorder :: MVar GraphState -> Gtk.DrawingArea -> IO ()+drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawBorder mv drawArea = do- (w, h) <- Gtk.widgetGetSize drawArea- drawWin <- Gtk.widgetGetDrawWindow drawArea- s <- readMVar mv+ (w, h) <- widgetGetAllocatedSize drawArea+ s <- liftIO $ readMVar mv let cfg = graphConfig s- Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h)- modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })+ renderFrameAndBackground cfg w h+ liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True }) return () -drawGraph :: MVar GraphState -> Gtk.DrawingArea -> IO ()+drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render () drawGraph mv drawArea = do- (w, h) <- Gtk.widgetGetSize drawArea- drawWin <- Gtk.widgetGetDrawWindow drawArea- s <- readMVar mv+ (w, h) <- widgetGetAllocatedSize drawArea+ drawBorder mv drawArea+ s <- liftIO $ readMVar mv let hist = graphHistory s cfg = graphConfig s histSize = graphHistorySize cfg@@ -200,8 +212,8 @@ xStep = fromIntegral w / fromIntegral (histSize - 1) case hist of- [] -> Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h)- _ -> Gtk.renderWithDrawable drawWin (renderGraph hist cfg w h xStep)+ [] -> renderFrameAndBackground cfg w h+ _ -> renderGraph hist cfg w h xStep graphNew :: GraphConfig -> IO (Gtk.Widget, GraphHandle) graphNew cfg = do@@ -213,8 +225,7 @@ } Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (-1)- _ <- Gtk.on drawArea Gtk.exposeEvent $ Gtk.tryEvent $ liftIO (drawGraph mv drawArea)- _ <- Gtk.on drawArea Gtk.realize $ liftIO (drawBorder mv drawArea)+ _ <- Gtk.on drawArea Gtk.draw $ drawGraph mv drawArea box <- Gtk.hBoxNew False 1 case graphLabel cfg of@@ -224,6 +235,8 @@ Gtk.labelSetMarkup l lbl Gtk.boxPackStart box l Gtk.PackNatural 0 + Gtk.set drawArea [Gtk.widgetVExpand Gtk.:= True]+ Gtk.set box [Gtk.widgetVExpand Gtk.:= True] Gtk.boxPackStart box drawArea Gtk.PackGrow 0 Gtk.widgetShowAll box return (Gtk.toWidget box, GH mv)
+ src/System/Taffybar/Widgets/Icon.hs view
@@ -0,0 +1,58 @@+-- | This is a simple static image widget, and a polling image widget that+-- updates its contents by calling a callback at a set interval.+module System.Taffybar.Widgets.Icon+(+ iconImageWidgetNew,+ pollingIconImageWidgetNew+) where++import Control.Concurrent ( forkIO, threadDelay )+import Control.Exception as E+import Control.Monad ( forever )+import Graphics.UI.Gtk++-- | Create a new widget that displays a static image+--+-- > iconImageWidgetNew path+--+-- returns a widget with icon at @path@.+iconImageWidgetNew :: FilePath -> IO Widget+iconImageWidgetNew path = do+ box <- hBoxNew False 0+ icon <- imageNewFromFile path+ boxPackStart box icon PackNatural 0+ widgetShowAll box+ return $ toWidget box++-- | Create a new widget that updates itself at regular intervals. The+-- function+--+-- > pollingIconImageWidgetNew path interval cmd+--+-- returns a widget with initial icon at @path@. The widget+-- forks a thread to update its contents every @interval@ seconds.+-- The command should return a FilePath of a valid icon.+--+-- If the IO action throws an exception, it will be swallowed and the+-- label will not update until the update interval expires.+pollingIconImageWidgetNew :: FilePath -- ^ Initial file path of the icon+ -> Double -- ^ Update interval (in seconds)+ -> IO FilePath -- ^ Command to run to get the input filepath+ -> IO Widget+pollingIconImageWidgetNew path interval cmd = do+ box <- hBoxNew False 0+ icon <- imageNewFromFile path+ _ <- on icon realize $ do+ _ <- forkIO $ forever $ do+ let tryUpdate = do+ str <- cmd+ postGUIAsync $ imageSetFromFile icon str+ E.catch tryUpdate ignoreIOException+ threadDelay $ floor (interval * 1000000)+ return ()+ boxPackStart box icon PackNatural 0+ widgetShowAll box+ return $ toWidget box++ignoreIOException :: IOException -> IO ()+ignoreIOException _ = return ()
src/System/Taffybar/Widgets/PollingLabel.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | This is a simple text widget that updates its contents by calling -- a callback at a set interval.-module System.Taffybar.Widgets.PollingLabel ( pollingLabelNew ) where+module System.Taffybar.Widgets.PollingLabel ( pollingLabelNew,+ pollingLabelNewWithTooltip) where import Control.Concurrent ( forkIO, threadDelay ) import Control.Exception.Enclosed as E@@ -35,6 +36,27 @@ case estr of Left _ -> return () Right str -> postGUIAsync $ labelSetMarkup l str+ threadDelay $ floor (interval * 1000000)+ return ()++ return (toWidget l)++pollingLabelNewWithTooltip :: String -- ^ Initial value for the label+ -> Double -- ^ Update interval (in seconds)+ -> IO (String, Maybe String) -- ^ Command to run to get the input string+ -> IO Widget+pollingLabelNewWithTooltip initialString interval cmd = do+ l <- labelNew (Nothing :: Maybe String)+ labelSetMarkup l initialString++ _ <- on l realize $ do+ _ <- forkIO $ forever $ do+ estr <- E.tryAny cmd+ case estr of+ Left _ -> return ()+ Right (labelStr, tooltipStr) -> postGUIAsync $ do+ labelSetMarkup l labelStr+ widgetSetTooltipMarkup l tooltipStr threadDelay $ floor (interval * 1000000) return ()
src/System/Taffybar/Widgets/Util.hs view
@@ -15,8 +15,10 @@ module System.Taffybar.Widgets.Util where import Control.Monad-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class+import Data.Tuple.Sequence import Graphics.UI.Gtk+import Prelude -- | Execute the given action as a response to any of the given types -- of mouse button clicks.@@ -39,13 +41,14 @@ set window [ windowTitle := title , windowTypeHint := WindowTypeHintTooltip , windowSkipTaskbarHint := True+ , windowSkipPagerHint := True+ , windowTransientFor :=> getWindow ]- windowSetSkipPagerHint window True windowSetKeepAbove window True windowStick window- Just topLevel <- widgetGetAncestor widget gTypeWindow- let topLevelWindow = castToWindow topLevel- windowSetTransientFor window topLevelWindow+ where getWindow = do+ Just topLevelWindow <- (fmap castToWindow) <$> widgetGetAncestor widget gTypeWindow+ return topLevelWindow -- | Display the given popup widget (previously prepared using the -- 'attachPopup' function) immediately beneath (or above) the given@@ -57,8 +60,15 @@ displayPopup widget window = do windowSetPosition window WinPosMouse (x, y ) <- windowGetPosition window- (_, y') <- widgetGetSize widget+ (_, y') <- widgetGetSizeRequest widget widgetShowAll window if y > y' then windowMove window x (y - y') else windowMove window x y'++widgetGetAllocatedSize+ :: (WidgetClass self, MonadIO m)+ => self -> m (Int, Int)+widgetGetAllocatedSize widget =+ liftIO $+ sequenceT (widgetGetAllocatedWidth widget, widgetGetAllocatedHeight widget)
src/System/Taffybar/Widgets/VerticalBar.hs view
@@ -8,43 +8,68 @@ -- * Accessors/Constructors verticalBarNew, verticalBarSetPercent,- defaultBarConfig+ defaultBarConfig,+ defaultBarConfigIO ) where -import Control.Concurrent+import Control.Concurrent+import Control.Monad.Trans import qualified Graphics.Rendering.Cairo as C-import Graphics.UI.Gtk+import Graphics.UI.Gtk+import System.Taffybar.Widgets.Util newtype VerticalBarHandle = VBH (MVar VerticalBarState)-data VerticalBarState =- VerticalBarState { barIsBootstrapped :: Bool- , barPercent :: Double- , barCanvas :: DrawingArea- , barConfig :: BarConfig- }+data VerticalBarState = VerticalBarState+ { barIsBootstrapped :: Bool+ , barPercent :: Double+ , barCanvas :: DrawingArea+ , barConfig :: BarConfig+ } data BarDirection = HORIZONTAL | VERTICAL -data BarConfig =- BarConfig { barBorderColor :: (Double, Double, Double) -- ^ Color of the border drawn around the widget- , barBackgroundColor :: Double -> (Double, Double, Double) -- ^ The background color of the widget- , barColor :: Double -> (Double, Double, Double) -- ^ A function to determine the color of the widget for the current data point- , barPadding :: Int -- ^ Number of pixels of padding around the widget- , barWidth :: Int- , barDirection :: BarDirection- }+data BarConfig+ = BarConfig -- | Color of the border drawn around the widget+ { barBorderColor :: (Double, Double, Double)+ -- | The background color of the widget+ , barBackgroundColor :: Double -> (Double, Double, Double)+ -- | A function to determine the color of the widget for the current data point+ , barColor :: Double -> (Double, Double, Double)+ -- | Number of pixels of padding around the widget+ , barPadding :: Int+ , barWidth :: Int+ , barDirection :: BarDirection}+ | BarConfigIO { barBorderColorIO :: IO (Double, Double, Double)+ , barBackgroundColorIO :: Double -> IO (Double, Double, Double)+ , barColorIO :: Double -> IO (Double, Double, Double)+ , barPadding :: Int+ , barWidth :: Int+ , barDirection :: BarDirection} -- | A default bar configuration. The color of the active portion of -- the bar must be specified. defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig-defaultBarConfig c = BarConfig { barBorderColor = (0.5, 0.5, 0.5)- , barBackgroundColor = const (0, 0, 0)- , barColor = c- , barPadding = 2- , barWidth = 15- , barDirection = VERTICAL- }+defaultBarConfig c =+ BarConfig+ { barBorderColor = (0.5, 0.5, 0.5)+ , barBackgroundColor = const (0, 0, 0)+ , barColor = c+ , barPadding = 2+ , barWidth = 15+ , barDirection = VERTICAL+ } +defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig+defaultBarConfigIO c =+ BarConfigIO+ { barBorderColorIO = return (0.5, 0.5, 0.5)+ , barBackgroundColorIO = \_ -> return (0, 0, 0)+ , barColorIO = c+ , barPadding = 2+ , barWidth = 15+ , barDirection = VERTICAL+ }+ verticalBarSetPercent :: VerticalBarHandle -> Double -> IO () verticalBarSetPercent (VBH mv) pct = do s <- readMVar mv@@ -58,21 +83,39 @@ clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d +liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)+liftedBackgroundColor bc pct =+ case bc of+ BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct)+ BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct++liftedBorderColor :: BarConfig -> IO (Double, Double, Double)+liftedBorderColor bc =+ case bc of+ BarConfig { barBorderColor = border } -> return border+ BarConfigIO { barBorderColorIO = border } -> border++liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)+liftedBarColor bc pct =+ case bc of+ BarConfig { barColor = c } -> return (c pct)+ BarConfigIO { barColorIO = c } -> c pct+ renderFrame :: Double -> BarConfig -> Int -> Int -> C.Render () renderFrame pct cfg width height = do let fwidth = fromIntegral width fheight = fromIntegral height -- Now draw the user's requested background, respecting padding- let (bgR, bgG, bgB) = barBackgroundColor cfg pct- pad = barPadding cfg+ (bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct+ let pad = barPadding cfg fpad = fromIntegral pad C.setSourceRGB bgR bgG bgB C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad) C.fill -- Now draw a nice frame- let (frameR, frameG, frameB) = barBorderColor cfg+ (frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg C.setSourceRGB frameR frameG frameB C.setLineWidth 1.0 C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1)@@ -101,36 +144,35 @@ yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height C.scale xS yS - let (r, g, b) = (barColor cfg) pct+ (r, g, b) <- C.liftIO $ liftedBarColor cfg pct C.setSourceRGB r g b C.translate 0 newOrigin C.rectangle 0 0 activeWidth activeHeight C.fill -drawBar :: MVar VerticalBarState -> DrawingArea -> IO ()+drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render () drawBar mv drawArea = do- (w, h) <- widgetGetSize drawArea- drawWin <- widgetGetDrawWindow drawArea- s <- readMVar mv- let pct = barPercent s- modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })- renderWithDrawable drawWin (renderBar pct (barConfig s) w h)+ (w, h) <- widgetGetAllocatedSize drawArea+ s <- liftIO $ do+ s <- readMVar mv+ modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })+ return s+ renderBar (barPercent s) (barConfig s) w h verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle) verticalBarNew cfg = do drawArea <- drawingAreaNew-- mv <- newMVar VerticalBarState { barIsBootstrapped = False- , barPercent = 0- , barCanvas = drawArea- , barConfig = cfg- }-+ mv <-+ newMVar+ VerticalBarState+ { barIsBootstrapped = False+ , barPercent = 0+ , barCanvas = drawArea+ , barConfig = cfg+ } widgetSetSizeRequest drawArea (barWidth cfg) (-1)- _ <- on drawArea exposeEvent $ tryEvent $ C.liftIO (drawBar mv drawArea)-+ _ <- on drawArea draw $ drawBar mv drawArea box <- hBoxNew False 1 boxPackStart box drawArea PackGrow 0 widgetShowAll box- return (toWidget box, VBH mv)
src/System/Taffybar/WindowSwitcher.hs view
@@ -25,13 +25,13 @@ windowSwitcherNew ) where -import Control.Monad (forM_)+import Control.Monad.Reader import qualified Data.Map as M-import Control.Monad.IO.Class ( liftIO ) import qualified Graphics.UI.Gtk as Gtk-import Graphics.X11.Xlib.Extras (Event)-import System.Information.EWMHDesktopInfo-import System.Taffybar.Pager+import Graphics.X11.Xlib.Extras (Event)+import System.Information.EWMHDesktopInfo+import System.Information.X11DesktopInfo+import System.Taffybar.Pager -- $usage --@@ -63,40 +63,32 @@ -- callback in another thread. We need to use postGUIAsync in it. let cfg = config pager callback = pagerCallback cfg label- subscribe pager callback "_NET_ACTIVE_WINDOW"- assembleWidget label+ subscribe pager (runWithPager pager . callback) "_NET_ACTIVE_WINDOW"+ assembleWidget pager label -- | Build a suitable callback function that can be registered as Listener -- of "_NET_ACTIVE_WINDOW" standard events. It will keep track of the -- currently focused window.-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> X11Property () pagerCallback cfg label _ = do- title <- withDefaultCtx getActiveWindowTitle+ title <- getActiveWindowTitle let decorate = activeWindow cfg- Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title)+ lift $ Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title) --- | Build the graphical representation of the widget.-assembleWidget :: Gtk.Label -> IO Gtk.Widget-assembleWidget label = do+assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget+assembleWidget pager label = do+ ebox <- Gtk.eventBoxNew+ Gtk.widgetSetName ebox "WindowTitle"+ Gtk.containerAdd ebox label+ title <- Gtk.menuItemNew Gtk.widgetSetName title "title"- Gtk.containerAdd title label+ Gtk.containerAdd title ebox switcher <- Gtk.menuBarNew Gtk.widgetSetName switcher "WindowSwitcher" Gtk.containerAdd switcher title - Gtk.rcParseString $ unlines [ "style 'WindowSwitcher' {"- , " xthickness = 0"- , " GtkMenuBar::internal-padding = 0"- , "}"- , "style 'title' {"- , " xthickness = 0"- , " GtkMenuItem::horizontal-padding = 0"- , "}"- , "widget '*WindowSwitcher' style 'WindowSwitcher'"- , "widget '*WindowSwitcher*title' style 'title'"- ] menu <- Gtk.menuNew Gtk.widgetSetName menu "menu" @@ -106,43 +98,41 @@ Gtk.menuItemSetSubmenu title menu -- These callbacks are run in the GUI thread automatically and do -- not need to use postGUIAsync- _ <- Gtk.on title Gtk.menuItemActivate $ fillMenu menu+ _ <- Gtk.on title Gtk.menuItemActivate $ fillMenu pager menu _ <- Gtk.on title Gtk.menuItemDeselect $ emptyMenu menu Gtk.widgetShowAll switcher return $ Gtk.toWidget switcher -- | Populate the given menu widget with the list of all currently open windows.-fillMenu :: Gtk.MenuClass menu => menu -> IO ()-fillMenu menu = withDefaultCtx $ do- handles <- getWindowHandles- if null handles then return () else do- wsNames <- getWorkspaceNames- forM_ handles $ \handle -> liftIO $ do- item <- Gtk.menuItemNewWithLabel (formatEntry (M.fromList wsNames) handle)- _ <- Gtk.on item Gtk.buttonPressEvent $ liftIO $ do- withDefaultCtx (focusWindow $ snd handle)- return True- Gtk.menuShellAppend menu item- Gtk.widgetShow item+fillMenu :: Gtk.MenuClass menu => Pager -> menu -> IO ()+fillMenu pager menu =+ runWithPager pager $ do+ handles <- getWindowHandles+ if null handles+ then return ()+ else do+ wsNames <- getWorkspaceNames+ forM_ handles $ \handle ->+ liftIO $ do+ let formatEntry = windowSwitcherFormatter $ config pager+ item <-+ Gtk.menuItemNewWithLabel (formatEntry (M.fromList wsNames) handle)+ _ <-+ Gtk.on item Gtk.buttonPressEvent $+ liftIO $ do+ runWithPager pager $ focusWindow $ snd handle+ return True+ Gtk.menuShellAppend menu item+ Gtk.widgetShow item -- | Remove all contents from the given menu widget. emptyMenu :: Gtk.MenuClass menu => menu -> IO () emptyMenu menu = Gtk.containerForeach menu $ \item -> Gtk.containerRemove menu item >> Gtk.widgetDestroy item --- | Build the name to display in the list of windows by prepending the name--- of the workspace it is currently in to the name of the window itself-formatEntry :: M.Map WorkspaceIdx String -- ^ List of names of all available workspaces- -> X11WindowHandle -- ^ Handle of the window to name- -> String-formatEntry wsNames ((ws, wtitle, _), _) = wsName ++ ": " ++ (nonEmpty wtitle)- where- wsName = M.findWithDefault ("WS#"++show wsN) ws wsNames- WSIdx wsN = ws---- | Return the given String if it's not empty, otherwise return "(nameless window)" nonEmpty :: String -> String-nonEmpty x = case x of- [] -> "(nameless window)"- _ -> x+nonEmpty x =+ case x of+ [] -> "(nameless window)"+ _ -> x
+ src/System/Taffybar/WorkspaceHUD.hs view
@@ -0,0 +1,1000 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.WorkspaceHUD+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------++module System.Taffybar.WorkspaceHUD (+ Context(..),+ ControllerConstructor,+ HUDIO,+ IconInfo(..),+ WWC(..),+ WindowData(..),+ Workspace(..),+ WorkspaceButtonController(..),+ WorkspaceContentsController(..),+ WorkspaceHUDConfig(..),+ WorkspaceState(..),+ WorkspaceUnderlineController(..),+ WorkspaceWidgetController(..),+ IconController(..),+ buildBorderButtonController,+ buildButtonController,+ buildContentsController,+ buildIconController,+ buildLabelController,+ buildPadBox,+ buildUnderlineButtonController,+ buildUnderlineController,+ buildWorkspaceHUD,+ buildWorkspaces,+ defaultBuildContentsController,+ defaultGetIconInfo,+ defaultWorkspaceHUDConfig,+ getWorkspaceToWindows,+ hideEmpty,+ hudFromPagerConfig,+ liftPager,+ liftX11Def,+ setImage,+ widgetSetClass,+ windowTitleClassIconGetter,+) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Concurrent+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.RateLimit+import qualified Data.Foldable as F+import Data.List (intersect, sortBy)+import qualified Data.Map as M+import Data.Maybe+import qualified Data.MultiMap as MM+import qualified Data.Set as Set+import Data.Time.Units+import Data.Tuple.Select+import Data.Tuple.Sequence+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 Graphics.X11.Xlib.Extras+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32, xSetErrorHandler)+import Prelude+import System.Information.EWMHDesktopInfo+import System.Information.SafeX11+import System.Information.X11DesktopInfo+import System.Taffybar.IconImages+import System.Taffybar.Pager+import Text.Printf++data WorkspaceState+ = Active+ | Visible+ | Hidden+ | Empty+ | Urgent+ deriving (Show, Eq)++workspaceStates :: [String]+workspaceStates = map show [Active, Visible, Hidden, Empty, Urgent]++data IconInfo+ = IIEWMH EWMHIcon+ | IIFilePath FilePath+ | IIColor ColorRGBA+ | IINone+ deriving (Eq, Show)++transparentInfo :: IconInfo+transparentInfo = IIColor (0, 0, 0, 0)++data WindowData = WindowData+ { windowId :: X11Window+ , windowTitle :: String+ , windowClass :: String+ , windowUrgent :: Bool+ , windowActive :: Bool+ , windowMinimized :: Bool+ } deriving (Show, Eq)++data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]++data Workspace = Workspace+ { workspaceIdx :: WorkspaceIdx+ , workspaceName :: String+ , workspaceState :: WorkspaceState+ , windows :: [WindowData]+ } deriving (Show, Eq)++data Context = Context+ { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)+ , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)+ , loggingVar :: MV.MVar Bool+ , hudWidget :: Gtk.HBox+ , hudConfig :: WorkspaceHUDConfig+ , hudPager :: Pager+ }++type HUDIO a = ReaderT Context IO a++liftPager :: PagerIO a -> HUDIO a+liftPager action = asks hudPager >>= lift . runReaderT action++liftX11Def :: a -> X11Property a -> HUDIO a+liftX11Def = (liftPager .) . liftPagerX11Def++widgetSetClass+ :: W.WidgetClass widget+ => widget -> String -> IO ()+widgetSetClass widget klass = do+ context <- Gtk.widgetGetStyleContext widget+ styleContextAddClass context klass++setWorkspaceWidgetStatusClass+ :: W.WidgetClass widget+ => Workspace -> widget -> IO ()+setWorkspaceWidgetStatusClass workspace widget =+ updateWidgetClasses widget [show $ workspaceState workspace] workspaceStates++updateWidgetClasses+ :: W.WidgetClass widget+ => widget -> [String] -> [String] -> IO ()+updateWidgetClasses widget toAdd toRemove = do+ context <- Gtk.widgetGetStyleContext widget+ let hasClass = styleContextHasClass context+ addIfMissing klass =+ hasClass klass >>= (`when` (styleContextAddClass context klass)) . not+ removeIfPresent klass = when (not $ elem klass toAdd) $+ hasClass klass >>= (`when` (styleContextRemoveClass context klass))+ mapM_ removeIfPresent toRemove+ mapM_ addIfMissing toAdd++class WorkspaceWidgetController wc where+ getWidget :: wc -> Gtk.Widget+ updateWidget :: wc -> WidgetUpdate -> HUDIO wc+ updateWidgetX11 :: wc -> WidgetUpdate -> HUDIO wc+ updateWidgetX11 cont _ = return cont++data WWC = forall a. WorkspaceWidgetController a => WWC a++instance WorkspaceWidgetController WWC where+ getWidget (WWC wc) = getWidget wc+ updateWidget (WWC wc) update = WWC <$> updateWidget wc update+ updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update++type ControllerConstructor = Workspace -> HUDIO WWC+type ParentControllerConstructor =+ ControllerConstructor -> ControllerConstructor++data WorkspaceHUDConfig =+ WorkspaceHUDConfig+ { widgetBuilder :: ControllerConstructor+ , widgetGap :: Int+ , windowIconSize :: Int+ , underlineHeight :: Int+ , minWSWidgetSize :: Maybe Int+ , underlinePadding :: Int+ , maxIcons :: Maybe Int+ , minIcons :: Int+ , getIconInfo :: WindowData -> HUDIO IconInfo+ , labelSetter :: Workspace -> HUDIO String+ , updateOnWMIconChange :: Bool+ , showWorkspaceFn :: Workspace -> Bool+ , borderWidth :: Int+ , updateEvents :: [String]+ , updateRateLimitMicroseconds :: Integer+ , debugMode :: Bool+ , iconSort :: [WindowData] -> HUDIO [WindowData]+ , urgentWorkspaceState :: Bool+ }++hudFromPagerConfig :: PagerConfig -> WorkspaceHUDConfig+hudFromPagerConfig pagerConfig =+ let updater workspace+ | any windowUrgent ws = urgentWorkspace pagerConfig name+ | otherwise =+ let getter =+ case state of+ Urgent -> urgentWorkspace+ Visible -> visibleWorkspace+ Active -> activeWorkspace+ Hidden -> hiddenWorkspace+ Empty -> emptyWorkspace+ in getter pagerConfig name+ where+ ws = windows workspace+ name = workspaceName workspace+ state = workspaceState workspace+ padded =+ if workspacePad pagerConfig+ then prefixSpace . updater+ else updater+ getCustomImage hasIcon wt wc =+ case customIcon pagerConfig hasIcon wt wc of+ Just fp -> IIFilePath fp+ Nothing -> IINone+ in defaultWorkspaceHUDConfig+ { labelSetter = return . padded+ , minIcons =+ if fillEmptyImages pagerConfig+ then 1+ else 0+ , maxIcons =+ Just $+ if useImages pagerConfig+ then 1+ else 0+ , getIconInfo =+ windowTitleClassIconGetter+ getCustomImage+ , widgetGap = workspaceGap pagerConfig+ , windowIconSize = imageSize pagerConfig+ , widgetBuilder =+ if workspaceBorder pagerConfig+ then buildBorderButtonController+ else buildButtonController defaultBuildContentsController+ , minWSWidgetSize = Nothing+ , iconSort = return+ }+ where+ prefixSpace "" = ""+ prefixSpace s = " " ++ s++windowTitleClassIconGetter+ :: (Bool -> String -> String -> IconInfo)+ -> (WindowData -> HUDIO 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++defaultWorkspaceHUDConfig :: WorkspaceHUDConfig+defaultWorkspaceHUDConfig =+ WorkspaceHUDConfig+ { widgetBuilder = buildButtonController defaultBuildContentsController+ , widgetGap = 0+ , windowIconSize = 16+ , underlineHeight = 4+ , minWSWidgetSize = Just 30+ , underlinePadding = 1+ , maxIcons = Nothing+ , minIcons = 0+ , getIconInfo = defaultGetIconInfo+ , labelSetter = return . workspaceName+ , updateOnWMIconChange = True+ , showWorkspaceFn = const True+ , borderWidth = 2+ , iconSort = sortWindowsByPosition+ , updateEvents =+ [ "WM_HINTS"+ , "_NET_CURRENT_DESKTOP"+ , "_NET_DESKTOP_NAMES"+ , "_NET_NUMBER_OF_DESKTOPS"+ , "_NET_WM_DESKTOP"+ , "_NET_WM_STATE_HIDDEN"+ ]+ , updateRateLimitMicroseconds = 100000+ , debugMode = False+ , urgentWorkspaceState = False+ }++hideEmpty :: Workspace -> Bool+hideEmpty Workspace { workspaceState = Empty } = False+hideEmpty _ = True++hudLogger :: Context -> String -> IO ()+hudLogger ctx txt =+ do+ shouldLog <- MV.readMVar $ loggingVar ctx+ when shouldLog $ putStrLn txt++hudLog :: String -> HUDIO ()+hudLog txt = ask >>= lift . flip hudLogger (printf "[WorkspaceHUD] %s" txt)++updateVar :: MV.MVar a -> (a -> HUDIO a) -> HUDIO a+updateVar var modify = do+ ctx <- ask+ lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify++updateWorkspacesVar :: HUDIO (M.Map WorkspaceIdx Workspace)+updateWorkspacesVar = do+ workspacesRef <- asks workspacesVar+ updateVar workspacesRef buildWorkspaces++getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window)+getWorkspaceToWindows =+ foldM+ (\theMap window ->+ MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)+ MM.empty++getWindowData :: [X11Window]+ -> [X11Window]+ -> X11Window+ -> X11Property WindowData+getWindowData activeWindows urgentWindows window = do+ wTitle <- getWindowTitle window+ wClass <- getWindowClass window+ wMinimized <- getWindowStateProperty window "_NET_WM_STATE_HIDDEN"+ return+ WindowData+ { windowId = window+ , windowTitle = wTitle+ , windowClass = wClass+ , windowUrgent = window `elem` urgentWindows+ , windowActive = window `elem` activeWindows+ , windowMinimized = wMinimized+ }++buildWorkspaces :: M.Map WorkspaceIdx Workspace+ -> HUDIO (M.Map WorkspaceIdx Workspace)+buildWorkspaces _ = ask >>= \context -> liftX11Def M.empty $ do+ names <- getWorkspaceNames+ wins <- getWindows+ workspaceToWindows <- getWorkspaceToWindows wins+ urgentWindows <- filterM isWindowUrgent wins+ activeWindows <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"+ active:visible <- getVisibleWorkspaces+ let getWorkspaceState idx ws+ | idx == active = Active+ | idx `elem` visible = Visible+ | urgentWorkspaceState (hudConfig context) &&+ not (null (ws `intersect` urgentWindows)) =+ Urgent+ | null ws = Empty+ | otherwise = Hidden+ foldM+ (\theMap (idx, name) -> do+ let ws = MM.lookup idx workspaceToWindows+ windowInfos <- mapM (getWindowData activeWindows urgentWindows) ws+ return $+ M.insert+ idx+ Workspace+ { workspaceIdx = idx+ , workspaceName = name+ , workspaceState = getWorkspaceState idx ws+ , windows = windowInfos+ }+ theMap)+ M.empty+ names++addWidgetsToTopLevel :: HUDIO ()+addWidgetsToTopLevel = do+ Context { controllersVar = controllersRef+ , hudWidget = cont+ , hudConfig = cfg+ } <- ask+ controllersMap <- lift $ MV.readMVar controllersRef+ -- Elems returns elements in ascending order of their keys so this will always+ -- add the widgets in the correct order+ mapM_ addWidget $ M.elems controllersMap+ when (debugMode cfg) addDebugWidgets+ lift $ Gtk.widgetShowAll cont++addWidget :: WWC -> HUDIO ()+addWidget controller = do+ cont <- asks hudWidget+ let workspaceWidget = getWidget controller+ lift $ do+ -- XXX: This hbox exists to (hopefully) prevent the issue where workspace+ -- widgets appear out of order, in the switcher, by acting as an empty+ -- place holder when the actual widget is hidden.+ hbox <- Gtk.hBoxNew False 0+ parent <- Gtk.widgetGetParent workspaceWidget+ if isJust parent+ then Gtk.widgetReparent (getWidget controller) hbox+ else Gtk.containerAdd hbox workspaceWidget+ Gtk.containerAdd cont hbox++addDebugWidgets :: HUDIO ()+addDebugWidgets = do+ ctx <- ask+ cont <- asks hudWidget+ loggingRef <- asks loggingVar+ let getLabelText state = printf "ToggleLogging: %s" $ show state :: String+ lift $ do+ enableLoggingBox <- Gtk.eventBoxNew+ rebuildBarBox <- Gtk.eventBoxNew+ Gtk.widgetSetName enableLoggingBox "WorkspaceHUD-toggleLogging"+ Gtk.widgetSetName rebuildBarBox "WorkspaceHUD-rebuildButton"+ loggingEnabled <- MV.readMVar loggingRef+ logLabel <- Gtk.labelNew $ Just $ getLabelText loggingEnabled+ rebuildLabel <- Gtk.labelNew $ Just "Rebuild Bar"+ Gtk.widgetSetName logLabel "WorkspaceHUD-toggleLogging"+ Gtk.widgetSetName rebuildLabel "WorkspaceHUD-rebuildButton"+ let toggleLogging =+ MV.modifyMVar_+ loggingRef+ (\current -> do+ let newState = not current+ labelText = getLabelText newState+ Gtk.labelSetMarkup logLabel labelText+ return $ not current) >>+ return True+ -- Clear the container and repopulate it+ rebuildBar+ = do+ Gtk.containerForeach cont (Gtk.containerRemove cont)+ runReaderT (addWidgetsToTopLevel >> updateAllWorkspaceWidgets) ctx+ return True+ Gtk.containerAdd enableLoggingBox logLabel+ Gtk.containerAdd rebuildBarBox rebuildLabel+ _ <- Gtk.on enableLoggingBox Gtk.buttonPressEvent (liftIO toggleLogging)+ _ <- Gtk.on rebuildBarBox Gtk.buttonPressEvent (liftIO rebuildBar)+ Gtk.containerAdd cont enableLoggingBox+ Gtk.containerAdd cont rebuildBarBox+ return ()++buildWorkspaceHUD :: WorkspaceHUDConfig -> Pager -> IO Gtk.Widget+buildWorkspaceHUD cfg pager = do+ cont <- Gtk.hBoxNew False (widgetGap cfg)+ controllersRef <- MV.newMVar M.empty+ workspacesRef <- MV.newMVar M.empty+ loggingRef <- MV.newMVar False+ let context =+ Context+ { controllersVar = controllersRef+ , workspacesVar = workspacesRef+ , loggingVar = loggingRef+ , hudWidget = cont+ , hudConfig = cfg+ , hudPager = pager+ }+ -- This will actually create all the widgets+ runReaderT updateAllWorkspaceWidgets context+ updateHandler <- onWorkspaceUpdate context+ mapM_ (subscribe pager updateHandler) $ updateEvents cfg+ iconHandler <- onIconsChanged context+ when (updateOnWMIconChange cfg) $+ subscribe pager (onIconChanged context iconHandler) "_NET_WM_ICON"+ return $ Gtk.toWidget cont++updateAllWorkspaceWidgets :: HUDIO ()+updateAllWorkspaceWidgets = do+ hudLog "-Workspace- -Execute-..."++ workspacesMap <- updateWorkspacesVar+ hudLog $ printf "Workspaces: %s" $ show workspacesMap++ hudLog "-Workspace- Adding and removing widgets..."+ updateWorkspaceControllers++ let updateController' idx controller =+ maybe (return controller)+ (updateWidget controller . WorkspaceUpdate) $+ M.lookup idx workspacesMap+ logUpdateController i =+ hudLog $ printf "-Workspace- -each- Updating %s widget" $ show i+ updateController i cont = logUpdateController i >>+ updateController' i cont++ doWidgetUpdate updateController++ hudLog "-Workspace- Showing and hiding controllers..."+ setControllerWidgetVisibility++setControllerWidgetVisibility :: HUDIO ()+setControllerWidgetVisibility = do+ Context { workspacesVar = workspacesRef+ , controllersVar = controllersRef+ , hudConfig = cfg+ } <- ask+ lift $ do+ workspacesMap <- MV.readMVar workspacesRef+ controllersMap <- MV.readMVar controllersRef+ forM_ (M.elems workspacesMap) $ \ws ->+ let c = M.lookup (workspaceIdx ws) controllersMap+ mWidget = getWidget <$> c+ action = if showWorkspaceFn cfg ws+ then Gtk.widgetShow+ else Gtk.widgetHide+ in+ maybe (return ()) action mWidget++doWidgetUpdate :: (WorkspaceIdx -> WWC -> HUDIO WWC) -> HUDIO ()+doWidgetUpdate updateController = do+ c@Context { controllersVar = controllersRef } <- ask+ lift $ MV.modifyMVar_ controllersRef $ \controllers -> do+ controllersList <-+ mapM+ (\(idx, controller) -> do+ newController <- runReaderT (updateController idx controller) c+ return (idx, newController)) $+ M.toList controllers+ return $ M.fromList controllersList++updateWorkspaceControllers :: HUDIO ()+updateWorkspaceControllers = do+ Context { controllersVar = controllersRef+ , workspacesVar = workspacesRef+ , hudWidget = cont+ , hudConfig = cfg+ } <- ask+ workspacesMap <- lift $ MV.readMVar workspacesRef+ controllersMap <- lift $ MV.readMVar controllersRef++ let newWorkspacesSet = M.keysSet workspacesMap+ existingWorkspacesSet = M.keysSet controllersMap++ when (existingWorkspacesSet /= newWorkspacesSet) $ do+ let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet+ removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet+ builder = widgetBuilder cfg++ _ <- updateVar controllersRef $ \controllers -> do+ let oldRemoved = F.foldl (flip M.delete) controllers removeWorkspaces+ buildController idx = builder <$> M.lookup idx workspacesMap+ buildAndAddController theMap idx =+ maybe (return theMap) (>>= return . flip (M.insert idx) theMap)+ (buildController idx)+ foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces++ -- Clear the container and repopulate it+ lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)+ addWidgetsToTopLevel++rateLimitFn+ :: forall req resp.+ Context+ -> (req -> IO resp)+ -> ResultsCombiner req resp+ -> IO (req -> IO resp)+rateLimitFn context =+ let limit = (updateRateLimitMicroseconds $ hudConfig context)+ rate = fromMicroseconds limit :: Microsecond in+ generateRateLimitedFunction $ PerInvocation rate++onWorkspaceUpdate :: Context -> IO (Event -> IO ())+onWorkspaceUpdate context = do+ rateLimited <- rateLimitFn context doUpdate combineRequests+ let withLog event = do+ case event of+ PropertyEvent _ _ _ _ _ atom _ _ ->+ hudLogger context $ printf "-Event- -Workspace- %s" $ show atom+ _ -> hudLogger context "-Event- -Workspace-"+ void $ forkIO $ rateLimited event+ return withLog+ where+ combineRequests _ b = Just (b, const ((), ()))+ doUpdate _ = Gtk.postGUIAsync $ runReaderT updateAllWorkspaceWidgets context++onIconChanged :: Context -> (Set.Set X11Window -> IO ()) -> Event -> IO ()+onIconChanged context handler event = do+ let logger = hudLogger context+ case event of+ PropertyEvent { ev_window = wid } -> do+ logger $ printf "-Icon- -Event- %s" $ show wid+ handler $ Set.singleton wid+ _ -> return ()++onIconsChanged :: Context -> IO (Set.Set X11Window -> IO ())+onIconsChanged context =+ (.) (void . forkIO) <$> rateLimitFn context onIconsChanged' combineRequests+ where+ combineRequests windows1 windows2 =+ Just (Set.union windows1 windows2, const ((), ()))+ onIconsChanged' wids = do+ hudLogger context $ printf "-Icon- -Execute- %s" $ show wids+ flip runReaderT context $+ doWidgetUpdate+ (\idx c ->+ hudLog (printf "-Icon- -each- Updating %s icons." $ show idx) >>+ updateWidget c (IconUpdate $ Set.toList wids))++data WorkspaceContentsController = WorkspaceContentsController+ { containerWidget :: Gtk.Widget+ , contentsControllers :: [WWC]+ }++buildContentsController :: [ControllerConstructor] -> ControllerConstructor+buildContentsController constructors ws = do+ controllers <- mapM ($ ws) constructors+ tempController <- lift $ do+ cons <- Gtk.hBoxNew False 0+ mapM_ (Gtk.containerAdd cons . getWidget) controllers+ outerBox <- buildPadBox cons+ widgetSetClass cons "Contents"+ return+ WorkspaceContentsController+ { containerWidget = Gtk.toWidget outerBox+ , contentsControllers = controllers+ }+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++buildPadBox :: W.WidgetClass widget => widget -> IO Gtk.EventBox+buildPadBox cons = do+ innerBox <- Gtk.hBoxNew False 0+ outerBox <- Gtk.eventBoxNew+ Gtk.containerAdd innerBox cons+ Gtk.containerAdd outerBox innerBox+ widgetSetClass innerBox "InnerPad"+ widgetSetClass outerBox "OuterPad"+ return outerBox++defaultBuildContentsController :: ControllerConstructor+defaultBuildContentsController =+ buildContentsController [buildLabelController, buildIconController]++instance WorkspaceWidgetController WorkspaceContentsController where+ getWidget = containerWidget+ updateWidget cc update = do+ Context {hudConfig = cfg} <- ask+ lift $+ maybe (return ()) (updateMinSize $ Gtk.toWidget $ containerWidget cc) $+ minWSWidgetSize cfg+ case update of+ WorkspaceUpdate newWorkspace ->+ lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc+ _ -> return ()+ newControllers <- mapM (`updateWidget` update) $ contentsControllers cc+ return cc {contentsControllers = newControllers}+ updateWidgetX11 cc update = do+ newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc+ return cc {contentsControllers = newControllers}++data LabelController = LabelController { label :: Gtk.Label }++buildLabelController :: ControllerConstructor+buildLabelController ws = do+ tempController <- lift $ do+ lbl <- Gtk.labelNew (Nothing :: Maybe String)+ widgetSetClass lbl "WorkspaceLabel"+ return LabelController { label = lbl }+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++instance WorkspaceWidgetController LabelController where+ getWidget = Gtk.toWidget . label+ updateWidget lc (WorkspaceUpdate newWorkspace) = do+ Context { hudConfig = cfg } <- ask+ labelText <- labelSetter cfg newWorkspace+ lift $ do+ Gtk.labelSetMarkup (label lc) labelText+ setWorkspaceWidgetStatusClass newWorkspace $ label lc+ return lc+ updateWidget lc _ = return lc++data IconWidget = IconWidget+ { iconContainer :: Gtk.EventBox+ , iconImage :: Gtk.Image+ , iconWindow :: MV.MVar (Maybe WindowData)+ }++data IconController = IconController+ { iconsContainer :: Gtk.HBox+ , iconImages :: [IconWidget]+ , iconWorkspace :: Workspace+ }++buildIconController :: ControllerConstructor+buildIconController ws = do+ tempController <-+ lift $ do+ hbox <- Gtk.hBoxNew False 0+ return+ IconController+ {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++instance WorkspaceWidgetController IconController where+ getWidget = Gtk.toWidget . iconsContainer+ updateWidget ic (WorkspaceUpdate newWorkspace) = do+ newImages <- updateImages ic newWorkspace+ return ic { iconImages = newImages, iconWorkspace = newWorkspace }+ updateWidget ic (IconUpdate updatedIcons) =+ updateWindowIconsById ic updatedIcons >> return ic++updateWindowIconsById :: IconController+ -> [X11Window]+ -> HUDIO ()+updateWindowIconsById ic windowIds =+ mapM_ maybeUpdateWindowIcon $ iconImages ic+ where+ maybeUpdateWindowIcon widget =+ do+ info <- lift $ MV.readMVar $ iconWindow widget+ when (maybe False (flip elem windowIds . windowId) info) $+ updateIconWidget ic widget info False++updateMinSize :: Gtk.Widget -> Int -> IO ()+updateMinSize widget minWidth = do+ W.widgetSetSizeRequest widget (-1) (-1)+ W.Requisition w _ <- W.widgetSizeRequest widget+ when (w < minWidth) $ W.widgetSetSizeRequest widget minWidth $ -1++defaultGetIconInfo :: WindowData -> HUDIO IconInfo+defaultGetIconInfo w = do+ icons <- liftX11Def [] $ postX11RequestSyncProp (getWindowIcons $ windowId w) []+ iconSize <- asks $ windowIconSize . hudConfig+ return $+ if null icons+ then IINone+ else IIEWMH $ selectEWMHIcon iconSize icons++forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b)+forkM a b = sequenceT . (a &&& b)++sortWindowsByPosition :: [WindowData] -> HUDIO [WindowData]+sortWindowsByPosition wins = do+ let getGeometryHUD w = getDisplay >>= liftIO . (`safeGetGeometry` w)+ getGeometries = mapM+ (forkM return ((((sel2 &&& sel3) <$>) .) getGeometryHUD) . windowId)+ wins+ windowGeometries <- liftX11Def [] getGeometries+ let getLeftPos wd =+ fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries+ compareWindowData a b =+ compare+ (windowMinimized a, getLeftPos a)+ (windowMinimized b, getLeftPos b)+ return $ sortBy compareWindowData wins++updateImages :: IconController -> Workspace -> HUDIO [IconWidget]+updateImages ic ws = do+ Context {hudConfig = cfg} <- ask+ sortedWindows <- iconSort cfg $ windows ws+ let updateIconWidget' getImage wdata ton = do+ iconWidget <- getImage+ _ <- updateIconWidget ic iconWidget wdata ton+ return iconWidget+ existingImages = map return $ iconImages ic+ buildAndAddIconWidget = do+ iw <- buildIconWidget ws+ lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw+ return iw+ infiniteImages = existingImages ++ repeat buildAndAddIconWidget+ windowCount = length $ windows ws+ maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg+ newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded+ -- XXX: Only one of the two things being zipped can be an infinite list,+ -- which is why this newImagesNeeded contortion is needed.+ imgSrcs =+ if newImagesNeeded+ then infiniteImages+ else existingImages+ getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg+ justWindows = map Just sortedWindows+ windowDatas =+ if newImagesNeeded+ 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+ when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic+ return newImgs++buildIconWidget :: Workspace -> HUDIO 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"++possibleStatusStrings :: [String]+possibleStatusStrings = [show Active, show Urgent, "Minimized", "Normal", "Nodata"]++updateIconWidget+ :: IconController+ -> IconWidget+ -> Maybe WindowData+ -> Bool+ -> HUDIO ()+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++getPixBuf :: Int -> IconInfo -> IO (Maybe Gtk.Pixbuf)+getPixBuf imgSize = gpb+ where+ gpb (IIEWMH icon) = Just <$> pixBufFromEWMHIcon icon+ 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+ , contentsController :: WWC+ }++buildButtonController :: ParentControllerConstructor+buildButtonController contentsBuilder workspace = do+ cc <- contentsBuilder workspace+ workspacesRef <- asks workspacesVar+ ctx <- ask+ lift $ do+ ebox <- Gtk.eventBoxNew+ Gtk.containerAdd ebox $ getWidget cc+ Gtk.eventBoxSetVisibleWindow ebox False+ _ <-+ Gtk.on ebox Gtk.scrollEvent $ do+ workspaces <- liftIO $ MV.readMVar workspacesRef+ let switchOne a =+ liftIO $+ flip runReaderT ctx $+ liftX11Def+ ()+ (switchOneWorkspace a (length (M.toList workspaces) - 1)) >>+ return True+ dir <- Gtk.eventScrollDirection+ case dir of+ Gtk.ScrollUp -> switchOne True+ Gtk.ScrollLeft -> switchOne True+ Gtk.ScrollDown -> switchOne False+ Gtk.ScrollRight -> switchOne False+ Gtk.ScrollSmooth -> return False+ _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch ctx $ workspaceIdx workspace+ return $+ WWC+ WorkspaceButtonController+ {button = ebox, buttonWorkspace = workspace, contentsController = cc}++switch :: (MonadIO m) => Context -> WorkspaceIdx -> m Bool+switch ctx idx = do+ liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx+ return True++instance WorkspaceWidgetController WorkspaceButtonController+ where+ getWidget wbc = Gtk.toWidget $ button wbc+ updateWidget wbc update = do+ newContents <- updateWidget (contentsController wbc) update+ return wbc { contentsController = newContents }++data WorkspaceUnderlineController = WorkspaceUnderlineController+ { table :: T.Table+ -- XXX: An event box is used here because we need to change the background+ , underline :: Gtk.EventBox+ , overlineController :: WWC+ }++buildUnderlineController :: ParentControllerConstructor+buildUnderlineController contentsBuilder workspace = do+ cfg <- asks hudConfig+ cc <- contentsBuilder workspace++ lift $ do+ t <- T.tableNew 2 1 False+ u <- Gtk.eventBoxNew+ W.widgetSetSizeRequest u (-1) $ underlineHeight cfg++ T.tableAttach t (getWidget cc) 0 1 0 1+ [T.Expand, T.Fill] [T.Expand, T.Fill] 0 0+ T.tableAttach t u 0 1 1 2+ [T.Fill] [T.Shrink] (underlinePadding cfg) 0++ widgetSetClass u "Underline"+ return $ WWC WorkspaceUnderlineController+ {table = t, underline = u, overlineController = cc}++instance WorkspaceWidgetController WorkspaceUnderlineController where+ getWidget uc = Gtk.toWidget $ table uc+ updateWidget uc wu@(WorkspaceUpdate workspace) =+ lift (setWorkspaceWidgetStatusClass workspace (underline uc)) >>+ updateUnderline uc wu+ updateWidget a b = updateUnderline a b++updateUnderline :: WorkspaceUnderlineController+ -> WidgetUpdate+ -> HUDIO WorkspaceUnderlineController+updateUnderline uc u = do+ newContents <- updateWidget (overlineController uc) u+ return uc { overlineController = newContents }++data WorkspaceBorderController =+ WorkspaceBorderController { border :: Gtk.EventBox+ , borderContents :: Gtk.EventBox+ , insideController :: WWC+ }++buildBorderController :: ParentControllerConstructor+buildBorderController contentsBuilder workspace = do+ cc <- contentsBuilder workspace+ cfg <- asks hudConfig+ lift $ do+ brd <- Gtk.eventBoxNew+ cnt <- Gtk.eventBoxNew+ Gtk.eventBoxSetVisibleWindow brd True+ Gtk.containerSetBorderWidth cnt $ borderWidth cfg+ Gtk.containerAdd brd cnt+ Gtk.containerAdd cnt $ getWidget cc+ widgetSetClass brd "Border"+ widgetSetClass cnt "Container"+ return $+ WWC+ WorkspaceBorderController+ {border = brd, borderContents = cnt, insideController = cc}++instance WorkspaceWidgetController WorkspaceBorderController where+ getWidget bc = Gtk.toWidget $ border bc+ updateWidget bc wu@(WorkspaceUpdate workspace) =+ let setClasses = setWorkspaceWidgetStatusClass workspace+ in lift (setClasses (border bc) >> setClasses (borderContents bc)) >>+ updateBorder bc wu+ updateWidget a b = updateBorder a b++updateBorder :: WorkspaceBorderController+ -> WidgetUpdate+ -> HUDIO WorkspaceBorderController+updateBorder bc update = do+ newContents <- updateWidget (insideController bc) update+ return bc { insideController = newContents }++buildUnderlineButtonController :: ControllerConstructor+buildUnderlineButtonController =+ buildButtonController (buildUnderlineController defaultBuildContentsController)++buildBorderButtonController :: ControllerConstructor+buildBorderButtonController =+ buildButtonController (buildBorderController defaultBuildContentsController)
src/System/Taffybar/WorkspaceSwitcher.hs view
@@ -20,30 +20,42 @@ -- ----------------------------------------------------------------------------- -module System.Taffybar.WorkspaceSwitcher (+module System.Taffybar.WorkspaceSwitcher+ {-# DEPRECATED "Use WorkspaceHUD instead of WorkspaceSwitcher" #-} ( -- * Usage -- $usage wspaceSwitcherNew-) where+ ) where import Control.Applicative import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.List ((\\), findIndices)+import Data.List ((\\), findIndices, sortBy)+import Data.Maybe (listToMaybe)+import Data.Ord (comparing) import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras import Prelude +import System.Taffybar.IconImages hiding (selectEWMHIcon) import System.Taffybar.Pager import System.Information.EWMHDesktopInfo type Desktop = [Workspace]-data Workspace = Workspace { label :: Gtk.Label- , name :: String- , urgent :: Bool+data Workspace = Workspace { label :: Gtk.Label+ , image :: Gtk.Image+ , border :: Gtk.EventBox+ , container :: Gtk.EventBox+ , name :: String+ , urgent :: Bool }+type WindowSet = [(WorkspaceIdx, [X11Window])]+type WindowInfo = Maybe (String, String, [EWMHIcon])+type CustomIconF = Bool -> String -> String -> Maybe FilePath+type ImageChoice = (Maybe EWMHIcon, Maybe FilePath, Maybe ColorRGBA)+ -- $usage -- -- This widget requires that the EwmhDesktops hook from the XMonadContrib@@ -82,7 +94,7 @@ -- its source of events. wspaceSwitcherNew :: Pager -> IO Gtk.Widget wspaceSwitcherNew pager = do- switcher <- Gtk.hBoxNew False 0+ switcher <- Gtk.hBoxNew False (workspaceGap (config pager)) desktop <- getDesktop pager deskRef <- MV.newMVar desktop populateSwitcher switcher deskRef@@ -94,6 +106,7 @@ redrawcb = redrawCallback pager deskRef switcher urgentcb = urgentCallback cfg deskRef subscribe pager activecb "_NET_CURRENT_DESKTOP"+ subscribe pager activecb "_NET_WM_DESKTOP" subscribe pager redrawcb "_NET_DESKTOP_NAMES" subscribe pager redrawcb "_NET_NUMBER_OF_DESKTOPS" subscribe pager urgentcb "WM_HINTS"@@ -108,15 +121,27 @@ nonEmptyWorkspaces :: IO [WorkspaceIdx] nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows --- | Return a list of two-element tuples, one for every workspace,--- containing the Label widget used to display the name of that specific--- workspace and a String with its default (unmarked) representation.+-- | Return a list of Workspace data instances. getDesktop :: Pager -> IO Desktop getDesktop pager = do names <- map snd <$> withDefaultCtx getWorkspaceNames- labels <- toLabels $ map (hiddenWorkspace $ config pager) names- return $ zipWith (\n l -> Workspace l n False) names labels+ mapM (createWorkspace pager) names +-- | Return a Workspace data instance, with the unmarked name,+-- label widget, and image widget.+createWorkspace :: Pager -> String -> IO Workspace+createWorkspace _pager wname = do+ lbl <- createLabel wname+ img <- Gtk.imageNew+ brd <- Gtk.eventBoxNew+ con <- Gtk.eventBoxNew++ let useBorder = workspaceBorder (config _pager)+ Gtk.eventBoxSetVisibleWindow brd useBorder+ Gtk.containerSetBorderWidth con (if useBorder then 2 else 0)++ return $ Workspace lbl img brd con wname False+ -- | Take an existing Desktop IORef and update it if necessary, store the result -- in the IORef, then return True if the reference was actually updated, False -- otherwise.@@ -124,7 +149,7 @@ updateDesktop pager deskRef = do wsnames <- withDefaultCtx getWorkspaceNames MV.modifyMVar deskRef $ \desktop ->- case length wsnames /= length desktop of+ case map snd wsnames /= map name desktop of True -> do desk' <- getDesktop pager return (desk', True)@@ -161,13 +186,14 @@ desktop <- MV.readMVar deskRef withDefaultCtx $ do let window = ev_window event+ pad = if workspacePad cfg then prefixSpace else id isUrgent <- isWindowUrgent window when isUrgent $ do this <- getCurrentWorkspace that <- getWorkspace window when (this /= that) $ liftIO $ do toggleUrgent deskRef that True- mark desktop (urgentWorkspace cfg) that+ mark desktop pad (urgentWorkspace cfg) that -- | Build a suitable callback function that can be registered as Listener -- of "_NET_NUMBER_OF_DESKTOPS" standard events. It will handle dynamically@@ -181,15 +207,14 @@ -- | Remove all children of a container. containerClear :: Gtk.ContainerClass self => self -> IO ()-containerClear container = Gtk.containerForeach container (Gtk.containerRemove container)+containerClear c = Gtk.containerForeach c (Gtk.containerRemove c) --- | Convert the given list of Strings to a list of Label widgets.-toLabels :: [String] -> IO [Gtk.Label]-toLabels = mapM labelNewMarkup- where labelNewMarkup markup = do- lbl <- Gtk.labelNew (Nothing :: Maybe String)- Gtk.labelSetMarkup lbl markup- return lbl+-- | Create a label widget from the given String.+createLabel :: String -> IO Gtk.Label+createLabel markup = do+ lbl <- Gtk.labelNew (Nothing :: Maybe String)+ Gtk.labelSetMarkup lbl markup+ return lbl -- | Get the workspace corresponding to the given 'WorkspaceIdx' on the given desktop getWS :: Desktop -> WorkspaceIdx -> Maybe Workspace@@ -204,22 +229,35 @@ -> Desktop -- ^ List of all workspace Labels available. -> WorkspaceIdx -- ^ Index of the workspace to use. -> IO ()-addButton hbox desktop idx+addButton switcherHbox desktop idx | Just ws <- getWS desktop idx = do let lbl = label ws- ebox <- Gtk.eventBoxNew- Gtk.widgetSetName ebox $ name ws- Gtk.eventBoxSetVisibleWindow ebox False- _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch idx- _ <- Gtk.on ebox Gtk.scrollEvent $ do+ let img = image ws+ let brd = border ws+ let con = container ws+ btnParentEbox <- Gtk.eventBoxNew+ iconLabelBox <- Gtk.hBoxNew False 0++ Gtk.boxPackStart switcherHbox btnParentEbox Gtk.PackNatural 0+ Gtk.containerAdd btnParentEbox brd+ Gtk.containerAdd brd con+ Gtk.containerAdd con iconLabelBox+ Gtk.containerAdd iconLabelBox lbl+ Gtk.containerAdd iconLabelBox img++ Gtk.widgetSetName btnParentEbox $ name ws+ Gtk.eventBoxSetVisibleWindow btnParentEbox False+ _ <- Gtk.on btnParentEbox Gtk.buttonPressEvent $ switch idx+ _ <- Gtk.on btnParentEbox Gtk.scrollEvent $ do dir <- Gtk.eventScrollDirection case dir of Gtk.ScrollUp -> switchOne True (length desktop - 1) Gtk.ScrollLeft -> switchOne True (length desktop - 1) Gtk.ScrollDown -> switchOne False (length desktop - 1) Gtk.ScrollRight -> switchOne False (length desktop - 1)- Gtk.containerAdd ebox lbl- Gtk.boxPackStart hbox ebox Gtk.PackNatural 0+ Gtk.ScrollSmooth -> return False+ return ()+ | otherwise = return () -- | Re-mark all workspace labels.@@ -232,29 +270,157 @@ let urgentWs = map WSIdx $ findIndices urgent desktop allWs = (allWorkspaces desktop) \\ urgentWs nonEmptyWs = nonEmpty \\ urgentWs- mapM_ (mark desktop $ hiddenWorkspace cfg) nonEmptyWs- mapM_ (mark desktop $ emptyWorkspace cfg) (allWs \\ nonEmpty)+ pad = if workspacePad cfg then prefixSpace else id+ mapM_ (mark desktop pad $ hiddenWorkspace cfg) nonEmptyWs+ mapM_ (setWidgetNames desktop "hidden") nonEmptyWs+ mapM_ (mark desktop pad $ emptyWorkspace cfg) (allWs \\ nonEmpty)+ mapM_ (setWidgetNames desktop "empty") (allWs \\ nonEmpty) case wss of active:rest -> do- mark desktop (activeWorkspace cfg) active- mapM_ (mark desktop $ visibleWorkspace cfg) rest+ mark desktop pad (activeWorkspace cfg) active+ setWidgetNames desktop "active" active+ mapM_ (mark desktop pad $ visibleWorkspace cfg) rest+ mapM_ (setWidgetNames desktop "visible") rest _ -> return ()- mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs+ mapM_ (mark desktop pad $ urgentWorkspace cfg) urgentWs+ mapM_ (setWidgetNames desktop "urgent") urgentWs + let useImg = useImages cfg+ fillEmpty = fillEmptyImages cfg+ imgSize = imageSize cfg+ customIconF = customIcon cfg+ when useImg $ updateImages desktop imgSize fillEmpty customIconF++-- | Update the GTK images using X properties.+updateImages :: Desktop -> Int -> Bool -> CustomIconF -> IO ()+updateImages desktop imgSize fillEmpty customIconF = do+ windowSet <- getWindowSet (allWorkspaces desktop)+ lastWinInfo <- getLastWindowInfo windowSet+ let images = map image desktop+ fillColor = if fillEmpty then Just (0, 0, 0, 0) else Nothing+ imageChoices = getImageChoices lastWinInfo customIconF fillColor imgSize+ zipWithM_ (setImage imgSize) images imageChoices++-- | Get EWMHIcons, custom icon files, and fill colors based on the window info.+getImageChoices :: [WindowInfo] -> CustomIconF -> Maybe ColorRGBA -> Int -> [ImageChoice]+getImageChoices lastWinInfo customIconF fillColor imgSize = zip3 icons files colors+ where icons = map (selectEWMHIcon imgSize) lastWinInfo+ files = map (selectCustomIconFile customIconF) lastWinInfo+ colors = map (\_ -> fillColor) lastWinInfo++-- | Select the icon with the smallest height that is larger than imgSize,+-- or if none such icons exist, select the icon with the largest height.+selectEWMHIcon :: Int -> WindowInfo -> Maybe EWMHIcon+selectEWMHIcon imgSize (Just (_, _, icons)) = listToMaybe prefIcon+ where sortedIcons = sortOn height icons+ smallestLargerIcon = take 1 $ dropWhile ((<=imgSize).height) sortedIcons+ largestIcon = take 1 $ reverse sortedIcons+ prefIcon = smallestLargerIcon ++ largestIcon+ sortOn f = sortBy (comparing f)+selectEWMHIcon _ _ = Nothing++-- | Select a file using customIcon config.+selectCustomIconFile :: CustomIconF -> WindowInfo -> Maybe FilePath+selectCustomIconFile customIconF (Just (wTitle, wClass, icons)) = customIconF (length icons > 0) wTitle wClass+selectCustomIconFile _ _ = Nothing++-- | Sets an image based on the image choice (EWMHIcon, custom file, and fill color).+setImage :: Int -> Gtk.Image -> ImageChoice -> IO ()+setImage imgSize img imgChoice = setImgAct imgChoice+ where setImgAct (_, Just file, _) = setImageFromFile img imgSize file+ setImgAct (Just icon, _, _) = setImageFromEWMHIcon img imgSize icon+ setImgAct (_, _, Just color) = setImageFromColor img imgSize color+ setImgAct _ = Gtk.imageClear img++-- | Create a pixbuf from the pixel data in an EWMHIcon,+-- scale it square, and set it in a GTK Image.+setImageFromEWMHIcon :: Gtk.Image -> Int -> EWMHIcon -> IO ()+setImageFromEWMHIcon img imgSize icon = do+ pixbuf <- pixBufFromEWMHIcon icon+ scaledPixbuf <- scalePixbuf imgSize pixbuf+ Gtk.imageSetFromPixbuf img scaledPixbuf++-- | Create a pixbuf from a file,+-- scale it square, and set it in a GTK Image.+setImageFromFile :: Gtk.Image -> Int -> FilePath -> IO ()+setImageFromFile img imgSize file = do+ pixbuf <- Gtk.pixbufNewFromFileAtScale file imgSize imgSize False+ scaledPixbuf <- scalePixbuf imgSize pixbuf+ Gtk.imageSetFromPixbuf img scaledPixbuf++-- | Create a pixbuf with the indicated RGBA color,+-- scale it square, and set it in a GTK Image.+setImageFromColor :: Gtk.Image -> Int -> ColorRGBA -> IO ()+setImageFromColor img imgSize (r,g,b,a) = do+ let sampleBits = 8+ hasAlpha = True+ colorspace = Gtk.ColorspaceRgb+ pixbuf <- Gtk.pixbufNew colorspace hasAlpha sampleBits imgSize imgSize+ Gtk.pixbufFill pixbuf r g b a+ scaledPixbuf <- scalePixbuf imgSize pixbuf+ Gtk.imageSetFromPixbuf img scaledPixbuf++-- | Get window title, class, and icons for the last window in each workspace.+getLastWindowInfo :: WindowSet -> IO [WindowInfo]+getLastWindowInfo windowSet = mapM getWindowInfo lastWins+ where wsIdxs = map fst windowSet+ lastWins = map lastWin wsIdxs+ wins wsIdx = snd $ head $ filter ((==wsIdx).fst) windowSet+ lastWin wsIdx = listToMaybe $ reverse $ wins wsIdx++-- | Get window title, class, and EWMHIcons for the given window.+getWindowInfo :: Maybe X11Window -> IO WindowInfo+getWindowInfo Nothing = return Nothing+getWindowInfo (Just w) = withDefaultCtx $ do+ wTitle <- getWindowTitle w+ wClass <- getWindowClass w+ wIcon <- getWindowIcons w+ return $ Just (wTitle, wClass, wIcon)++-- | Get a list of windows for each workspace.+getWindowSet :: [WorkspaceIdx] -> IO WindowSet+getWindowSet wsIdxs = do+ windows <- withDefaultCtx getWindows+ workspaces <- mapM (withDefaultCtx.getWorkspace) windows+ let wsWins = zip workspaces windows+ return $ map (\wsIdx -> (wsIdx, lookupAll wsIdx wsWins)) wsIdxs+ where lookupAll x xs = map snd $ filter (((==)x).fst) xs+ -- | Apply the given marking function to the Label of the workspace with -- the given index. mark :: Desktop -- ^ List of all available labels.+ -> (String -> String) -- ^ Padding function. -> (String -> String) -- ^ Marking function. -> WorkspaceIdx -- ^ Index of the Label to modify. -> IO ()-mark desktop decorate wsIdx+mark desktop pad decorate wsIdx | Just ws <- getWS desktop wsIdx =- Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ decorate' (name ws)+ Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ pad $ decorate (name ws) | otherwise = return ()- where decorate' = pad . decorate- pad m | m == [] = m- | otherwise = ' ' : m +-- | Prefix the string with a space unless the string is empty.+prefixSpace :: String -> String+prefixSpace "" = ""+prefixSpace s = " " ++ s++-- | Set the widget names of the workspace button components:+-- border => Workspace-Border-<WORKSPACE_NAME>-<WORKSPACE_STATE>+-- image => Workspace-Image-<WORKSPACE_NAME>-<WORKSPACE_STATE>+-- container => Workspace-Container-<WORKSPACE_NAME>-<WORKSPACE_STATE>+-- label => Workspace-Label-<WORKSPACE_NAME>-<WORKSPACE_STATE>+setWidgetNames :: Desktop -> String -> WorkspaceIdx -> IO ()+setWidgetNames desktop workspaceState wsIdx+ | Just ws <- getWS desktop wsIdx = do+ Gtk.widgetSetName (label ws) (widgetName "Label" (name ws))+ Gtk.widgetSetName (image ws) (widgetName "Image" (name ws))+ Gtk.widgetSetName (border ws) (widgetName "Border" (name ws))+ Gtk.widgetSetName (container ws) (widgetName "Container" (name ws))+ | otherwise = return ()+ where widgetName widget wsName = "Workspace"+ ++ "-" ++ widget+ ++ "-" ++ wsName+ ++ "-" ++ workspaceState+ -- | Switch to the workspace with the given index. switch :: (MonadIO m) => WorkspaceIdx -> m Bool switch idx = do@@ -284,4 +450,3 @@ _ : rest -> return $ ys ++ (ws' : rest) _ -> return (ys ++ [ws']) _ -> return desktop-
− src/System/Taffybar/XMonadLog.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This widget listens on DBus for Log events from XMonad and--- displays the formatted status string. To log to this widget using--- the excellent dbus-core library, use code like the following:------ > import DBus.Client.Simple--- > main = do--- > session <- connectSession--- > emit session "/org/xmonad/Log" "org.xmonad.Log" "Update" [toVariant "msg"]------ There is a more complete example of xmonad integration in the--- top-level module.-module System.Taffybar.XMonadLog {-# DEPRECATED "Use TaffyPager instead. This module will be removed." #-} (- -- * Constructor- xmonadLogNew,- -- * Log hooks for xmonad.hs- dbusLog,- dbusLogWithPP,- -- * Styles- taffybarPP,- taffybarDefaultPP,- taffybarColor,- taffybarEscape- ) where--import Codec.Binary.UTF8.String ( decodeString )-import DBus ( toVariant, fromVariant, Signal(..), signal )-import DBus.Client ( listen, matchAny, MatchRule(..), connectSession, emit, Client )-import Graphics.UI.Gtk hiding ( Signal )--import XMonad-import XMonad.Hooks.DynamicLog---- | This is a DBus-based logger that can be used from XMonad to log--- to this widget. This version lets you specify the format for the--- log using a pretty printer (e.g., 'taffybarPP').-dbusLogWithPP :: Client -> PP -> X ()-dbusLogWithPP client pp = dynamicLogWithPP pp { ppOutput = outputThroughDBus client }---- | A DBus-based logger with a default pretty-print configuration-dbusLog :: Client -> X ()-dbusLog client = dbusLogWithPP client taffybarDefaultPP--taffybarColor :: String -> String -> String -> String-taffybarColor fg bg = wrap t "</span>" . taffybarEscape- where- t = concat ["<span fgcolor=\"", fg, if null bg then "" else "\" bgcolor=\"" ++ bg , "\">"]---- | Escape strings so that they can be safely displayed by Pango in--- the bar widget-taffybarEscape :: String -> String-taffybarEscape = escapeMarkup---- | The same as the default PP in XMonad.Hooks.DynamicLog-taffybarDefaultPP :: PP-taffybarDefaultPP =-#if MIN_VERSION_xmonad_contrib(0, 12, 0)- def {-#else- defaultPP {-#endif- ppCurrent = taffybarEscape . wrap "[" "]"- , ppVisible = taffybarEscape . wrap "<" ">"- , ppHidden = taffybarEscape- , ppHiddenNoWindows = taffybarEscape- , ppUrgent = taffybarEscape- , ppTitle = taffybarEscape . shorten 80- , ppLayout = taffybarEscape- }--- | The same as xmobarPP in XMonad.Hooks.DynamicLog-taffybarPP :: PP-taffybarPP = taffybarDefaultPP { ppCurrent = taffybarColor "yellow" "" . wrap "[" "]"- , ppTitle = taffybarColor "green" "" . shorten 40- , ppVisible = wrap "(" ")"- , ppUrgent = taffybarColor "red" "yellow"- }----outputThroughDBus :: Client -> String -> IO ()-outputThroughDBus client str = do- -- The string that we get from XMonad here isn't quite a normal- -- string - each character is actually a byte in a utf8 encoding.- -- We need to decode the string back into a real String before we- -- send it over dbus.- let str' = decodeString str- emit client (signal "/org/xmonad/Log" "org.xmonad.Log" "Update") { signalBody = [ toVariant str' ] }--setupDbus :: Label -> IO ()-setupDbus w = do- let matcher = matchAny { matchSender = Nothing- , matchDestination = Nothing- , matchPath = Just "/org/xmonad/Log"- , matchInterface = Just "org.xmonad.Log"- , matchMember = Just "Update"- }-- client <- connectSession-- listen client matcher (callback w)--callback :: Label -> Signal -> IO ()-callback w sig = do- let [bdy] = signalBody sig- status :: String- Just status = fromVariant bdy- postGUIAsync $ labelSetMarkup w status---- | Return a new XMonad log widget-xmonadLogNew :: IO Widget-xmonadLogNew = do- l <- labelNew (Nothing :: Maybe String)- _ <- on l realize $ setupDbus l- widgetShowAll l- return (toWidget l)--{-# DEPRECATED xmonadLogNew "Use taffyPagerNew instead." #-}
src/gdk_property_change_wrapper.c view
@@ -7,6 +7,7 @@ #include <gtk/gtk.h> #include <gdk/gdk.h>+#include <gdk/gdkkeysyms-compat.h> void set_strut_properties(GtkWindow *window, long left, long right, long top, long bottom,@@ -21,7 +22,7 @@ data[8] = top_start_x; data[9] = top_end_x; data[10] = bottom_start_x; data[11] = bottom_end_x; - gdk_property_change(GTK_WIDGET(window)->window,+ gdk_property_change(gtk_widget_get_window(GTK_WIDGET(window)), gdk_atom_intern("_NET_WM_STRUT_PARTIAL", FALSE), gdk_atom_intern ("CARDINAL", FALSE), 32, GDK_PROP_MODE_REPLACE, (unsigned char *)data, 12);
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 0.4.6+version: 1.0.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -8,9 +8,9 @@ category: System build-type: Simple cabal-version: >=1.10-tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2+tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 homepage: http://github.com/travitch/taffybar-data-files: taffybar.rc+data-files: taffybar.css extra-source-files: README.md, CHANGELOG.md, taffybar.hs.example@@ -22,102 +22,139 @@ flag network-uri description: network hack- default: True+ default: True library default-language: Haskell2010- build-depends: base > 3 && < 5,- time >= 1.4 && < 1.7,- time-locale-compat >= 0.1 && < 0.2,- old-locale,- containers,- text,- HTTP,- parsec >= 3.1,- mtl >= 2,- cairo,- dbus >= 0.10.1 && < 1.0,- gtk >= 0.12.1 && < 0.15,- dyre >= 0.8.6 && < 0.9,- HStringTemplate >= 0.8 && < 0.9,- gtk-traymanager >= 0.1.2 && < 0.2,- xmonad-contrib,- xmonad,- xdg-basedir >= 0.2 && < 0.3,- filepath,- utf8-string,- process,- stm,- transformers >= 0.3.0.0,- X11 >= 1.5.0.1,- safe >= 0.3 && < 1,- split >= 0.1.4.2,- process >= 1.0.1.1,- enclosed-exceptions >= 1.0.0.1+ build-depends: base > 3 && < 5+ , alsa-mixer >= 0.2.0+ , ConfigFile+ , HStringTemplate >= 0.8 && < 0.9+ , HTTP+ , X11 >= 1.5.0.1+ , cairo+ , containers+ , dbus >= 1.0.0 && < 2.0.0+ , directory+ , dyre >= 0.8.6 && < 0.9+ , either >= 4.0.0.0+ , enclosed-exceptions >= 1.0.0.1+ , filepath+ , glib+ , gtk-traymanager >= 1.0.0 && < 2.0.0+ , gtk3+ , mtl >= 2+ , multimap >= 1.2.1+ , old-locale+ , parsec >= 3.1+ , process >= 1.0.1.1+ , process+ , rate-limit >= 1.1.1+ , safe >= 0.3 && < 1+ , split >= 0.1.4.2+ , stm+ , text+ , time >= 1.4 && < 1.9+ , time-locale-compat >= 0.1 && < 0.2+ , time-units >= 1.0.0+ , transformers >= 0.3.0.0+ , tuple >= 0.3.0.2+ , unix+ , utf8-string+ , xdg-basedir >= 0.2 && < 0.3+ , xml+ , xml-helpers+ , xmonad+ , xmonad-contrib+ if flag(network-uri) build-depends: network-uri >= 2.6 && < 3, network >= 2.6 && < 3 else build-depends: network-uri < 2.6, network < 2.6 hs-source-dirs: src- pkgconfig-depends: gtk+-2.0- exposed-modules: System.Taffybar,- System.Taffybar.XMonadLog,- System.Taffybar.Systray,- System.Taffybar.SimpleClock,- System.Taffybar.FreedesktopNotifications,- System.Taffybar.Weather,- System.Taffybar.MPRIS,- System.Taffybar.MPRIS2,+ pkgconfig-depends: gtk+-3.0+ exposed-modules: System.Information.Battery,+ System.Information.CPU,+ System.Information.CPU2,+ System.Information.DiskIO,+ System.Information.EWMHDesktopInfo,+ System.Information.Memory,+ System.Information.Network,+ System.Information.SafeX11+ System.Information.StreamInfo,+ System.Information.Volume,+ System.Information.X11DesktopInfo,+ System.Taffybar, System.Taffybar.Battery, System.Taffybar.CPUMonitor, System.Taffybar.CommandRunner, System.Taffybar.DiskIOMonitor, System.Taffybar.FSMonitor,+ System.Taffybar.FreedesktopNotifications,+ System.Taffybar.Hooks.PagerHints,+ System.Taffybar.IconImages, System.Taffybar.LayoutSwitcher,+ System.Taffybar.MPRIS,+ System.Taffybar.MPRIS2,+ System.Taffybar.Menu.DesktopEntry,+ System.Taffybar.Menu.Menu,+ System.Taffybar.Menu.MenuWidget,+ System.Taffybar.Menu.XdgMenu, System.Taffybar.NetMonitor, System.Taffybar.Pager,+ System.Taffybar.SimpleClock,+ System.Taffybar.Systray, System.Taffybar.TaffyPager, System.Taffybar.Text.CPUMonitor, System.Taffybar.Text.MemoryMonitor,- System.Taffybar.WindowSwitcher,- System.Taffybar.WorkspaceSwitcher,- System.Taffybar.Hooks.PagerHints,+ System.Taffybar.ToggleMonitor,+ System.Taffybar.Volume,+ System.Taffybar.Weather, System.Taffybar.Widgets.Graph,+ System.Taffybar.Widgets.Icon, System.Taffybar.Widgets.PollingBar, System.Taffybar.Widgets.PollingGraph, System.Taffybar.Widgets.PollingLabel, System.Taffybar.Widgets.Util, System.Taffybar.Widgets.VerticalBar,- System.Information.StreamInfo,- System.Information.Battery,- System.Information.EWMHDesktopInfo,- System.Information.X11DesktopInfo,- System.Information.Memory,- System.Information.Network,- System.Information.CPU,- System.Information.CPU2,- System.Information.DiskIO+ System.Taffybar.WindowSwitcher,+ System.Taffybar.WorkspaceHUD,+ System.Taffybar.WorkspaceSwitcher+ other-modules: System.Taffybar.StrutProperties,- Paths_taffybar+ Paths_taffybar,+ System.Taffybar.Util c-sources: src/gdk_property_change_wrapper.c-+ cc-options: -fPIC ghc-options: -Wall -funbox-strict-fields executable taffybar default-language: Haskell2010- build-depends: base > 3 && < 5,- dyre >= 0.8.6,- gtk >= 0.12 && < 0.15,- safe >= 0.3 && < 1,- xdg-basedir,- filepath+ build-depends: base > 3 && < 5+ , X11 >= 1.5.0.1+ , containers+ , directory+ , dyre >= 0.8.6+ , filepath+ , glib+ , gtk3+ , mtl+ , safe >= 0.3 && < 1+ , split >= 0.1.4.2+ , taffybar+ , utf8-string+ , xdg-basedir hs-source-dirs: src main-is: Main.hs- pkgconfig-depends: gtk+-2.0+ other-modules: System.Taffybar,+ System.Taffybar.StrutProperties,+ System.Information.X11DesktopInfo+ pkgconfig-depends: gtk+-3.0 c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -rtsopts -threaded source-repository head type: git location: git://github.com/travitch/taffybar.git+
+ taffybar.css view
@@ -0,0 +1,65 @@+@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;++.Contents {+ border-radius: 5px;+ padding: 3px;+}++.Active .Contents, .Visible .Contents {+ background-color: @bg-tone;+}++.InnerPad {+ padding: 4px;+}++.WorkspaceLabel {+ padding-right: 3px;+ padding-left: 2px;+ font-size: 12pt;+}++.IconContainer {+ transition: background-color .5s;+ border-radius: 5px;+}++.IconContainer.Active {+ transition: background-color .5s;+ background-color: @active-window-color;+}++.IconContainer.Urgent {+ transition: background-color .5s;+ background-color: @urgent-window-color;+}++.IconContainer.Minimized .IconImage {+ transition: opacity .5s;+ opacity: .3;+}++.IconImage {+ transition: opacity .5s;+ padding: 2px;+ opacity: 1;+}++#WindowSwitcher {+ background-color: @bg-color;+}++.Taffybar {+ background-color: @bg-color;+ border-radius: 5px;+}++.Taffybar * {+ font-family: "Fira Sans", sans-serif;+ font-size: 10pt;+ color: @font-color;+}
taffybar.hs.example view
@@ -1,17 +1,17 @@-import System.Taffybar+module Main where +import System.Information.CPU+import System.Information.Memory+import System.Taffybar+import System.Taffybar.FreedesktopNotifications+import System.Taffybar.MPRIS+import System.Taffybar.SimpleClock import System.Taffybar.Systray import System.Taffybar.TaffyPager-import System.Taffybar.SimpleClock-import System.Taffybar.FreedesktopNotifications import System.Taffybar.Weather-import System.Taffybar.MPRIS- import System.Taffybar.Widgets.PollingBar import System.Taffybar.Widgets.PollingGraph--import System.Information.Memory-import System.Information.CPU+import System.Taffybar.WorkspaceHUD memCallback = do mi <- parseMeminfo@@ -31,7 +31,7 @@ , graphLabel = Just "cpu" } let clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1- pager = taffyPagerNew defaultPagerConfig+ pager = taffyPagerHUDNew defaultPagerConfig defaultWorkspaceHUDConfig note = notifyAreaNew defaultNotificationConfig wea = weatherNew (defaultWeatherConfig "KMSN") 10 mpris = mprisNew defaultMPRISConfig
− taffybar.rc
@@ -1,26 +0,0 @@--style "taffybar-default" {- color["black"] = "#000000"- color["white"] = "#ffffff"- color["green"] = "#00ff00"- color["red"] = "#ff0000"-- bg[NORMAL] = @black- fg[NORMAL] = @white- text[NORMAL] = @white- fg[PRELIGHT] = @green- bg[PRELIGHT] = @black-}--style "taffybar-active-window" = "taffybar-default" {- fg[NORMAL] = @green-}--style "taffybar-notification-button" = "taffybar-default" {- text[NORMAL] = @red- fg[NORMAL] = @red-}--widget "Taffybar*" style "taffybar-default"-widget "Taffybar*WindowSwitcher*label" style "taffybar-active-window"-widget "*NotificationCloseButton" style "taffybar-notification-button"