taffybar 0.4.4 → 0.4.5
raw patch · 10 files changed
+216/−149 lines, 10 filesdep +time-locale-compatdep ~time
Dependencies added: time-locale-compat
Dependency ranges changed: time
Files
- CHANGELOG.md +4/−0
- src/System/Information/Network.hs +2/−0
- src/System/Taffybar/LayoutSwitcher.hs +20/−18
- src/System/Taffybar/MPRIS.hs +40/−17
- src/System/Taffybar/MPRIS2.hs +22/−14
- src/System/Taffybar/NetMonitor.hs +1/−1
- src/System/Taffybar/SimpleClock.hs +5/−5
- src/System/Taffybar/WindowSwitcher.hs +42/−35
- src/System/Taffybar/WorkspaceSwitcher.hs +77/−57
- taffybar.cabal +3/−2
CHANGELOG.md view
@@ -1,3 +1,7 @@+# 0.4.5++ * GHC 7.10 compat+ # 0.4.4 * Fix compilation with gtk 0.13.1
src/System/Information/Network.hs view
@@ -21,6 +21,8 @@ import Safe ( atMay, initSafe, readDef ) import System.Information.StreamInfo ( getParsedInfo ) +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.
src/System/Taffybar/LayoutSwitcher.hs view
@@ -27,7 +27,7 @@ ) where import Control.Monad.IO.Class (MonadIO, liftIO)-import Graphics.UI.Gtk+import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras (Event) import System.Taffybar.Pager import System.Information.X11DesktopInfo@@ -60,9 +60,11 @@ -- | Create a new LayoutSwitcher widget that will use the given Pager as -- its source of events.-layoutSwitcherNew :: Pager -> IO Widget+layoutSwitcherNew :: Pager -> IO Gtk.Widget layoutSwitcherNew pager = do- label <- labelNew (Nothing :: Maybe String)+ label <- Gtk.labelNew (Nothing :: Maybe String)+ -- This callback is run in a separate thread and needs to use+ -- postGUIAsync let cfg = config pager callback = pagerCallback cfg label subscribe pager callback xLayoutProp@@ -71,31 +73,31 @@ -- | 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 -> Label -> Event -> IO ()-pagerCallback cfg label _ = do+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO ()+pagerCallback cfg label _ = Gtk.postGUIAsync $ do layout <- withDefaultCtx $ readAsString Nothing xLayoutProp let decorate = activeLayout cfg- postGUIAsync $ labelSetMarkup label (decorate layout)+ Gtk.labelSetMarkup label (decorate layout) -- | Build the graphical representation of the widget.-assembleWidget :: Label -> IO Widget+assembleWidget :: Gtk.Label -> IO Gtk.Widget assembleWidget label = do- ebox <- eventBoxNew- containerAdd ebox label- _ <- on ebox buttonPressEvent dispatchButtonEvent- widgetShowAll ebox- return $ toWidget ebox+ ebox <- Gtk.eventBoxNew+ Gtk.containerAdd ebox label+ _ <- Gtk.on ebox Gtk.buttonPressEvent dispatchButtonEvent+ 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 :: EventM EButton Bool+dispatchButtonEvent :: Gtk.EventM Gtk.EButton Bool dispatchButtonEvent = do- btn <- eventButton- let trigger = onClick [SingleClick]+ btn <- Gtk.eventButton+ let trigger = onClick [Gtk.SingleClick] case btn of- LeftButton -> trigger $ switch 1- RightButton -> trigger $ switch (-1)- _ -> return False+ Gtk.LeftButton -> trigger $ switch 1+ Gtk.RightButton -> trigger $ 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
src/System/Taffybar/MPRIS.hs view
@@ -5,10 +5,12 @@ -- only works with version 1 of the MPRIS protocol -- (http://www.mpris.org/1.0/spec.html). Support for version 2 will -- be in a separate widget.------ This widget isn't as configurable as the others yet - that will be--- fixed.-module System.Taffybar.MPRIS ( mprisNew ) where+module System.Taffybar.MPRIS+ ( TrackInfo (..)+ , MPRISConfig (..)+ , defaultMPRISConfig+ , mprisNew+ ) where import Data.Int ( Int32 ) import qualified Data.Map as M@@ -19,8 +21,18 @@ import Graphics.UI.Gtk hiding ( Signal, Variant ) import Text.Printf -setupDBus :: Label -> IO ()-setupDBus w = do+data TrackInfo = TrackInfo+ { trackArtist :: Maybe String -- ^ Artist name, if available.+ , trackTitle :: Maybe String -- ^ Track name, if available.+ , trackAlbum :: Maybe String -- ^ Album name, if available.+ }++data MPRISConfig = MPRISConfig+ { trackLabel :: TrackInfo -> String -- ^ Calculate a label to display.+ }++setupDBus :: MPRISConfig -> Label -> IO ()+setupDBus cfg w = do let trackMatcher = matchAny { matchSender = Nothing , matchDestination = Nothing , matchPath = Just "/Player"@@ -34,7 +46,7 @@ , matchMember = Just "StatusChange" } client <- connectSession- listen client trackMatcher (trackCallback w)+ listen client trackMatcher (trackCallback cfg w) listen client stateMatcher (stateCallback w) variantDictLookup :: (IsVariant b, Ord k) => k -> M.Map k Variant -> Maybe b@@ -43,18 +55,19 @@ fromVariant val -trackCallback :: Label -> Signal -> IO ()-trackCallback w s = do+trackCallback :: MPRISConfig -> Label -> Signal -> IO ()+trackCallback cfg w s = do let v :: Maybe (M.Map Text Variant) v = fromVariant variant [variant] = signalBody s case v of Just m -> do- let artist = maybe "[unknown]" id (variantDictLookup "artist" m)- track = maybe "[unknown]" id (variantDictLookup "title" m)- msg :: String- msg = escapeMarkup $ printf "%s - %s" (T.unpack artist) (T.unpack track)- txt = "<span fgcolor='yellow'>Now Playing:</span> " ++ msg+ let getInfo key = fmap (escapeMarkup . T.unpack) $ variantDictLookup key m+ txt = trackLabel cfg info+ info = TrackInfo { trackArtist = getInfo "artist"+ , trackTitle = getInfo "title"+ , trackAlbum = getInfo "album"+ } postGUIAsync $ do -- In case the widget was hidden due to a stop/pause, forcibly -- show it again when the track changes.@@ -74,10 +87,20 @@ _ -> return () _ -> return () -mprisNew :: IO Widget-mprisNew = do+defaultMPRISConfig :: MPRISConfig+defaultMPRISConfig = MPRISConfig+ { trackLabel = display+ }+ where artist track = maybe "[unknown]" id (trackArtist track)+ title track = maybe "[unknown]" id (trackTitle track)+ display :: TrackInfo -> String+ display track = "<span fgcolor='yellow'>▶</span> " +++ printf "%s - %s" (artist track) (title track)++mprisNew :: MPRISConfig -> IO Widget+mprisNew cfg = do l <- labelNew (Nothing :: Maybe String) - _ <- on l realize $ setupDBus l+ _ <- on l realize $ setupDBus cfg l widgetShowAll l return (toWidget l)
src/System/Taffybar/MPRIS2.hs view
@@ -75,14 +75,17 @@ setSongInfo :: Label -> String -> String -> IO () setSongInfo w artist title = do let msg :: String- msg = escapeMarkup $ printf "%s - %s" (cutoff 15 artist) (cutoff 30 title)+ msg = case artist of+ "" -> escapeMarkup $ printf "%s" (truncateString 30 title)+ _ -> escapeMarkup $ printf "%s - %s" (truncateString 15 artist) (truncateString 30 title) txt = "<span fgcolor='yellow'>▶</span> " ++ msg postGUIAsync $ do labelSetMarkup w txt- widgetShowAll w- where cutoff n xs | length xs <= n = xs- | otherwise = take n xs ++ "…" +truncateString :: Int -> String -> String+truncateString n xs | length xs <= n = xs+ | otherwise = take n xs ++ "…"+ updatePlaybackStatus :: Label -> [(Variant, Variant)] -> IO () updatePlaybackStatus w items = do case lookup (toVariant ("PlaybackStatus" :: String)) items of@@ -96,18 +99,23 @@ return () updateSongInfo :: Label -> [(Variant, Variant)] -> IO ()-updateSongInfo w items =- case parseArtistAndTitle of- Just (artist, title) -> setSongInfo w artist title+updateSongInfo w items = do+ let artist = case readArtist of+ Just x -> x+ Nothing -> ""+ case readTitle of+ Just title -> do+ setSongInfo w artist title Nothing -> return () where- parseArtistAndTitle = do- aLookup <- lookup (toVariant ("xesam:artist" :: String)) items- tLookup <- lookup (toVariant ("xesam:title" :: String)) items- let artists = (unpack . unpack) aLookup :: [String]- title = (unpack . unpack) tLookup :: String- artist <- listToMaybe artists- return (artist, title)+ readArtist :: Maybe String+ readArtist = do+ artist <- lookup (toVariant ("xesam:artist" :: String)) items+ listToMaybe $ ((unpack . unpack) artist :: [String])+ readTitle :: Maybe String+ readTitle = do+ title <- lookup (toVariant ("xesam:title" :: String)) items+ Just $ (unpack . unpack) title updateMetadata :: Label -> [(Variant, Variant)] -> IO () updateMetadata w items = do
src/System/Taffybar/NetMonitor.hs view
@@ -64,7 +64,7 @@ Just thisSample -> do lastSample <- readIORef sample writeIORef sample thisSample- let deltas = map fromIntegral $ zipWith (-) thisSample lastSample+ 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
src/System/Taffybar/SimpleClock.hs view
@@ -16,7 +16,7 @@ import Data.Time.Format import Data.Time.LocalTime import Graphics.UI.Gtk-import System.Locale+import qualified Data.Time.Locale.Compat as L import System.Taffybar.Widgets.PollingLabel import System.Taffybar.Widgets.Util@@ -53,14 +53,14 @@ -- | Create the widget. I recommend passing @Nothing@ for the -- TimeLocale parameter. The format string can include Pango markup -- (http://developer.gnome.org/pango/stable/PangoMarkupFormat.html).-textClockNew :: Maybe TimeLocale -> String -> Double -> IO Widget+textClockNew :: Maybe L.TimeLocale -> String -> Double -> IO Widget textClockNew userLocale fmt updateSeconds = textClockNewWith cfg fmt updateSeconds where cfg = defaultClockConfig { clockTimeLocale = userLocale } data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone- , clockTimeLocale :: Maybe TimeLocale+ , clockTimeLocale :: Maybe L.TimeLocale } deriving (Eq, Ord, Show) @@ -69,7 +69,7 @@ defaultClockConfig = ClockConfig Nothing Nothing data TimeInfo = TimeInfo { getTZ :: IO TimeZone- , getLocale :: IO TimeLocale+ , getLocale :: IO L.TimeLocale } systemGetTZ :: IO TimeZone@@ -94,7 +94,7 @@ textClockNewWith :: ClockConfig -> String -> Double -> IO Widget textClockNewWith cfg fmt updateSeconds = do let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone- , getLocale = maybe (return defaultTimeLocale) return userLocale+ , getLocale = maybe (return L.defaultTimeLocale) return userLocale } l <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt) ebox <- eventBoxNew
src/System/Taffybar/WindowSwitcher.hs view
@@ -26,7 +26,8 @@ ) where import Control.Monad (forM_)-import Graphics.UI.Gtk+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@@ -53,10 +54,12 @@ -- | Create a new WindowSwitcher widget that will use the given Pager as -- its source of events.-windowSwitcherNew :: Pager -> IO Widget+windowSwitcherNew :: Pager -> IO Gtk.Widget windowSwitcherNew pager = do- label <- labelNew (Nothing :: Maybe String)- widgetSetName label "label"+ label <- Gtk.labelNew (Nothing :: Maybe String)+ Gtk.widgetSetName label "label"+ -- This callback is registered through 'subscribe', which runs the+ -- 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"@@ -65,24 +68,24 @@ -- | 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 -> Label -> Event -> IO ()+pagerCallback :: PagerConfig -> Gtk.Label -> Event -> IO () pagerCallback cfg label _ = do title <- withDefaultCtx getActiveWindowTitle let decorate = activeWindow cfg- postGUIAsync $ labelSetMarkup label (decorate $ nonEmpty title)+ Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title) -- | Build the graphical representation of the widget.-assembleWidget :: Label -> IO Widget+assembleWidget :: Gtk.Label -> IO Gtk.Widget assembleWidget label = do- title <- menuItemNew- widgetSetName title "title"- containerAdd title label+ title <- Gtk.menuItemNew+ Gtk.widgetSetName title "title"+ Gtk.containerAdd title label - switcher <- menuBarNew- widgetSetName switcher "WindowSwitcher"- containerAdd switcher title+ switcher <- Gtk.menuBarNew+ Gtk.widgetSetName switcher "WindowSwitcher"+ Gtk.containerAdd switcher title - rcParseString $ unlines [ "style 'WindowSwitcher' {"+ Gtk.rcParseString $ unlines [ "style 'WindowSwitcher' {" , " xthickness = 0" , " GtkMenuBar::internal-padding = 0" , "}"@@ -93,35 +96,39 @@ , "widget '*WindowSwitcher' style 'WindowSwitcher'" , "widget '*WindowSwitcher*title' style 'title'" ]- menu <- menuNew- widgetSetName menu "menu"+ menu <- Gtk.menuNew+ Gtk.widgetSetName menu "menu" - menuTop <- widgetGetToplevel menu- widgetSetName menuTop "Taffybar_WindowSwitcher"+ menuTop <- Gtk.widgetGetToplevel menu+ Gtk.widgetSetName menuTop "Taffybar_WindowSwitcher" - menuItemSetSubmenu title menu- _ <- on title menuItemActivate $ fillMenu menu- _ <- on title menuItemDeselect $ emptyMenu menu+ 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.menuItemDeselect $ emptyMenu menu - widgetShowAll switcher- return $ toWidget switcher+ Gtk.widgetShowAll switcher+ return $ Gtk.toWidget switcher -- | Populate the given menu widget with the list of all currently open windows.-fillMenu :: MenuClass menu => menu -> IO ()-fillMenu menu = do- handles <- withDefaultCtx getWindowHandles+fillMenu :: Gtk.MenuClass menu => menu -> IO ()+fillMenu menu = withDefaultCtx $ do+ handles <- getWindowHandles if null handles then return () else do- wsNames <- withDefaultCtx getWorkspaceNames- forM_ handles $ \handle -> do- item <- menuItemNewWithLabel (formatEntry wsNames handle)- _ <- onActivateLeaf item $ withDefaultCtx (focusWindow $ snd handle)- menuShellAppend menu item- widgetShow item+ wsNames <- getWorkspaceNames+ forM_ handles $ \handle -> liftIO $ do+ item <- Gtk.menuItemNewWithLabel (formatEntry wsNames handle)+ _ <- Gtk.on item Gtk.buttonPressEvent $ liftIO $ do+ withDefaultCtx (focusWindow $ snd handle)+ return True+ Gtk.menuShellAppend menu item+ Gtk.widgetShow item -- | Remove all contents from the given menu widget.-emptyMenu :: MenuClass menu => menu -> IO ()-emptyMenu menu = containerForeach menu $ \item ->- containerRemove menu item >> postGUIAsync (widgetDestroy item)+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
src/System/Taffybar/WorkspaceSwitcher.hs view
@@ -26,18 +26,18 @@ wspaceSwitcherNew ) where +import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.IORef import Data.List ((\\), findIndices)-import Graphics.UI.Gtk hiding (get)+import qualified Graphics.UI.Gtk as Gtk import Graphics.X11.Xlib.Extras import System.Taffybar.Pager import System.Information.EWMHDesktopInfo type Desktop = [Workspace]-data Workspace = Workspace { label :: Label+data Workspace = Workspace { label :: Gtk.Label , name :: String , urgent :: Bool }@@ -77,13 +77,15 @@ -- | Create a new WorkspaceSwitcher widget that will use the given Pager as -- its source of events.-wspaceSwitcherNew :: Pager -> IO Widget+wspaceSwitcherNew :: Pager -> IO Gtk.Widget wspaceSwitcherNew pager = do- switcher <- hBoxNew False 0+ switcher <- Gtk.hBoxNew False 0 desktop <- getDesktop pager- deskRef <- newIORef desktop+ 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@@ -92,7 +94,7 @@ subscribe pager redrawcb "_NET_NUMBER_OF_DESKTOPS" subscribe pager urgentcb "WM_HINTS" - return $ toWidget switcher+ return $ Gtk.toWidget switcher -- | List of indices of all available workspaces. allWorkspaces :: Desktop -> [Int]@@ -114,42 +116,46 @@ -- | 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 -> IORef Desktop -> IO Bool+updateDesktop :: Pager -> MV.MVar Desktop -> IO Bool updateDesktop pager deskRef = do wsnames <- withDefaultCtx getWorkspaceNames- desktop <- readIORef deskRef- if (length wsnames /= length desktop)- then getDesktop pager >>= writeIORef deskRef >> return True- else return False+ MV.modifyMVar deskRef $ \desktop ->+ case length wsnames /= length 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 :: BoxClass box => box -> IORef Desktop -> IO ()+populateSwitcher :: Gtk.BoxClass box => box -> MV.MVar Desktop -> IO () populateSwitcher switcher deskRef = do containerClear switcher- desktop <- readIORef deskRef+ desktop <- MV.readMVar deskRef mapM_ (addButton switcher desktop) (allWorkspaces desktop)- widgetShowAll switcher+ 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 -> IORef Desktop -> Event -> IO ()-activeCallback cfg deskRef _ = do+activeCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO ()+activeCallback cfg deskRef _ = Gtk.postGUIAsync $ do curr <- withDefaultCtx getVisibleWorkspaces- desktop <- readIORef deskRef- let visible = head curr- when (urgent $ desktop !! visible) $- liftIO $ toggleUrgent deskRef visible False- transition cfg desktop curr+ desktop <- MV.readMVar deskRef+ case curr of+ visible : _ | length desktop > visible -> do+ when (urgent (desktop !! visible)) $ do+ 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 -> IORef Desktop -> Event -> IO ()-urgentCallback cfg deskRef event = do- desktop <- readIORef deskRef+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 isUrgent <- isWindowUrgent window@@ -163,39 +169,43 @@ -- | 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 :: BoxClass box => Pager -> IORef Desktop -> box -> Event -> IO ()-redrawCallback pager deskRef box _ =- updateDesktop pager deskRef >>= \deskChanged ->- when deskChanged $ postGUIAsync (populateSwitcher box deskRef)+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 :: ContainerClass self => self -> IO ()-containerClear container = containerForeach container (containerRemove container)+containerClear :: Gtk.ContainerClass self => self -> IO ()+containerClear container = Gtk.containerForeach container (Gtk.containerRemove container) -- | Convert the given list of Strings to a list of Label widgets.-toLabels :: [String] -> IO [Label]+toLabels :: [String] -> IO [Gtk.Label] toLabels = mapM labelNewMarkup where labelNewMarkup markup = do- lbl <- labelNew (Nothing :: Maybe String)- labelSetMarkup lbl markup+ lbl <- Gtk.labelNew (Nothing :: Maybe String)+ Gtk.labelSetMarkup lbl markup return lbl -- | Build a new clickable event box containing the Label widget that -- corresponds to the given index, and add it to the given container.-addButton :: BoxClass self+addButton :: Gtk.BoxClass self => self -- ^ Graphical container. -> Desktop -- ^ List of all workspace Labels available. -> Int -- ^ Index of the workspace to use. -> IO ()-addButton hbox desktop idx = do- let index = desktop !! idx- lbl = label index- ebox <- eventBoxNew- widgetSetName ebox $ name index- eventBoxSetVisibleWindow ebox False- _ <- on ebox buttonPressEvent $ switch idx- containerAdd ebox lbl- boxPackStart hbox ebox PackNatural 0+addButton hbox desktop idx+ | length desktop > idx = do+ let index = desktop !! idx+ lbl = label index+ ebox <- Gtk.eventBoxNew+ Gtk.widgetSetName ebox $ name index+ Gtk.eventBoxSetVisibleWindow ebox False+ _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch idx+ Gtk.containerAdd ebox lbl+ Gtk.boxPackStart hbox ebox Gtk.PackNatural 0+ | otherwise = return () -- | Re-mark all workspace labels. transition :: PagerConfig -- ^ Configuration settings.@@ -209,8 +219,11 @@ nonEmptyWs = nonEmpty \\ urgentWs mapM_ (mark desktop $ hiddenWorkspace cfg) nonEmptyWs mapM_ (mark desktop $ emptyWorkspace cfg) (allWs \\ nonEmpty)- mark desktop (activeWorkspace cfg) (head wss)- mapM_ (mark desktop $ visibleWorkspace cfg) (tail wss)+ case wss of+ active:rest -> do+ mark desktop (activeWorkspace cfg) active+ mapM_ (mark desktop $ visibleWorkspace cfg) rest+ _ -> return () mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs -- | Apply the given marking function to the Label of the workspace with@@ -219,9 +232,11 @@ -> (String -> String) -- ^ Marking function. -> Int -- ^ Index of the Label to modify. -> IO ()-mark desktop decorate idx = do- let ws = desktop !! idx- postGUIAsync $ labelSetMarkup (label ws) $ decorate' (name ws)+mark desktop decorate idx+ | length desktop > idx = do+ let ws = desktop !! idx+ Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ decorate' (name ws)+ | otherwise = return () where decorate' = pad . decorate pad m | m == [] = m | otherwise = ' ' : m@@ -234,14 +249,19 @@ -- | 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 :: IORef Desktop -- ^ IORef to modify.+toggleUrgent :: MV.MVar Desktop -- ^ IORef to modify. -> Int -- ^ Index of the Workspace to replace. -> Bool -- ^ New value of the "urgent" flag. -> IO ()-toggleUrgent deskRef idx isUrgent = do- desktop <- readIORef deskRef- let ws = desktop !! idx- unless (isUrgent == urgent ws) $ do- let ws' = (desktop !! idx) { urgent = isUrgent }- let (ys, zs) = splitAt idx desktop- in writeIORef deskRef $ ys ++ (ws' : tail zs)+toggleUrgent deskRef 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+
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 0.4.4+version: 0.4.5 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -26,7 +26,8 @@ library default-language: Haskell2010 build-depends: base > 3 && < 5,- time >= 1.4 && < 1.5,+ time >= 1.4 && < 1.6,+ time-locale-compat >= 0.1 && < 0.2, old-locale, containers, text,