diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://travis-ci.org/travitch/taffybar.svg?branch=master)](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 +``` diff --git a/src/System/Information/Battery.hs b/src/System/Information/Battery.hs --- a/src/System/Information/Battery.hs +++ b/src/System/Information/Battery.hs @@ -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 diff --git a/src/System/Information/EWMHDesktopInfo.hs b/src/System/Information/EWMHDesktopInfo.hs --- a/src/System/Information/EWMHDesktopInfo.hs +++ b/src/System/Information/EWMHDesktopInfo.hs @@ -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 diff --git a/src/System/Information/Memory.hs b/src/System/Information/Memory.hs --- a/src/System/Information/Memory.hs +++ b/src/System/Information/Memory.hs @@ -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 } - diff --git a/src/System/Information/Network.hs b/src/System/Information/Network.hs --- a/src/System/Information/Network.hs +++ b/src/System/Information/Network.hs @@ -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 diff --git a/src/System/Information/SafeX11.hsc b/src/System/Information/SafeX11.hsc new file mode 100644 --- /dev/null +++ b/src/System/Information/SafeX11.hsc @@ -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 diff --git a/src/System/Information/Volume.hs b/src/System/Information/Volume.hs new file mode 100644 --- /dev/null +++ b/src/System/Information/Volume.hs @@ -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 diff --git a/src/System/Information/X11DesktopInfo.hs b/src/System/Information/X11DesktopInfo.hs --- a/src/System/Information/X11DesktopInfo.hs +++ b/src/System/Information/X11DesktopInfo.hs @@ -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 diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -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 . + + -- * 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 () diff --git a/src/System/Taffybar/Battery.hs b/src/System/Taffybar/Battery.hs --- a/src/System/Taffybar/Battery.hs +++ b/src/System/Taffybar/Battery.hs @@ -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) diff --git a/src/System/Taffybar/FreedesktopNotifications.hs b/src/System/Taffybar/FreedesktopNotifications.hs --- a/src/System/Taffybar/FreedesktopNotifications.hs +++ b/src/System/Taffybar/FreedesktopNotifications.hs @@ -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 [ "Note:" - , 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 "" <> prefix <> "" <> 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 diff --git a/src/System/Taffybar/Hooks/PagerHints.hs b/src/System/Taffybar/Hooks/PagerHints.hs --- a/src/System/Taffybar/Hooks/PagerHints.hs +++ b/src/System/Taffybar/Hooks/PagerHints.hs @@ -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) diff --git a/src/System/Taffybar/IconImages.hs b/src/System/Taffybar/IconImages.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/IconImages.hs @@ -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 diff --git a/src/System/Taffybar/LayoutSwitcher.hs b/src/System/Taffybar/LayoutSwitcher.hs --- a/src/System/Taffybar/LayoutSwitcher.hs +++ b/src/System/Taffybar/LayoutSwitcher.hs @@ -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) diff --git a/src/System/Taffybar/MPRIS.hs b/src/System/Taffybar/MPRIS.hs --- a/src/System/Taffybar/MPRIS.hs +++ b/src/System/Taffybar/MPRIS.hs @@ -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 () diff --git a/src/System/Taffybar/MPRIS2.hs b/src/System/Taffybar/MPRIS2.hs --- a/src/System/Taffybar/MPRIS2.hs +++ b/src/System/Taffybar/MPRIS2.hs @@ -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 () diff --git a/src/System/Taffybar/Menu/DesktopEntry.hs b/src/System/Taffybar/Menu/DesktopEntry.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Menu/DesktopEntry.hs @@ -0,0 +1,179 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Menu.DesktopEntry +-- Copyright : 2017 Ulf Jasper +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ulf Jasper +-- 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. % 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" + diff --git a/src/System/Taffybar/Menu/Menu.hs b/src/System/Taffybar/Menu/Menu.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Menu/Menu.hs @@ -0,0 +1,124 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Menu.Menu +-- Copyright : 2017 Ulf Jasper +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ulf Jasper +-- 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 diff --git a/src/System/Taffybar/Menu/MenuWidget.hs b/src/System/Taffybar/Menu/MenuWidget.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Menu/MenuWidget.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Menu.MenuWidget +-- Copyright : 2017 Ulf Jasper +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ulf Jasper +-- 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 diff --git a/src/System/Taffybar/Menu/XdgMenu.hs b/src/System/Taffybar/Menu/XdgMenu.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Menu/XdgMenu.hs @@ -0,0 +1,277 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Taffybar.Menu.XdgMenu +-- Copyright : 2017 Ulf Jasper +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Ulf Jasper +-- 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) diff --git a/src/System/Taffybar/NetMonitor.hs b/src/System/Taffybar/NetMonitor.hs --- a/src/System/Taffybar/NetMonitor.hs +++ b/src/System/Taffybar/NetMonitor.hs @@ -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 diff --git a/src/System/Taffybar/Pager.hs b/src/System/Taffybar/Pager.hs --- a/src/System/Taffybar/Pager.hs +++ b/src/System/Taffybar/Pager.hs @@ -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) diff --git a/src/System/Taffybar/SimpleClock.hs b/src/System/Taffybar/SimpleClock.hs --- a/src/System/Taffybar/SimpleClock.hs +++ b/src/System/Taffybar/SimpleClock.hs @@ -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) diff --git a/src/System/Taffybar/Systray.hs b/src/System/Taffybar/Systray.hs --- a/src/System/Taffybar/Systray.hs +++ b/src/System/Taffybar/Systray.hs @@ -17,8 +17,5 @@ widgetShowAll w boxPackStart box w PackNatural 0 - _ <- on trayManager trayIconRemoved $ \_ -> do - putStrLn "Tray icon removed" - widgetShowAll box return (toWidget box) diff --git a/src/System/Taffybar/TaffyPager.hs b/src/System/Taffybar/TaffyPager.hs --- a/src/System/Taffybar/TaffyPager.hs +++ b/src/System/Taffybar/TaffyPager.hs @@ -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 diff --git a/src/System/Taffybar/ToggleMonitor.hs b/src/System/Taffybar/ToggleMonitor.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/ToggleMonitor.hs @@ -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 diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Util.hs @@ -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) diff --git a/src/System/Taffybar/Volume.hs b/src/System/Taffybar/Volume.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Volume.hs @@ -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 diff --git a/src/System/Taffybar/Weather.hs b/src/System/Taffybar/Weather.hs --- a/src/System/Taffybar/Weather.hs +++ b/src/System/Taffybar/Weather.hs @@ -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 diff --git a/src/System/Taffybar/Widgets/Graph.hs b/src/System/Taffybar/Widgets/Graph.hs --- a/src/System/Taffybar/Widgets/Graph.hs +++ b/src/System/Taffybar/Widgets/Graph.hs @@ -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) diff --git a/src/System/Taffybar/Widgets/Icon.hs b/src/System/Taffybar/Widgets/Icon.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/Widgets/Icon.hs @@ -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 () diff --git a/src/System/Taffybar/Widgets/PollingLabel.hs b/src/System/Taffybar/Widgets/PollingLabel.hs --- a/src/System/Taffybar/Widgets/PollingLabel.hs +++ b/src/System/Taffybar/Widgets/PollingLabel.hs @@ -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 () diff --git a/src/System/Taffybar/Widgets/Util.hs b/src/System/Taffybar/Widgets/Util.hs --- a/src/System/Taffybar/Widgets/Util.hs +++ b/src/System/Taffybar/Widgets/Util.hs @@ -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) diff --git a/src/System/Taffybar/Widgets/VerticalBar.hs b/src/System/Taffybar/Widgets/VerticalBar.hs --- a/src/System/Taffybar/Widgets/VerticalBar.hs +++ b/src/System/Taffybar/Widgets/VerticalBar.hs @@ -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) diff --git a/src/System/Taffybar/WindowSwitcher.hs b/src/System/Taffybar/WindowSwitcher.hs --- a/src/System/Taffybar/WindowSwitcher.hs +++ b/src/System/Taffybar/WindowSwitcher.hs @@ -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 diff --git a/src/System/Taffybar/WorkspaceHUD.hs b/src/System/Taffybar/WorkspaceHUD.hs new file mode 100644 --- /dev/null +++ b/src/System/Taffybar/WorkspaceHUD.hs @@ -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) diff --git a/src/System/Taffybar/WorkspaceSwitcher.hs b/src/System/Taffybar/WorkspaceSwitcher.hs --- a/src/System/Taffybar/WorkspaceSwitcher.hs +++ b/src/System/Taffybar/WorkspaceSwitcher.hs @@ -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-- +-- image => Workspace-Image-- +-- container => Workspace-Container-- +-- label => Workspace-Label-- +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 - diff --git a/src/System/Taffybar/XMonadLog.hs b/src/System/Taffybar/XMonadLog.hs deleted file mode 100644 --- a/src/System/Taffybar/XMonadLog.hs +++ /dev/null @@ -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 "" . taffybarEscape - where - t = concat [""] - --- | 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." #-} diff --git a/src/gdk_property_change_wrapper.c b/src/gdk_property_change_wrapper.c --- a/src/gdk_property_change_wrapper.c +++ b/src/gdk_property_change_wrapper.c @@ -7,6 +7,7 @@ #include #include +#include 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); diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -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 + diff --git a/taffybar.css b/taffybar.css new file mode 100644 --- /dev/null +++ b/taffybar.css @@ -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; +} diff --git a/taffybar.hs.example b/taffybar.hs.example --- a/taffybar.hs.example +++ b/taffybar.hs.example @@ -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 "%a %b %_d %H:%M" 1 - pager = taffyPagerNew defaultPagerConfig + pager = taffyPagerHUDNew defaultPagerConfig defaultWorkspaceHUDConfig note = notifyAreaNew defaultNotificationConfig wea = weatherNew (defaultWeatherConfig "KMSN") 10 mpris = mprisNew defaultMPRISConfig diff --git a/taffybar.rc b/taffybar.rc deleted file mode 100644 --- a/taffybar.rc +++ /dev/null @@ -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"