taffybar 1.0.1 → 1.0.2

raw patch · 20 files changed

+467/−647 lines, 20 filesdep +gi-gdkdep +gi-gdkpixbufdep +gi-gdkx11dep ~dyredep ~gtk3dep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: gi-gdk, gi-gdkpixbuf, gi-gdkx11, gi-gtk, haskell-gi-base, transformers-base

Dependency ranges changed: dyre, gtk3, mtl, xdg-basedir

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• LICENSE +1/−1
• README.md +53/−36
• app/Main.hs +9/−0
• src/Main.hs +0/−9
• src/System/Information/EWMHDesktopInfo.hs +23/−11
• src/System/Information/SafeX11.hsc +7/−3
• src/System/Information/X11DesktopInfo.hs +25/−14
• src/System/Taffybar.hs +1/−1
• src/System/Taffybar/Battery.hs +24/−13
• src/System/Taffybar/Context.hs +129/−0
• src/System/Taffybar/GtkLibCompat.hs +45/−0
• src/System/Taffybar/IconImages.hs +10/−9
• src/System/Taffybar/LayoutSwitcher.hs +6/−3
• src/System/Taffybar/Pager.hs +15/−44
• src/System/Taffybar/PixbufCompat.hs +71/−0
• src/System/Taffybar/WindowSwitcher.hs +5/−2
• src/System/Taffybar/WorkspaceHUD.hs +15/−23
• src/System/Taffybar/WorkspaceSwitcher.hs +0/−452
• taffybar.cabal +21/−26

@@ -1,3 +1,10 @@+# 1.0.2++## Bug Fixes++ * Fix long standing memory leak that was caused by a failure to free memory+   allocated for gtk pixbufs.+ # 1.0.0  ## Breaking Changes

@@ -1,4 +1,4 @@-Copyright (c)2011, Tristan Ravitch+Copyright (c) (2011-2018), Tristan Ravitch  All rights reserved. 

@@ -1,52 +1,69 @@+Taffybar+==========+[![Hackage](https://img.shields.io/hackage/v/taffybar.svg)](https://hackage.haskell.org/package/taffybar) [![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-of eye candy.  This bar is based on GTK+ (via gtk2hs) and uses fancy-graphics where doing so is reasonable and useful.  Example:+[![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.png)](https://gitter.im/taffybar/Lobby)+[![License BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](https://github.com/travitch/taffybar/blob/master/LICENSE)  ![](https://github.com/travitch/taffybar/blob/master/doc/screenshot.png) -The bar is configured much like XMonad.  It uses-~/.config/taffybar/taffybar.hs as its configuration file.  This file-is just a Haskell program that invokes the real _main_ function with a-configuration object.  The configuration file basically just specifies-which widgets to use, though any arbitrary Haskell code can be-executed before the bar is created.+Taffybar is a gtk+3 (through gtk2hs) based desktop information bar, intended+primarily for use with XMonad, though it can also function alongside other EWMH+compliant window managers. It is similar in spirit to xmobar, but it differs in+that it gives up some simplicity for a reasonable helping of eye candy. -There are some generic pre-defined widgets available:+Development Status+------------------ - * Graph (modeled after the graph widget in Awesome)- * Vertical bar (also similar to a widget in Awesome)- * Periodically-updating labels, graphs, and vertical bars+Taffybar is under active development and has many exciting but potentially+breaking changes ahead. All of the planned changes that will be occuring in the+near future are tracked in [this github+project](https://github.com/travitch/taffybar/projects/1). Particularly+significant is [#265](https://github.com/travitch/taffybar/issues/265) which is+actually already complete, and available in [this+branch](https://github.com/travitch/taffybar/tree/use_gtk-strut). New users are+encouraged to build from source and use this aforementioned branch to avoid+having to rewrite their configs when the new version of taffybar is released. -There are also several more specialized widgets:+Installation+------------ - * Battery widget- * Volume widget- * Network activity- * Textual clock- * Freedesktop.org notifications (via dbus)- * MPRIS1 and MPRIS2 widgets- * Weather widget- * Workspace, Window and Layout switchers- * System tray- * Freedesktop.org menu+Taffybar can be installed in a number of different ways: -[See full documentation of release version here.](https://hackage.haskell.org/package/taffybar)+### Stack -Installation-============-**NOTE**: `gtk2hs-buildtools` is needed for installations with GHC 8 and above, till there's better support for `setup-depends`.+Though it is admittedly a bit complicated to set up properly, using stack is the+preferred approach for installing taffybar, because it makes the build process+stable and repeatable. Even if you are unfamiliar with stack, or even haskell in+general, you should be able to get things working by using the taffybar's+quick-start script: -### Cabal ```-cabal install taffybar+curl -sSL https://raw.githubusercontent.com/travitch/taffybar/master/quick-start.sh | bash ``` -### Stack+This script will clone the taffybar repository into a subdirectory of the+default taffybar configuration directory, and copy the example cabal, stack and+taffybar.hs files into the same location. It will then install a binary+`my-taffybar` to `$HOME/.local/bin`, which can be executed to run taffybar. Note+that with this approach, running the `taffybar` binary WILL NOT work; you must+run the binary that is produced by the stack build in your local directory. The+name of the binary can be changed in the cabal file in the taffybar+configuration directory.+++### Cabal++Cabal installation is a simple matter of installing taffybar from hackage: ```-stack install gtk2hs-buildtools-stack install taffybar+cabal install taffybar ```++Configuration+-------------++Like xmobar and XMonad, taffybar is configured in haskell. Taffybar depends on+dyre to automatically detect changes to its configuration file+($XDG_CONFIG_HOME/taffybar/taffybar.hs) and recompile when appropriate.++For more details about how to configure taffybar, see the [full documentation](https://hackage.haskell.org/package/taffybar).

@@ -0,0 +1,9 @@+-- | This is just a stub executable that uses dyre to read the config+-- file and recompile itself.+module Main ( main ) where++import System.Taffybar++main :: IO ()+main = do+  defaultTaffybar defaultTaffybarConfig

@@ -1,9 +0,0 @@--- | This is just a stub executable that uses dyre to read the config--- file and recompile itself.-module Main ( main ) where--import System.Taffybar--main :: IO ()-main = do-  defaultTaffybar defaultTaffybarConfig

@@ -24,6 +24,7 @@   , X11WindowHandle   , WorkspaceIdx(..)   , EWMHIcon(..)+  , EWMHIconData   , withDefaultCtx -- re-exported from X11DesktopInfo   , isWindowUrgent -- re-exported from X11DesktopInfo   , getCurrentWorkspace@@ -31,9 +32,10 @@   , getWorkspaceNames   , switchToWorkspace   , switchOneWorkspace+  , withEWMHIcons   , getWindowTitle   , getWindowClass-  , getWindowIcons+  , getWindowIconsData   , getActiveWindowTitle   , getWindows   , getWindowHandles@@ -43,9 +45,8 @@  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+import Data.Tuple import Data.Word import Debug.Trace import Foreign.ForeignPtr@@ -75,6 +76,8 @@ -- appropriately. type PixelsWordType = Word64 +type EWMHIconData = (ForeignPtr PixelsWordType, Int)+ data EWMHIcon = EWMHIcon   { width :: Int   , height :: Int@@ -142,21 +145,30 @@ 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+-- | Get EWMHIconData for the given X11Window+getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData)+getWindowIconsData window = 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+  lift $ rawGetWindowPropertyBytes 32 dpy atom window +-- | Operate on the data contained in 'EWMHIconData' in the easier to interact+-- with format offered by 'EWMHIcon'. This function is much like+-- 'withForeignPtr' in that the 'EWMHIcon' values that are provided to the+-- callable argument should not be kept around in any way, because it can not be+-- guaranteed that the finalizer for the memory to which those icon objects+-- point will not be executed, after the call to 'withEWMHIcons' completes.+withEWMHIcons :: EWMHIconData -> ([EWMHIcon] -> IO a) -> IO a+withEWMHIcons (fptr, size) action =+  withForeignPtr fptr ((>>= action) . parseIcons size)+ -- | 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.+-- This function should not be made public, because its return value contains+-- (sub)pointers whose allocation we do not control. parseIcons :: Int -> Ptr PixelsWordType -> IO [EWMHIcon] parseIcons 0 _ = return [] parseIcons totalSize arr = do

@@ -10,7 +10,12 @@ -- Stability   : unstable -- Portability : unportable ------------------------------------------------------------------------------module System.Information.SafeX11 where+module System.Information.SafeX11+  ( module Graphics.X11.Xlib+  , module Graphics.X11.Xlib.Extras+  , module System.Information.SafeX11+  )+  where  import           Control.Concurrent import           Control.Exception@@ -26,9 +31,8 @@ import           Graphics.X11.Xlib.Extras        hiding (rawGetWindowProperty, getWindowProperty8,                getWindowProperty16, getWindowProperty32,-               xGetWMHints, getWMHints)+               xGetWMHints, getWMHints, refreshKeyboardMapping) import           Prelude-import           Graphics.X11.Xlib.Types import           System.IO import           System.IO.Unsafe import           System.Timeout

@@ -1,4 +1,3 @@-{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module      : System.Information.X11DesktopInfo@@ -47,6 +46,7 @@ import Data.Maybe  import Codec.Binary.UTF8.String as UTF8+import qualified Control.Concurrent.MVar as MV import Control.Monad.Reader import Data.Bits (testBit, (.|.)) import Data.List.Split (endBy)@@ -59,7 +59,11 @@ import Prelude import System.Information.SafeX11 -data X11Context = X11Context { contextDisplay :: Display, _contextRoot :: Window }+data X11Context = X11Context+  { contextDisplay :: Display+  , _contextRoot :: Window+  , atomCache :: MV.MVar [(String, Atom)]+  } type X11Property a = ReaderT X11Context IO a type X11Window = Window type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])@@ -155,8 +159,14 @@ -- | Return the Atom with the given name. getAtom :: String -> X11Property Atom getAtom s = do-  (X11Context d _) <- ask-  liftIO $ internAtom d s False+  (X11Context d _ cacheVar) <- ask+  a <- lift $ lookup s <$> MV.readMVar cacheVar+  let updateCacheAction = lift $ MV.modifyMVar cacheVar updateCache+      updateCache currentCache =+        do+          atom <- internAtom d s False+          return ((s, atom):currentCache, atom)+  maybe updateCacheAction return a  -- | Spawn a new thread and listen inside it to all incoming events, -- invoking the given function to every event of type @MapNotifyEvent@ that@@ -164,13 +174,13 @@ -- created windows. eventLoop :: (Event -> IO ()) -> X11Property () eventLoop dispatch = do-  (X11Context d w) <- ask+  (X11Context d w _) <- ask   liftIO $ do     selectInput d w $ propertyChangeMask .|. substructureNotifyMask     allocaXEvent $ \e -> forever $ do       event <- nextEvent d e >> getEvent e       case event of-        MapNotifyEvent _ _ _ _ _ window _ ->+        MapNotifyEvent { ev_window = window } ->           selectInput d window propertyChangeMask         _ -> return ()       dispatch event@@ -180,13 +190,13 @@ -- process and acted upon in that context. sendCommandEvent :: Atom -> Atom -> X11Property () sendCommandEvent cmd arg = do-  (X11Context dpy root) <- ask+  (X11Context dpy root _) <- ask   sendCustomEvent dpy cmd arg root root  -- | Similar to 'sendCommandEvent', but with an argument of type Window. sendWindowEvent :: Atom -> X11Window -> X11Property () sendWindowEvent cmd win = do-  (X11Context dpy root) <- ask+  (X11Context dpy root _) <- ask   sendCustomEvent dpy cmd cmd root win  -- | Build a new X11Context containing the current X11 display and its root@@ -195,7 +205,8 @@ getDefaultCtx = do   d <- openDisplay ""   w <- rootWindow d $ defaultScreen d-  return $ X11Context d w+  cache <- MV.newMVar []+  return $ X11Context d w cache  getWindowStateProperty :: X11Window -> String -> X11Property Bool getWindowStateProperty window property = not . null <$> getWindowState window [property]@@ -218,14 +229,14 @@       -> String            -- ^ Name of the property to retrieve.       -> X11Property (Maybe [a]) fetch fetcher window name = do-  (X11Context dpy root) <- ask+  (X11Context dpy root _) <- ask   atom <- getAtom name   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+  (X11Context d _ _) <- ask   liftIO $ getWMHints d window  -- | Emit an event of type @ClientMessage@ that can be listened to and@@ -251,13 +262,13 @@  isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool isActiveOutput sres output = do-  (X11Context display _) <- ask+  (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+  (X11Context display rootw _) <- ask   maybeSres <- liftIO $ xrrGetScreenResources display rootw   maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres)         maybeSres@@ -265,7 +276,7 @@ -- | Get the index of the primary monitor as set and ordered by Xrandr. getPrimaryOutputNumber :: X11Property (Maybe Int) getPrimaryOutputNumber = do-  (X11Context display rootw) <- ask+  (X11Context display rootw _) <- ask   primary <- liftIO $ xrrGetOutputPrimary display rootw   outputs <- getActiveOutputs   return $ primary `elemIndex` outputs

@@ -280,7 +280,7 @@ usePrimaryMonitor :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ) usePrimaryMonitor c@(cfg, _) = do   maybePrimary <- withDefaultCtx getPrimaryOutputNumber-  let primary = maybe (monitorNumber cfg) id maybePrimary+  let primary = fromMaybe (monitorNumber cfg) maybePrimary   return $ \mnumber -> if mnumber == primary then Just c else Nothing  allMonitors :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)

@@ -1,12 +1,23 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}--- | This module provides battery widgets using the UPower system+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.NetMonitor+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+--+-- This module provides battery widgets using the UPower system -- service. -- -- Currently it reports only the first battery it finds.  If it does -- not find a battery, it just returns an obnoxious widget with -- warning text in it.  Battery hotplugging is not supported.  These -- more advanced features could be supported if there is interest.+----------------------------------------------------------------------------- module System.Taffybar.Battery (   batteryBarNew,   batteryBarNewWithFormat,@@ -42,10 +53,10 @@ 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-            })+  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@@ -58,7 +69,7 @@ safeGetBatteryInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryInfo) safeGetBatteryInfo mv i = do   ctxt <- readIORef mv-  E.catchAny (getBatteryInfo ctxt) $ \_ -> reconnect+  E.catchAny (getBatteryInfo ctxt) $ const reconnect   where     reconnect = do       IO.hPutStrLn IO.stderr "reconnecting"@@ -108,11 +119,11 @@ -- | Provides textual information regarding multiple batteries battSumm :: [IORef BatteryContext] -> String -> IO String battSumm rs fmt = do-  winfos <- sequence $ fmap (uncurry getBatteryWidgetInfo) (rs `zip` [0..])+  winfos <- traverse (uncurry getBatteryWidgetInfo) (rs `zip` [0..])   let ws :: [BatteryWidgetInfo]       ws = flatten winfos       flatten []            = []-      flatten ((Just a):as) = a:(flatten as)+      flatten (Just a:as) = a:flatten as       flatten (Nothing:as)  = flatten as       combined = combine ws   return $ formatBattInfo combined fmt@@ -134,7 +145,7 @@ textBatteryNew [] _ _ =   let lbl :: Maybe String       lbl = Just "No battery"-  in labelNew lbl >>= return . toWidget+  in toWidget <$> labelNew lbl textBatteryNew rs fmt pollSeconds = do     l <- pollingLabelNew "" pollSeconds (battSumm rs fmt)     widgetShowAll l@@ -170,8 +181,8 @@ -- 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+batteryBarNew battCfg =+  batteryBarNewWithFormat battCfg "$percentage$%"  -- | A battery bar constructor which allows using a custom format string -- in order to display more information, such as charging/discharging time@@ -186,11 +197,11 @@       toWidget <$> labelNew lbl     cs -> do       b <- hBoxNew False 1-      rs <- sequence $ fmap newIORef cs+      rs <- traverse 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+      bars <- traverse (\(i, r) -> pollingBarNew battCfg pollSeconds (battPct i r)) ris       mapM_ (\bar -> boxPackStart b bar PackNatural 0) bars       boxPackStart b txt PackNatural 0       widgetShowAll b

@@ -0,0 +1,129 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Context+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+-----------------------------------------------------------------------------++module System.Taffybar.Context where++import           Control.Concurrent (forkIO)+import qualified Control.Concurrent.MVar as MV+import           Control.Exception.Enclosed (catchAny)+import           Control.Monad+import           Control.Monad.Base+import           Control.Monad.Trans+import           Control.Monad.Trans.Reader+import           Data.Data+import qualified Data.Map as M+import           Data.Unique+import           System.Information.SafeX11+import           System.Information.X11DesktopInfo+import           Unsafe.Coerce++type Taffy m v = (MonadBase IO m) => ReaderT Context m v+type Listener = Event -> Taffy IO ()+type SubscriptionList = [(Unique, Listener)]+data Value = forall t. Typeable t => Value t++fromValue :: forall t. Typeable t => Value -> Maybe t+fromValue (Value v) =+  if typeOf v == typeRep (Proxy :: Proxy t) then+    Just $ unsafeCoerce v+  else+    Nothing++data Context = Context+  { x11ContextVar :: MV.MVar X11Context+  , listeners :: MV.MVar SubscriptionList+  , contextState :: MV.MVar (M.Map TypeRep Value)+  }++buildEmptyContext :: IO Context+buildEmptyContext = do+  listenersVar <- MV.newMVar []+  state <- MV.newMVar M.empty+  ctx <- getDefaultCtx+  x11Context <- MV.newMVar ctx+  let context = Context+                { x11ContextVar = x11Context+                , listeners = listenersVar+                , contextState = state+                }+  runReaderT startX11EventHandler context+  return context++asksContextVar :: (r -> MV.MVar b) -> ReaderT r IO b+asksContextVar getter = asks getter >>= lift . MV.readMVar++runX11 :: ReaderT X11Context IO b -> ReaderT Context IO b+runX11 action =+  asksContextVar x11ContextVar >>= lift . runReaderT action++getState :: forall t. Typeable t => Taffy IO (Maybe t)+getState = do+  stateMap <- asksContextVar contextState+  let maybeValue = M.lookup (typeOf (undefined :: t)) stateMap+  return $ maybeValue >>= fromValue++putState :: Typeable t => t -> Taffy IO ()+putState v = do+  contextVar <- asks contextState+  lift $ MV.modifyMVar_ contextVar $ return . M.insert (typeOf v) (Value v)++liftReader ::+  Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b+liftReader modifier action =+  ask >>= lift . modifier . runReaderT action++taffyFork :: ReaderT r IO () -> ReaderT r IO ()+taffyFork = void . liftReader forkIO++startX11EventHandler :: Taffy IO ()+startX11EventHandler = taffyFork $ do+  c <- ask+  -- The event loop needs its own X11Context to separately handle communications+  -- from the X server.+  lift $ withDefaultCtx $ eventLoop+         (\e -> runReaderT (handleX11Event e) c)++unsubscribe :: Unique -> Taffy IO ()+unsubscribe identifier = do+  listenersVar <- asks listeners+  lift $ MV.modifyMVar_ listenersVar $ return . filter ((== identifier) . fst)++subscribeToAll :: Listener -> Taffy IO Unique+subscribeToAll listener = do+  identifier <- lift newUnique+  listenersVar <- asks listeners+  let+    -- This type annotation probably has something to do with the warnings that+    -- occur without MonoLocalBinds, but it still seems to be necessary+    addListener :: SubscriptionList -> SubscriptionList+    addListener = ((identifier, listener):)+  lift $ MV.modifyMVar_ listenersVar (return . addListener)+  return identifier++subscribeToEvents :: [String] -> Listener -> Taffy IO Unique+subscribeToEvents eventNames listener = do+  eventAtoms <- mapM (runX11 . getAtom) eventNames+  let filteredListener event@PropertyEvent { ev_atom = atom } =+        when (atom `elem` eventAtoms) $ catchAny (listener event) (const $ return ())+      filteredListener _ = return ()+  subscribeToAll filteredListener++handleX11Event :: Event -> Taffy IO ()+handleX11Event event =+  asksContextVar listeners >>= mapM_ applyListener+  where applyListener :: (Unique, Listener) -> Taffy IO ()+        applyListener (_, listener) = taffyFork $ listener event

@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.GtkLibCompat+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.GtkLibCompat where++import           Data.GI.Base.ManagedPtr+import           Data.Word+import           Foreign.ForeignPtr+import           Foreign.Marshal.Alloc+import           Foreign.Ptr+import           GI.GdkPixbuf.Enums+import qualified GI.GdkPixbuf.Objects.Pixbuf as PB+import qualified GI.Gtk+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Types as Gtk+import           System.Glib.GObject+import           System.Taffybar.PixbufCompat++fromGIPixBuf :: PB.Pixbuf -> IO Gtk.Pixbuf+fromGIPixBuf (PB.Pixbuf pbManagedPtr) =+  wrapNewGObject Gtk.mkPixbuf (castPtr <$> disownManagedPtr pbManagedPtr)++toGIWindow :: Gtk.Window -> IO GI.Gtk.Window+toGIWindow window = do+  let wid = Gtk.toWidget window+  fPtr <- withForeignPtr (Gtk.unWidget wid) $ flip GI.Gtk.newManagedPtr (return ()) . castPtr+  return $! GI.Gtk.Window fPtr++-- | Call the GI version of 'pixbufNewFromData' with sensible parameters. The+-- provided ptr will be freed when the pixbuf is destroyed.+pixbufNewFromData :: (Integral p2, Integral p1) => Ptr Word8 -> p2 -> p1 -> IO Gtk.Pixbuf+pixbufNewFromData ptr w h = do+  let width = fromIntegral w+      height = fromIntegral h+      rowStride = width * 4+  giPb <- pixbufNewFromData' ptr ColorspaceRgb True 8+    width height rowStride (Just free)+  fromGIPixBuf giPb

@@ -19,20 +19,22 @@   selectEWMHIcon ) where +-- TODO: rename module to IconPixbuf+ 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+import           System.Taffybar.GtkLibCompat  type ColorRGBA = (Word8, Word8, Word8, Word8) --- | Take the passed in pixbuf and ensure its scaled square.+-- | Take the passed in pixbuf and scale it to the provided imageSize. scalePixbuf :: Int -> Gtk.Pixbuf -> IO Gtk.Pixbuf scalePixbuf imgSize pixbuf = do   h <- Gtk.pixbufGetHeight pixbuf@@ -55,12 +57,9 @@ -- | 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+  wPtr <- pixelsARGBToBytesABGR px (w * h)+  pixbufNewFromData wPtr w h+  -- Gtk.pixbufNewFromData (castPtr wPtr) colorspace hasAlpha sampleBits w h (w * 4)  -- | Create a pixbuf with the indicated RGBA color. pixBufFromColor :: Int -> ColorRGBA -> IO Gtk.Pixbuf@@ -70,9 +69,11 @@   return pixbuf  -- | Convert a C array of integer pixels in the ARGB format to the ABGR format.+-- Returns an unmanged Ptr that points to a block of memory that must be freed+-- manually. pixelsARGBToBytesABGR   :: (Storable a, Bits a, Num a, Integral a)-  => Ptr a -> Int -> IO (Ptr CUChar)+  => Ptr a -> Int -> IO (Ptr Word8) pixelsARGBToBytesABGR ptr size = do   target <- mallocArray (size * 4)   let writeIndex i = do

@@ -29,6 +29,7 @@ import Control.Monad.Trans import Control.Monad.Reader import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Abstract.Widget as W import Graphics.X11.Xlib.Extras (Event) import System.Taffybar.Pager import System.Information.X11DesktopInfo@@ -67,9 +68,11 @@   -- This callback is run in a separate thread and needs to use   -- postGUIAsync   let cfg = config pager-      callback = Gtk.postGUIAsync . (flip runReaderT pager) . (pagerCallback cfg label)-  subscribe pager callback xLayoutProp-  assembleWidget pager label+      callback = Gtk.postGUIAsync . flip runReaderT pager . pagerCallback cfg label+  subscription <- subscribe pager callback xLayoutProp+  widget <- assembleWidget pager label+  _ <- Gtk.on widget W.unrealize (unsubscribe pager subscription)+  return widget  -- | Build a suitable callback function that can be registered as Listener -- of "_XMONAD_CURRENT_LAYOUT" custom events. These events are emitted by

@@ -40,29 +40,22 @@   , liftPagerX11Def   , runWithPager   , shorten+  , unsubscribe   , wrap   , escape   ) where -import Control.Concurrent (forkIO)-import Control.Exception-import Control.Exception.Enclosed (catchAny)+import qualified Control.Concurrent.MVar as MV import Control.Monad.Reader-import Data.IORef+import Data.Unique+import System.Information.SafeX11 import qualified Data.Map as M import Graphics.UI.Gtk (escapeMarkup)-import Graphics.X11.Types-import Graphics.X11.Xlib.Extras-  hiding (rawGetWindowProperty, getWindowProperty8,-          getWindowProperty16, getWindowProperty32) import System.Information.EWMHDesktopInfo import System.Information.X11DesktopInfo+import qualified System.Taffybar.Context as TContext import Text.Printf (printf) -type Listener = Event -> IO ()-type Filter = Atom-type SubscriptionList = IORef [(Listener, Filter)]- -- | Structure contanining functions to customize the pretty printing of -- different widget elements. data PagerConfig = PagerConfig@@ -105,8 +98,7 @@ -- | 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+  , tContext :: TContext.Context   }  type PagerIO a = ReaderT Pager IO a@@ -119,8 +111,7 @@  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+  x11Ctx <- MV.readMVar $ TContext.x11ContextVar $ tContext pager   runReaderT prop x11Ctx  -- | Default pretty printing options.@@ -164,39 +155,19 @@ -- | 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 []-  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-            listeners <- readIORef ref-            mapM_ (notify event) listeners---- | Passes the given Event to the given Listener, but only if it was--- registered for that type of events via 'subscribe'.-notify :: Event -> (Listener, Filter) -> IO ()-notify event (listener, eventFilter) =-  case event of-    PropertyEvent _ _ _ _ _ atom _ _ ->-      when (atom == eventFilter) $ catchAny (listener event) ignoreException-    _ -> return ()+pagerNew cfg = Pager cfg <$> TContext.buildEmptyContext  -- | Registers the given Listener as a subscriber of events of the given -- type: whenever a new event of the type with the given name arrives to -- the Pager, it will execute Listener on it.-subscribe :: Pager -> Listener -> String -> IO ()-subscribe pager listener filterName = do-  eventFilter <- runWithPager pager $ getAtom filterName-  registered <- readIORef (clients pager)-  let next = (listener, eventFilter)-  writeIORef (clients pager) (next : registered)+subscribe :: Pager -> (Event -> IO ()) -> String -> IO Unique+subscribe pager listener filterName =+  runReaderT (TContext.subscribeToEvents [filterName] (lift . listener)) $+             tContext pager -ignoreException :: SomeException -> IO ()-ignoreException _ = return ()+unsubscribe :: Pager -> Unique -> IO ()+unsubscribe pager identifier =+  runReaderT (TContext.unsubscribe identifier) $ tContext pager  -- | Creates markup with the given foreground and background colors and the -- given contents.

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.PixbufCompat where++import qualified Data.GI.Base.CallStack as B.CallStack+import           Data.GI.Base.ShortPrelude+import qualified GI.GdkPixbuf.Callbacks as GdkPixbuf.Callbacks+import qualified GI.GdkPixbuf.Enums as GdkPixbuf.Enums+import           GI.GdkPixbuf.Objects.Pixbuf++-- TODO: Remove this once a better approach is found+++foreign import ccall "gdk_pixbuf_new_from_data" gdk_pixbuf_new_from_data ::+    Ptr Word8 ->                            -- data : TCArray False (-1) (-1) (TBasicType TUInt8)+    CUInt ->                                -- colorspace : TInterface (Name {namespace = "GdkPixbuf", name = "Colorspace"})+    CInt ->                                 -- has_alpha : TBasicType TBoolean+    Int32 ->                                -- bits_per_sample : TBasicType TInt+    Int32 ->                                -- width : TBasicType TInt+    Int32 ->                                -- height : TBasicType TInt+    Int32 ->                                -- rowstride : TBasicType TInt+    FunPtr GdkPixbuf.Callbacks.C_PixbufDestroyNotify -> -- destroy_fn : TInterface (Name {namespace = "GdkPixbuf", name = "PixbufDestroyNotify"})+    Ptr () ->                               -- destroy_fn_data : TBasicType TPtr+    IO (Ptr Pixbuf)++{- |+Creates a new 'GI.GdkPixbuf.Objects.Pixbuf.Pixbuf' out of in-memory image data.  Currently only RGB+images with 8 bits per sample are supported.++Since you are providing a pre-allocated pixel buffer, you must also+specify a way to free that data.  This is done with a function of+type 'GI.GdkPixbuf.Callbacks.PixbufDestroyNotify'.  When a pixbuf created with is+finalized, your destroy notification function will be called, and+it is its responsibility to free the pixel array.++See also 'GI.GdkPixbuf.Objects.Pixbuf.pixbufNewFromBytes'.+-}+pixbufNewFromData' ::+    (B.CallStack.HasCallStack, MonadIO m) =>+    Ptr Word8+    {- ^ /@data@/: Image data in 8-bit\/sample packed format -}+    -> GdkPixbuf.Enums.Colorspace+    {- ^ /@colorspace@/: Colorspace for the image data -}+    -> Bool+    {- ^ /@hasAlpha@/: Whether the data has an opacity channel -}+    -> Int32+    {- ^ /@bitsPerSample@/: Number of bits per sample -}+    -> Int32+    {- ^ /@width@/: Width of the image in pixels, must be > 0 -}+    -> Int32+    {- ^ /@height@/: Height of the image in pixels, must be > 0 -}+    -> Int32+    {- ^ /@rowstride@/: Distance in bytes between row starts -}+    -> Maybe GdkPixbuf.Callbacks.PixbufDestroyNotify+    {- ^ /@destroyFn@/: Function used to free the data when the pixbuf\'s reference count+drops to zero, or 'Nothing' if the data should not be freed -}+    -> m Pixbuf+    {- ^ __Returns:__ A newly-created 'GI.GdkPixbuf.Objects.Pixbuf.Pixbuf' structure with a reference count of 1. -}+pixbufNewFromData' data_ colorspace hasAlpha bitsPerSample width height rowstride destroyFn = liftIO $ do+    let colorspace' = (fromIntegral . fromEnum) colorspace+    let hasAlpha' = (fromIntegral . fromEnum) hasAlpha+    ptrdestroyFn <- callocMem :: IO (Ptr (FunPtr GdkPixbuf.Callbacks.C_PixbufDestroyNotify))+    maybeDestroyFn <- case destroyFn of+        Nothing -> return (castPtrToFunPtr nullPtr)+        Just jDestroyFn -> do+            jDestroyFn' <- GdkPixbuf.Callbacks.mk_PixbufDestroyNotify (GdkPixbuf.Callbacks.wrap_PixbufDestroyNotify (Just ptrdestroyFn) (GdkPixbuf.Callbacks.drop_closures_PixbufDestroyNotify jDestroyFn))+            poke ptrdestroyFn jDestroyFn'+            return jDestroyFn'+    let destroyFnData = nullPtr+    result <- gdk_pixbuf_new_from_data data_ colorspace' hasAlpha' bitsPerSample width height rowstride maybeDestroyFn destroyFnData+    checkUnexpectedReturnNULL "pixbufNewFromData" result+    wrapObject Pixbuf result

@@ -28,6 +28,7 @@ import           Control.Monad.Reader import qualified Data.Map as M import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Abstract.Widget as W import           Graphics.X11.Xlib.Extras (Event) import           System.Information.EWMHDesktopInfo import           System.Information.X11DesktopInfo@@ -63,8 +64,10 @@   -- callback in another thread.  We need to use postGUIAsync in it.   let cfg = config pager       callback = pagerCallback cfg label-  subscribe pager (runWithPager pager . callback) "_NET_ACTIVE_WINDOW"-  assembleWidget pager label+  subscription <- subscribe pager (runWithPager pager . callback) "_NET_ACTIVE_WINDOW"+  widget <- assembleWidget pager label+  _ <- Gtk.on widget W.unrealize (unsubscribe pager subscription)+  return widget  -- | Build a suitable callback function that can be registered as Listener -- of "_NET_ACTIVE_WINDOW" standard events. It will keep track of the

@@ -70,9 +70,6 @@ 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@@ -93,7 +90,7 @@ workspaceStates = map show [Active, Visible, Hidden, Empty, Urgent]  data IconInfo-  = IIEWMH EWMHIcon+  = IIEWMH EWMHIconData   | IIFilePath FilePath   | IIColor ColorRGBA   | IINone@@ -157,9 +154,9 @@   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))+        hasClass klass >>= (`when` styleContextAddClass context klass) . not+      removeIfPresent klass = unless (klass `elem` toAdd) $+        hasClass klass >>= (`when` styleContextRemoveClass context klass)   mapM_ removeIfPresent toRemove   mapM_ addIfMissing toAdd @@ -192,7 +189,6 @@   , minIcons :: Int   , getIconInfo :: WindowData -> HUDIO IconInfo   , labelSetter :: Workspace -> HUDIO String-  , updateOnWMIconChange :: Bool   , showWorkspaceFn :: Workspace -> Bool   , borderWidth :: Int   , updateEvents :: [String]@@ -279,7 +275,6 @@   , minIcons = 0   , getIconInfo = defaultGetIconInfo   , labelSetter = return . workspaceName-  , updateOnWMIconChange = True   , showWorkspaceFn = const True   , borderWidth = 2   , iconSort = sortWindowsByPosition@@ -463,10 +458,12 @@   -- This will actually create all the widgets   runReaderT updateAllWorkspaceWidgets context   updateHandler <- onWorkspaceUpdate context-  mapM_ (subscribe pager updateHandler) $ updateEvents cfg+  subscriptions <- mapM (subscribe pager updateHandler) $ updateEvents cfg   iconHandler <- onIconsChanged context-  when (updateOnWMIconChange cfg) $-    subscribe pager (onIconChanged context iconHandler) "_NET_WM_ICON"+  iconSubscription <- subscribe pager (onIconChanged context iconHandler) "_NET_WM_ICON"+  let doUnsubscribe =+        mapM_ (unsubscribe pager) (iconSubscription:subscriptions)+  _ <- Gtk.on cont W.unrealize doUnsubscribe   return $ Gtk.toWidget cont  updateAllWorkspaceWidgets :: HUDIO ()@@ -548,7 +545,6 @@             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@@ -722,13 +718,8 @@   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+defaultGetIconInfo w =+  maybe IINone IIEWMH <$> liftX11Def Nothing (getWindowIconsData $ windowId w)  forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b) forkM a b = sequenceT . (a &&& b)@@ -752,8 +743,8 @@ updateImages ic ws = do   Context {hudConfig = cfg} <- ask   sortedWindows <- iconSort cfg $ windows ws-  let updateIconWidget' getImage wdata ton = do-        iconWidget <- getImage+  let updateIconWidget' getImageAction wdata ton = do+        iconWidget <- getImageAction         _ <- updateIconWidget ic iconWidget wdata ton         return iconWidget       existingImages = map return $ iconImages ic@@ -857,7 +848,8 @@ getPixBuf :: Int -> IconInfo -> IO (Maybe Gtk.Pixbuf) getPixBuf imgSize = gpb   where-    gpb (IIEWMH icon) = Just <$> pixBufFromEWMHIcon icon+    gpb (IIEWMH iconData) = Just <$>+      withEWMHIcons iconData (pixBufFromEWMHIcon . selectEWMHIcon imgSize)     gpb (IIFilePath file) = Just <$> pixBufFromFile imgSize file     gpb (IIColor color) = Just <$> pixBufFromColor imgSize color     gpb _ = return Nothing

@@ -1,452 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      : System.Taffybar.WorkspaceSwitcher--- Copyright   : (c) José A. Romero L.--- License     : BSD3-style (see LICENSE)------ Maintainer  : José A. Romero L. <escherdragon@gmail.com>--- Stability   : unstable--- Portability : unportable------ Composite widget that displays all currently configured workspaces and--- allows to switch to any of them by clicking on its label. Supports also--- urgency hints and (with an additional hook) display of other visible--- workspaces besides the active one (in Xinerama or XRandR installations).------ N.B. If you're just looking for a drop-in replacement for the--- "System.Taffybar.XMonadLog" widget that is clickable and doesn't require--- DBus, you may want to see first "System.Taffybar.TaffyPager".-----------------------------------------------------------------------------------module System.Taffybar.WorkspaceSwitcher-  {-# DEPRECATED "Use WorkspaceHUD instead of WorkspaceSwitcher" #-} (-  -- * Usage-  -- $usage-  wspaceSwitcherNew-  ) 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, 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-                           , 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--- project be installed in your @xmonad.hs@ file:------ > import XMonad.Hooks.EwmhDesktops (ewmh)--- > main = do--- >   xmonad $ ewmh $ defaultConfig--- > ...------ Urgency hooks are not required for the urgency hints displaying to work--- (since it is also based on desktop events), but if you use @focusUrgent@--- you may want to keep the \"@withUrgencyHook NoUrgencyHook@\" anyway.------ Unfortunately, in multiple monitor installations EWMH does not provide a--- way to determine what desktops are shown in secondary displays. Thus, if--- you have more than one monitor you may want to additionally install the--- "System.Taffybar.Hooks.PagerHints" hook in your @xmonad.hs@:------ > import System.Taffybar.Hooks.PagerHints (pagerHints)--- > main = do--- >   xmonad $ ewmh $ pagerHints $ defaultConfig--- > ...------ Once you've properly configured @xmonad.hs@, you can use the widget in--- your @taffybar.hs@ file:------ > import System.Taffybar.WorkspaceSwitcher--- > main = do--- >   pager <- pagerNew defaultPagerConfig--- >   let wss = wspaceSwitcherNew pager------ now you can use @wss@ as any other Taffybar widget.---- | Create a new WorkspaceSwitcher widget that will use the given Pager as--- its source of events.-wspaceSwitcherNew :: Pager -> IO Gtk.Widget-wspaceSwitcherNew pager = do-  switcher <- Gtk.hBoxNew False (workspaceGap (config pager))-  desktop  <- getDesktop pager-  deskRef  <- MV.newMVar desktop-  populateSwitcher switcher deskRef--  -- These callbacks need to use postGUIAsync since they run in-  -- another thread-  let cfg = config pager-      activecb = activeCallback cfg deskRef-      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"--  return $ Gtk.toWidget switcher---- | List of indices of all available workspaces.-allWorkspaces :: Desktop -> [WorkspaceIdx]-allWorkspaces desktop = map WSIdx [0 .. length desktop - 1]---- | List of indices of all the workspaces that contain at least one window.-nonEmptyWorkspaces :: IO [WorkspaceIdx]-nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows---- | Return a list of Workspace data instances.-getDesktop :: Pager -> IO Desktop-getDesktop pager = do-  names  <- map snd <$> withDefaultCtx getWorkspaceNames-  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.-updateDesktop :: Pager -> MV.MVar Desktop -> IO Bool-updateDesktop pager deskRef = do-  wsnames <- withDefaultCtx getWorkspaceNames-  MV.modifyMVar deskRef $ \desktop ->-    case map snd wsnames /= map name desktop of-      True -> do-        desk' <- getDesktop pager-        return (desk', True)-      False -> return (desktop, False)---- | Clean up the given box, then fill it up with the buttons for the current--- state of the desktop.-populateSwitcher :: Gtk.BoxClass box => box -> MV.MVar Desktop -> IO ()-populateSwitcher switcher deskRef = do-  containerClear switcher-  desktop <- MV.readMVar deskRef-  mapM_ (addButton switcher desktop) (allWorkspaces desktop)-  Gtk.widgetShowAll switcher---- | Build a suitable callback function that can be registered as Listener--- of "_NET_CURRENT_DESKTOP" standard events. It will track the position of--- the active workspace in the desktop.-activeCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO ()-activeCallback cfg deskRef _ = Gtk.postGUIAsync $ do-  curr <- withDefaultCtx getVisibleWorkspaces-  desktop <- MV.readMVar deskRef-  case curr of-    visible : _ | Just ws <- getWS desktop visible -> do-      when (urgent ws) $ toggleUrgent deskRef visible False-      transition cfg desktop curr-    _ -> return ()---- | Build a suitable callback function that can be registered as Listener--- of "WM_HINTS" standard events. It will display in a different color any--- workspace (other than the active one) containing one or more windows--- with its urgency hint set.-urgentCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO ()-urgentCallback cfg deskRef event = Gtk.postGUIAsync $ do-  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 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--- adding and removing workspaces.-redrawCallback :: Gtk.BoxClass box => Pager -> MV.MVar Desktop -> box -> Event -> IO ()-redrawCallback pager deskRef box _ = Gtk.postGUIAsync $ do-  -- updateDesktop indirectly invokes some gtk functions, so it also-  -- needs to be guarded by postGUIAsync-  deskChanged <- updateDesktop pager deskRef-  when deskChanged $ populateSwitcher box deskRef---- | Remove all children of a container.-containerClear :: Gtk.ContainerClass self => self -> IO ()-containerClear c = Gtk.containerForeach c (Gtk.containerRemove c)---- | 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-getWS desktop (WSIdx idx)-  | length desktop > idx = Just (desktop !! idx)-  | otherwise            = Nothing---- | Build a new clickable event box containing the Label widget that--- corresponds to the given index, and add it to the given container.-addButton :: Gtk.BoxClass self-          => self         -- ^ Graphical container.-          -> Desktop      -- ^ List of all workspace Labels available.-          -> WorkspaceIdx -- ^ Index of the workspace to use.-          -> IO ()-addButton switcherHbox desktop idx-  | Just ws <- getWS desktop idx = do-    let lbl = label ws-    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.ScrollSmooth -> return False-    return ()--  | otherwise = return ()---- | Re-mark all workspace labels.-transition :: PagerConfig    -- ^ Configuration settings.-           -> Desktop        -- ^ All available Labels with their default values.-           -> [WorkspaceIdx] -- ^ Currently visible workspaces (first is active).-           -> IO ()-transition cfg desktop wss = do-  nonEmpty <- fmap (filter (>=WSIdx 0)) nonEmptyWorkspaces-  let urgentWs = map WSIdx $ findIndices urgent desktop-      allWs    = (allWorkspaces desktop) \\ urgentWs-      nonEmptyWs = nonEmpty \\ urgentWs-      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 pad (activeWorkspace cfg) active-      setWidgetNames desktop "active" active-      mapM_ (mark desktop pad $ visibleWorkspace cfg) rest-      mapM_ (setWidgetNames desktop "visible") rest-    _ -> return ()-  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 pad decorate wsIdx-  | Just ws <- getWS desktop wsIdx =-    Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ pad $ decorate (name ws)-  | otherwise = return ()---- | Prefix the string with a space unless the string is empty.-prefixSpace :: String -> String-prefixSpace "" = ""-prefixSpace s = " " ++ s---- | Set the widget names of the workspace button components:--- border    => Workspace-Border-<WORKSPACE_NAME>-<WORKSPACE_STATE>--- image     => Workspace-Image-<WORKSPACE_NAME>-<WORKSPACE_STATE>--- container => Workspace-Container-<WORKSPACE_NAME>-<WORKSPACE_STATE>--- label     => Workspace-Label-<WORKSPACE_NAME>-<WORKSPACE_STATE>-setWidgetNames :: Desktop -> String -> WorkspaceIdx -> IO ()-setWidgetNames desktop workspaceState wsIdx-  | Just ws <- getWS desktop wsIdx = do-      Gtk.widgetSetName (label ws)     (widgetName "Label"     (name ws))-      Gtk.widgetSetName (image ws)     (widgetName "Image"     (name ws))-      Gtk.widgetSetName (border ws)    (widgetName "Border"    (name ws))-      Gtk.widgetSetName (container ws) (widgetName "Container" (name ws))-  | otherwise = return ()-  where widgetName widget wsName = "Workspace"-                                   ++ "-" ++ widget-                                   ++ "-" ++ wsName-                                   ++ "-" ++ workspaceState---- | Switch to the workspace with the given index.-switch :: (MonadIO m) => WorkspaceIdx -> m Bool-switch idx = do-  liftIO $ withDefaultCtx (switchToWorkspace idx)-  return True---- | Switch to one workspace up or down given a boolean direction and the last workspace-switchOne :: (MonadIO m) => Bool -> Int -> m Bool-switchOne dir end = do-  liftIO $ withDefaultCtx (if dir then switchOneWorkspace dir end else switchOneWorkspace dir end)-  return True---- | Modify the Desktop inside the given IORef, so that the Workspace at the--- given index has its "urgent" flag set to the given value.-toggleUrgent :: MV.MVar Desktop -- ^ MVar to modify.-             -> WorkspaceIdx  -- ^ Index of the Workspace to replace.-             -> Bool          -- ^ New value of the "urgent" flag.-             -> IO ()-toggleUrgent deskRef (WSIdx idx) isUrgent =-  MV.modifyMVar_ deskRef $ \desktop -> do-    let ws = desktop !! idx-    case length desktop > idx of-      True | isUrgent /= urgent ws -> do-               let ws' = ws { urgent = isUrgent }-                   (ys, zs) = splitAt idx desktop-               case zs of-                 _ : rest -> return $ ys ++ (ws' : rest)-                 _ -> return (ys ++ [ws'])-      _ -> return desktop

@@ -1,5 +1,5 @@ name: taffybar-version: 1.0.1+version: 1.0.2 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -16,9 +16,10 @@                     taffybar.hs.example  description:-  A somewhat fancier desktop bar than xmobar.  This bar is based on-  gtk2hs and provides several widgets (including a few graphical ones).-  It also sports an optional snazzy system tray.+  Taffybar is a gtk+3 (through gtk2hs) based desktop information bar, intended+  primarily for use with XMonad, though it can also function alongside other EWMH+  compliant window managers. It is similar in spirit to xmobar, but it differs in+  that it gives up some simplicity for a reasonable helping of eye candy.  flag network-uri   description: network hack@@ -40,6 +41,11 @@                , either >= 4.0.0.0                , enclosed-exceptions >= 1.0.0.1                , filepath+               , haskell-gi-base+               , gi-gdk+               , gi-gdkpixbuf >= 2.0.15+               , gi-gdkx11+               , gi-gtk                , glib                , gtk-traymanager >= 1.0.1 && < 2.0.0                , gtk3@@ -58,6 +64,7 @@                , time-locale-compat >= 0.1 && < 0.2                , time-units >= 1.0.0                , transformers >= 0.3.0.0+               , transformers-base >= 0.4                , tuple >= 0.3.0.2                , unix                , utf8-string@@ -86,6 +93,7 @@                    System.Information.X11DesktopInfo,                    System.Taffybar,                    System.Taffybar.Battery,+                   System.Taffybar.Context,                    System.Taffybar.CPUMonitor,                    System.Taffybar.CommandRunner,                    System.Taffybar.DiskIOMonitor,@@ -118,13 +126,14 @@                    System.Taffybar.Widgets.Util,                    System.Taffybar.Widgets.VerticalBar,                    System.Taffybar.WindowSwitcher,-                   System.Taffybar.WorkspaceHUD,-                   System.Taffybar.WorkspaceSwitcher-                   -  other-modules: System.Taffybar.StrutProperties,-                 Paths_taffybar,-                 System.Taffybar.Util+                   System.Taffybar.WorkspaceHUD +  other-modules: Paths_taffybar+               , System.Taffybar.GtkLibCompat+               , System.Taffybar.PixbufCompat+               , System.Taffybar.StrutProperties+               , System.Taffybar.Util+   c-sources: src/gdk_property_change_wrapper.c   cc-options: -fPIC   ghc-options: -Wall -funbox-strict-fields@@ -132,24 +141,10 @@ executable taffybar   default-language: Haskell2010   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++  hs-source-dirs: app   main-is: Main.hs-  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