packages feed

taffybar 3.1.2 → 3.2.0

raw patch · 39 files changed

+495/−235 lines, 39 filesdep +ansi-terminaldep +broadcast-chandep ~scotty

Dependencies added: ansi-terminal, broadcast-chan

Dependency ranges changed: scotty

Files

CHANGELOG.md view
@@ -1,3 +1,45 @@+# 3.2.0++## New Features++ * The Layout widget can now be styled with the css class "layout-label".++ * A new polling label function `pollingLabelWithVariableDelay` that allows for+   variable poll times was added.++ * A new widget `System.Taffybar.Widget.SimpleCommandButton` was added.++ * Taffybar now outputs colorized and annotated logs by default.++## Breaking Changes++ * The file specified in the cssPath parameter in config is now used instead of,+   rather than in addition to the default user config file.++ * All parameters are now passed to `textClockNewWith` as part of the+   ClockConfig it receives. A new mechanism for rounded variable polling should+   allow the clock to always remain accurate (to the precision selected by the+   user) without having a very high polling rate, thus reducing CPU usage.++ * The polling label functions no longer accept a default text parameter.++## Miscellaneous++ * Battery updates are only triggered when a more limited number of UPower+   properties are changed. This can be customized by manually calling+   `setupDisplayBatteryChanVar` as a hook.++## Bug Fixes++ * Calendar pops up below bar without hiding any other widget #261.++ * Avoid failing when parsing XDG Desktop files with unrecognized application+   type, which previously resulted in "Prelude.read: no parse" #447.++ * Use XDG data dir so that taffybar dbus toggling functions correctly when+   taffybar is installed in a location that is not writable by the user. This is+   the case with nix when it is installed in the nix store #452.+ # 3.1.2  ## Updates
README.md view
@@ -72,6 +72,12 @@ list of available widgets [here](http://hackage.haskell.org/package/taffybar-2.0.0/docs/System-Taffybar-Widget.html) +FAQ+---++For the time being, taffybar's frequently asked questions page lives in [this+github issue](https://github.com/taffybar/taffybar/issues/332).+ Contributing ------------
src/System/Taffybar.hs view
@@ -117,7 +117,9 @@ import           System.Exit ( exitFailure ) import           System.FilePath ( (</>) ) import qualified System.IO as IO+import           System.Log.Logger import           System.Taffybar.Context+import           System.Taffybar.Hooks  import           Paths_taffybar ( getDataDir ) @@ -154,23 +156,29 @@   dataDir <- getDataDir   return (dataDir </> name) -startCSS :: Maybe FilePath -> IO Gtk.CssProvider-startCSS configCssPath = do+startCSS :: [FilePath] -> IO Gtk.CssProvider+startCSS cssPaths = 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 <- Gtk.cssProviderNew+   let loadIfExists filePath =         doesFileExist filePath >>=         flip when (Gtk.cssProviderLoadFromPath taffybarProvider (T.pack filePath))-  loadIfExists =<< getDefaultConfigFile "taffybar.css"-  mapM_ loadIfExists configCssPath-  loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css"++  mapM_ loadIfExists cssPaths+   Just scr <- Gdk.screenGetDefault   Gtk.styleContextAddProviderForScreen scr taffybarProvider 800   return taffybarProvider +getDefaultCSSPaths :: IO [FilePath]+getDefaultCSSPaths = do+  defaultUserConfig <- getUserConfigFile "taffybar" "taffybar.css"+  return [defaultUserConfig]+ -- | Start taffybar with the provided 'TaffybarConfig'. Because this function -- will not handle recompiling taffybar automatically when taffybar.hs is -- updated, it is generally recommended that end users use 'dyreTaffybar'@@ -179,10 +187,15 @@ -- perfectly fine to use this function. startTaffybar :: TaffybarConfig -> IO () startTaffybar config = do+  updateGlobalLogger "" $ removeHandler+  setTaffyLogFormatter "System.Taffybar"+  setTaffyLogFormatter "StatusNotifier"   _ <- initThreads   _ <- Gtk.init Nothing   GIThreading.setCurrentThreadAsGUIThread-  _ <- startCSS $ cssPath config+  defaultConfig <- getDefaultConfigFile "taffybar.css"+  cssPaths <- maybe getDefaultCSSPaths (return . return) $ cssPath config+  _ <- startCSS $ defaultConfig:cssPaths   _ <- buildContext config    Gtk.main
src/System/Taffybar/Context.hs view
@@ -167,9 +167,9 @@       show $ strutConfig barConfig    window <- Gtk.windowNew Gtk.WindowTypeToplevel-  box <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig+  box <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig   _ <- widgetSetClassGI box "taffy-box"-  centerBox <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig+  centerBox <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral $ widgetSpacing barConfig   Gtk.boxSetCenterWidget box (Just centerBox)    setupStrutWindow (strutConfig barConfig) window
src/System/Taffybar/DBus/Toggle.hs view
@@ -17,6 +17,7 @@  import           Control.Applicative import qualified Control.Concurrent.MVar as MV+import           Control.Exception import           Control.Monad import           Control.Monad.Trans.Class import           Control.Monad.Trans.Maybe@@ -29,9 +30,9 @@ import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk import           Graphics.UI.GIGtkStrut-import           Paths_taffybar ( getDataDir ) import           Prelude import           System.Directory+import           System.Environment.XDG.BaseDir import           System.FilePath.Posix import           System.Log.Logger import           System.Taffybar.Context hiding (logIO, logT)@@ -88,8 +89,11 @@ taffybarToggleInterface :: InterfaceName taffybarToggleInterface = "taffybar.toggle" +taffyDir :: IO FilePath+taffyDir = getUserDataDir "taffybar"+ toggleStateFile :: IO FilePath-toggleStateFile = (</> "toggleState.hs") <$> getDataDir+toggleStateFile = (</> "toggle_state.dat") <$> taffyDir  newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool)) @@ -110,13 +114,17 @@ exportTogglesInterface = do   TogglesMVar enabledVar <- getTogglesVar   ctx <- ask+  lift $ taffyDir >>= createDirectoryIfMissing True+  stateFile <- lift toggleStateFile   let toggleTaffyOnMon fn mon = flip runReaderT ctx $ do         lift $ MV.modifyMVar_ enabledVar $ \numToEnabled -> do           let current = fromMaybe True $ M.lookup mon numToEnabled               result = M.insert mon (fn current) numToEnabled-          logIO DEBUG $ printf "Toggle state before: %s" $ show numToEnabled-          logIO DEBUG $ printf "Toggle state after: %s" $ show result-          flip writeFile (show result) =<< toggleStateFile+          logIO DEBUG $ printf "Toggle state before: %s, after %s"+                  (show numToEnabled) (show result)+          catch (writeFile stateFile (show result)) $ \e ->+            logIO WARNING $ printf "Unable to write to toggle state file %s, error: %s"+                  (show stateFile) (show (e :: SomeException))           return result         refreshTaffyWindows       toggleTaffy = do
src/System/Taffybar/Hooks.hs view
@@ -2,12 +2,14 @@   ( module System.Taffybar.DBus   , module System.Taffybar.Hooks   , ChromeTabImageData(..)-  , refreshBatteriesOnPropChange-  , getX11WindowToChromeTabId   , getChromeTabImageDataChannel   , getChromeTabImageDataTable+  , getX11WindowToChromeTabId+  , refreshBatteriesOnPropChange+  , setTaffyLogFormatter   ) where +import           BroadcastChan import           Control.Applicative import           Control.Concurrent import           Control.Monad@@ -16,24 +18,31 @@ import           Data.Maybe import qualified Data.MultiMap as MM import           System.FilePath+import           System.Log.Logger import           System.Taffybar.Context import           System.Taffybar.DBus import           System.Taffybar.Information.Battery import           System.Taffybar.Information.Chrome import           System.Taffybar.Information.Network import           System.Taffybar.Information.XDG.DesktopEntry+import           System.Taffybar.LogFormatter import           System.Taffybar.Util -newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))])+newtype NetworkInfoChan = NetworkInfoChan (BroadcastChan In [(String, (Rational, Rational))])  buildInfoChan :: Double -> IO NetworkInfoChan buildInfoChan interval = do-  chan <- newChan-  _ <- forkIO $ monitorNetworkInterfaces interval $ writeChan chan+  chan <- newBroadcastChan+  _ <- forkIO $ monitorNetworkInterfaces interval (void . writeBChan chan)   return $ NetworkInfoChan chan  getNetworkChan :: TaffyIO NetworkInfoChan getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0++setTaffyLogFormatter :: String -> IO ()+setTaffyLogFormatter loggerName = do+  handler <- taffyLogHandler+  updateGlobalLogger loggerName $ setHandlers [handler]  withBatteryRefresh :: TaffybarConfig -> TaffybarConfig withBatteryRefresh = appendHook refreshBatteriesOnPropChange
src/System/Taffybar/Information/Battery.hs view
@@ -11,6 +11,7 @@   , module System.Taffybar.Information.Battery   ) where +import           BroadcastChan import           Control.Concurrent import           Control.Monad import           Control.Monad.IO.Class@@ -140,24 +141,33 @@     return $ filter isBattery paths  newtype DisplayBatteryChanVar =-  DisplayBatteryChanVar (Chan BatteryInfo, MVar BatteryInfo)+  DisplayBatteryChanVar (BroadcastChan In BatteryInfo, MVar BatteryInfo)  getDisplayBatteryInfo :: TaffyIO BatteryInfo getDisplayBatteryInfo = do   DisplayBatteryChanVar (_, theVar) <- getDisplayBatteryChanVar   lift $ readMVar theVar +defaultMonitorDisplayBatteryProperties :: [String]+defaultMonitorDisplayBatteryProperties = [ "IconName", "State", "Percentage" ]++-- | Start the monitoring of the display battery, and setup the associated+-- channel and mvar for the current state.+setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar+setupDisplayBatteryChanVar properties = getStateDefault $+  DisplayBatteryChanVar <$> monitorDisplayBattery properties+ getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar getDisplayBatteryChanVar =-  getStateDefault $ DisplayBatteryChanVar <$> monitorDisplayBattery+  setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties -getDisplayBatteryChan :: TaffyIO (Chan BatteryInfo)+getDisplayBatteryChan :: TaffyIO (BroadcastChan In BatteryInfo) getDisplayBatteryChan = do   DisplayBatteryChanVar (chan, _) <- getDisplayBatteryChanVar   return chan  updateBatteryInfo-  :: Chan BatteryInfo+  :: BroadcastChan In BatteryInfo   -> MVar BatteryInfo   -> ObjectPath   -> TaffyIO ()@@ -166,27 +176,37 @@   where     doWrites info =         batteryLogF DEBUG "Writing info %s" info >>-        swapMVar var info >> writeChan chan info+        swapMVar var info >> void (writeBChan chan info)     warnOfFailure = batteryLogF WARNING "Failed to update battery info %s"  registerForAnyUPowerPropertiesChanged   :: (Signal -> String -> Map String Variant -> [String] -> IO ())   -> ReaderT Context IO SignalHandler-registerForAnyUPowerPropertiesChanged signalHandler = do+registerForAnyUPowerPropertiesChanged = registerForUPowerPropertyChanges []++registerForUPowerPropertyChanges+  :: [String]+  -> (Signal -> String -> Map String Variant -> [String] -> IO ())+  -> ReaderT Context IO SignalHandler+registerForUPowerPropertyChanges properties signalHandler = do   client <- asks systemDBusClient   lift $ DBus.registerForPropertiesChanged       client       matchAny { matchInterface = Just uPowerDeviceInterfaceName }-      signalHandler+      handleIfPropertyMatches+  where handleIfPropertyMatches rawSignal n propertiesMap l =+          let propertyPresent prop = isJust $ M.lookup prop propertiesMap+          in when (any propertyPresent properties || null properties) $+             signalHandler rawSignal n propertiesMap l  -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects-monitorDisplayBattery :: TaffyIO (Chan BatteryInfo, MVar BatteryInfo)-monitorDisplayBattery = do+monitorDisplayBattery :: [String] -> TaffyIO (BroadcastChan In BatteryInfo, MVar BatteryInfo)+monitorDisplayBattery propertiesToMonitor = do   lift $ batteryLog DEBUG "Starting Battery Monitor"   client <- asks systemDBusClient   infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty-  chan <- lift newChan+  chan <- newBroadcastChan   taffyFork $ do     ctx <- ask     let warnOfFailedGetDevice err =@@ -199,7 +219,7 @@           do             batteryLogF DEBUG "Battery changed properties: %s" changedProps             runReaderT doUpdate ctx-    _ <- registerForAnyUPowerPropertiesChanged signalCallback+    _ <- registerForUPowerPropertyChanges propertiesToMonitor signalCallback     doUpdate     return ()   return (chan, infoVar)
src/System/Taffybar/Information/Chrome.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Information.Chrome where +import           BroadcastChan import           Control.Concurrent import           Control.Monad import           Control.Monad.Trans.Class@@ -29,14 +30,14 @@  newtype ChromeTabImageDataState =   ChromeTabImageDataState-  (MVar (M.Map Int ChromeTabImageData), Chan ChromeTabImageData)+  (MVar (M.Map Int ChromeTabImageData), BroadcastChan Out ChromeTabImageData)  getChromeTabImageDataState :: TaffyIO ChromeTabImageDataState getChromeTabImageDataState = do   ChromeFaviconServerPort port <- fromMaybe (ChromeFaviconServerPort 5000) <$> getState   getStateDefault (listenForChromeFaviconUpdates port) -getChromeTabImageDataChannel :: TaffyIO (Chan ChromeTabImageData)+getChromeTabImageDataChannel :: TaffyIO (BroadcastChan Out ChromeTabImageData) getChromeTabImageDataChannel = do   ChromeTabImageDataState (_, chan) <- getChromeTabImageDataState   return chan@@ -51,7 +52,8 @@ listenForChromeFaviconUpdates :: Int -> TaffyIO ChromeTabImageDataState listenForChromeFaviconUpdates port = do   infoVar <- lift $ newMVar M.empty-  chan <- lift newChan+  inChan <- newBroadcastChan+  outChan <- newBChanListener inChan   _ <- lift $ forkIO $ scotty port $     post "/setTabImageData/:tabID" $ do       tabID <- param "tabID"@@ -69,10 +71,10 @@               in                 modifyMVar_ infoVar $ \currentMap ->                   do-                    writeChan chan chromeTabImageData+                    _ <- writeBChan inChan chromeTabImageData                     return $ M.insert tabID chromeTabImageData currentMap         Gdk.pixbufLoaderGetPixbuf loader >>= maybe (return ()) updateChannelAndMVar-  return $ ChromeTabImageDataState (infoVar, chan)+  return $ ChromeTabImageDataState (infoVar, outChan)  newtype X11WindowToChromeTabId = X11WindowToChromeTabId (MVar (M.Map X11Window Int))
src/System/Taffybar/Information/Memory.hs view
@@ -15,7 +15,7 @@   , memorySwapFree :: Double   , memorySwapUsed :: Double -- swapTotal - swapFree   , memorySwapUsedRatio :: Double -- swapUsed / swapTotal-  , memoryAvailable :: Double -- An estimate of how much memory is available for starting new apps+  , memoryAvailable :: Double -- An estimate of how much memory is available   , memoryRest :: Double -- free + buffer + cache   , memoryUsed :: Double -- total - rest   , memoryUsedRatio :: Double -- used / total
src/System/Taffybar/Information/Network.hs view
@@ -106,7 +106,9 @@       doUpdate = MV.modifyMVar_ samplesVar ((>>= doOnUpdate) . updateSamples)   foreverWithDelay interval doUpdate -updateSamples :: [(String, (TxSample, TxSample))] -> IO [(String, (TxSample, TxSample))]+updateSamples ::+  [(String, (TxSample, TxSample))] ->+  IO [(String, (TxSample, TxSample))] updateSamples currentSamples = do   let getLast sample@TxSample { sampleDevice = device } =         maybe sample fst $ lookup device currentSamples
src/System/Taffybar/Information/SafeX11.hs view
@@ -35,8 +35,12 @@ import Prelude import System.IO import System.IO.Unsafe+import System.Log.Logger import System.Timeout+import Text.Printf +logHere = logM "System.Taffybar.Information.SafeX11"+ foreign import ccall safe "XlibExtras.h XGetWMHints"     safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints) @@ -124,9 +128,9 @@ startHandlingX11Requests =   withErrorHandler handleError handleX11Requests   where handleError _ xerrptr = do-          putStrLn "Got error"           ee <- getErrorEvent xerrptr-          print ee+          logHere WARNING $+                  printf "Handling X11 error with error handler: %s" $ show ee  handleX11Requests :: IO () handleX11Requests = do@@ -136,9 +140,8 @@     catch       (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)       (\e -> do-         putStrLn "Got error on X11 thread"-         hFlush stdout-         print (e :: IOException)+         logHere WARNING $ printf "Handling X11 error with catch: %s" $+                 show (e :: IOException)          return $ Left SafeX11Exception)   writeChan responseChannel res   handleX11Requests
src/System/Taffybar/Information/XDG/DesktopEntry.hs view
@@ -46,16 +46,15 @@ import           System.Log.Logger import           System.Posix.Files import           Text.Printf+import           Text.Read (readMaybe) +logHere = logM "System.Taffybar.Information.XDG.DesktopEntry"+ data DesktopEntryType = Application | Link | Directory   deriving (Read, Show, Eq)  existingDirs :: [FilePath] -> IO [FilePath]-existingDirs  dirs = do-  exs <- mapM fileExist dirs-  let exDirs = nub $ map fst $ filter snd $ zip dirs exs-  mapM_ (putStrLn . ("Directory does not exist: " ++)) $ dirs \\ exDirs-  return exDirs+existingDirs  dirs = filterM fileExist dirs  getDefaultConfigHome :: IO FilePath getDefaultConfigHome = do@@ -182,8 +181,7 @@ -- | Retrieve a desktop entry with a specific name. getDirectoryEntry :: [FilePath] -> String -> IO (Maybe DesktopEntry) getDirectoryEntry dirs name = do-  liftIO $ logM "System.Taffybar.Information.XDG.DesktopEntry" DEBUG $-           printf "Searching %s for %s" (show dirs) name+  liftIO $ logHere DEBUG $ printf "Searching %s for %s" (show dirs) name   exFiles <- filterM doesFileExist $ map ((</> name) . normalise) dirs   if null exFiles   then return Nothing@@ -206,27 +204,16 @@  -- | 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+readDesktopEntry filePath = doReadDesktopEntry >>= either logWarning (return . Just)   where-    doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)-    doReadDesktopEntry f = do-      eResult <--        runExceptT $ do-          cp <- join $ liftIO $ CF.readfile CF.emptyCP f-          CF.items cp sectionMain-      case eResult of-        Left _ -> return Nothing-        Right r ->-          return $-          Just-            DesktopEntry-            { deType = maybe Application read (lookup "Type" r)-            , deFilename = f-            , deAttributes = r-            }+    logWarning error =+      logHere  WARNING (printf "Failed to parse desktop entry at %s" filePath) >>+               return Nothing+    doReadDesktopEntry = runExceptT $ do+         result <- (join $ liftIO $ CF.readfile CF.emptyCP filePath) >>=+                   flip CF.items sectionMain+         return DesktopEntry+                { deType = fromMaybe Application $ lookup "Type" result >>= readMaybe+                , deFilename = filePath+                , deAttributes = result+                }
src/System/Taffybar/Information/XDG/Protocol.hs view
@@ -39,6 +39,7 @@ import           System.Directory import           System.Environment import           System.FilePath.Posix+import           System.Log.Logger import           System.Taffybar.Information.XDG.DesktopEntry import           System.Taffybar.Util import           Text.XML.Light@@ -250,13 +251,13 @@ 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)+       (do+         logM "System.Taffybar.Information.XDG.Protocol" WARNING $+                "Menu file '" ++ filename ++ "' does not exist!"+         return Nothing)
+ src/System/Taffybar/LogFormatter.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.LogFormatter+-- Copyright   : (c) Ivan A. Malison+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ivan A. Malison+-- Stability   : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.LogFormatter where++import System.Console.ANSI+import System.Log.Formatter+import System.Log.Handler.Simple+import System.Log.Logger+import Text.Printf+import System.IO+import Data.Monoid++setColor :: Color -> String+setColor color = setSGRCode [SetColor Foreground Vivid color]++priorityToColor :: Priority -> Color+priorityToColor CRITICAL = Red+priorityToColor ALERT = Red+priorityToColor EMERGENCY = Red+priorityToColor ERROR = Red+priorityToColor WARNING = Yellow+priorityToColor NOTICE = Magenta+priorityToColor INFO = Blue+priorityToColor DEBUG = Green++reset :: String+reset = setSGRCode [Reset]++colorize color txt = setColor color <> txt <> reset++taffyLogFormatter :: LogFormatter a+taffyLogFormatter _ (priority, msg) name =+  return $ printf "%s %s - %s" colorizedPriority colorizedName msg+    where priorityColor = priorityToColor priority+          colorizedPriority = colorize priorityColor+                              ("[" <> show priority <> "]")+          colorizedName = colorize Green name++taffyLogHandler = setFormatter <$> streamHandler stderr DEBUG+  where setFormatter h = h { formatter = taffyLogFormatter }
src/System/Taffybar/SimpleConfig.hs view
@@ -30,7 +30,7 @@ import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar import qualified System.Taffybar.Context as BC (BarConfig(..), TaffybarConfig(..))-import           System.Taffybar.Context hiding (BarConfig(..), cssPath)+import           System.Taffybar.Context hiding (TaffybarConfig(..), BarConfig(..)) import           System.Taffybar.Util  -- | The side of the monitor at which taffybar should be displayed.@@ -51,15 +51,17 @@   , barPosition :: Position   -- | The number of pixels between widgets   , widgetSpacing :: Int-  -- | Widget constructors whose results are placed at the beginning of the bar+  -- | Widget constructors whose output are placed at the beginning of the bar   , startWidgets :: [TaffyIO Gtk.Widget]-  -- | Widget constructors whose results will be placed in the center of the bar+  -- | Widget constructors whose output are placed in the center of the bar   , centerWidgets :: [TaffyIO Gtk.Widget]-  -- | Widget constructors whose results are placed at the end of the bar+  -- | Widget constructors whose output are placed at the end of the bar   , endWidgets :: [TaffyIO Gtk.Widget]   -- | Optional path to CSS stylesheet (loaded in addition to stylesheet found   -- in XDG data directory).   , cssPath :: Maybe FilePath+  -- | Hook to run at taffybar startup.+  , startupHook :: TaffyIO ()   }  -- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll@@ -76,6 +78,7 @@   , centerWidgets = []   , endWidgets = []   , cssPath = Nothing+  , startupHook = return ()   }  toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig@@ -111,11 +114,13 @@  newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)]) -toTaffyConfig :: SimpleTaffyConfig -> TaffybarConfig+toTaffyConfig :: SimpleTaffyConfig -> BC.TaffybarConfig toTaffyConfig conf =-    defaultTaffybarConfig { getBarConfigsParam = configGetter-                          , BC.cssPath = cssPath conf-                          }+    defaultTaffybarConfig+    { BC.getBarConfigsParam = configGetter+    , BC.cssPath = cssPath conf+    , BC.startupHook = startupHook conf+    }   where     configGetter = do       SimpleBarConfigs configsVar <-
src/System/Taffybar/Util.hs view
@@ -85,9 +85,14 @@     ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr  -- | Execute the provided IO action at the provided interval.-foreverWithDelay :: RealFrac a1 => a1 -> IO a -> IO ThreadId+foreverWithDelay :: RealFrac d => d -> IO a -> IO ThreadId foreverWithDelay delay action =-  forkIO $ forever $ action >> threadDelay (floor $ delay * 1000000)+  foreverWithVariableDelay $ action >> return delay++foreverWithVariableDelay :: RealFrac d => IO d -> IO ThreadId+foreverWithVariableDelay action = forkIO $ action >>= delayThenAction+  where delayThenAction delay =+          threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction  liftActionTaker   :: (Monad m)
src/System/Taffybar/Widget.hs view
@@ -39,11 +39,11 @@   , module System.Taffybar.Widget.SNITray    -- * "System.Taffybar.Widget.SimpleClock"-  , textClockNew-  , textClockNewWith-  , defaultClockConfig-  , ClockConfig(..)+  , module System.Taffybar.Widget.SimpleClock +  -- * "System.Taffybar.Widget.SimpleCommandButton"+  , simpleCommandButtonNew+   -- * "System.Taffybar.Widget.Text.CPUMonitor"   , module System.Taffybar.Widget.Text.CPUMonitor @@ -87,6 +87,7 @@ import System.Taffybar.Widget.NetworkGraph import System.Taffybar.Widget.SNITray import System.Taffybar.Widget.SimpleClock+import System.Taffybar.Widget.SimpleCommandButton import System.Taffybar.Widget.Text.CPUMonitor import System.Taffybar.Widget.Text.MemoryMonitor import System.Taffybar.Widget.Text.NetworkMonitor
src/System/Taffybar/Widget/CommandRunner.hs view
@@ -34,8 +34,7 @@   -> T.Text -- ^ If command fails this will be displayed.   -> m GI.Gtk.Widget commandRunnerNew interval cmd args defaultOutput =-  pollingLabelNew "" interval $-  runCommandWithDefault cmd args defaultOutput+  pollingLabelNew interval $ runCommandWithDefault cmd args defaultOutput  runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text runCommandWithDefault cmd args def =
src/System/Taffybar/Widget/Decorators.hs view
@@ -11,7 +11,7 @@ -- for the purpose of displaying a different background behind the widget. buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildPadBox contents = liftIO $ do-  innerBox <- Gtk.hBoxNew False 0+  innerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0   outerBox <- Gtk.eventBoxNew   Gtk.containerAdd innerBox contents   Gtk.containerAdd outerBox innerBox@@ -23,7 +23,7 @@  buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildContentsBox widget = liftIO $ do-  contents <- Gtk.hBoxNew False 0+  contents <- Gtk.boxNew Gtk.OrientationHorizontal 0   Gtk.containerAdd contents widget   _ <- widgetSetClassGI contents "contents"   Gtk.widgetShowAll contents
src/System/Taffybar/Widget/FSMonitor.hs view
@@ -32,7 +32,7 @@   -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])   -> m GI.Gtk.Widget fsMonitorNew interval fsList = liftIO $ do-  label <- pollingLabelNew "" interval $ showFSInfo fsList+  label <- pollingLabelNew interval $ showFSInfo fsList   GI.Gtk.widgetShowAll label   GI.Gtk.toWidget label
src/System/Taffybar/Widget/FreedesktopNotifications.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This widget listens on DBus for freedesktop notifications--- (http://developer.gnome.org/notification-spec/).  Currently it is+-- (<http://developer.gnome.org/notification-spec/>).  Currently it is -- somewhat ugly, but the format is somewhat configurable.  A visual -- overhaul of the widget is coming. --@@ -28,6 +28,7 @@   , notifyAreaNew   ) where +import           BroadcastChan import           Control.Concurrent import           Control.Concurrent.STM import           Control.Monad ( forever, void )@@ -64,14 +65,14 @@   , noteConfig :: NotificationConfig -- ^ The associated configuration   , noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications   , noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids-  , noteChan :: Chan () -- ^ Writing to this channel wakes up the display thread+  , noteChan :: BroadcastChan In () -- ^ 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-  ch <- newChan+  ch <- newBroadcastChan   return NotifyState { noteQueue = q                      , noteIdSource = m                      , noteWidget = l@@ -172,19 +173,21 @@  -------------------------------------------------------------------------------- wakeupDisplayThread :: NotifyState -> IO ()-wakeupDisplayThread s = writeChan (noteChan s) ()+wakeupDisplayThread s = void $ writeBChan (noteChan s) ()  -- | Refreshes the GUI displayThread :: NotifyState -> IO ()-displayThread s = forever $ do-  () <- 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)+displayThread s = do+  chan <- newBChanListener (noteChan s)+  forever $ do+    _ <- readBChan chan+    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)   where     formatMessage NotificationConfig {..} ns =       T.take notificationMaxLength $ notificationFormatter ns@@ -234,7 +237,7 @@ notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget notifyAreaNew cfg = liftIO $ do   frame <- frameNew Nothing-  box <- hBoxNew False 3+  box <- boxNew OrientationHorizontal 3   textArea <- labelNew (Nothing :: Maybe Text)   button <- eventBoxNew   sep <- separatorNew OrientationHorizontal@@ -259,7 +262,7 @@   s <- initialNoteState w textArea cfg   _ <- onWidgetButtonReleaseEvent button (userCancel s) -  realizableWrapper <- hBoxNew False 0+  realizableWrapper <- boxNew OrientationHorizontal 0   boxPackStart realizableWrapper frame False False 0   widgetShow realizableWrapper
src/System/Taffybar/Widget/Generic/ChannelGraph.hs view
@@ -1,20 +1,22 @@ module System.Taffybar.Widget.Generic.ChannelGraph where +import BroadcastChan import Control.Concurrent import Control.Monad import Control.Monad.IO.Class+import Data.Foldable (traverse_) import GI.Gtk import System.Taffybar.Widget.Generic.Graph  channelGraphNew   :: MonadIO m-  => GraphConfig -> Chan a -> (a -> IO [Double]) -> m GI.Gtk.Widget+  => GraphConfig -> BroadcastChan In a -> (a -> IO [Double]) -> m GI.Gtk.Widget channelGraphNew config chan sampleBuilder = do   (graphWidget, graphHandle) <- graphNew config   _ <- onWidgetRealize graphWidget $ do-       ourChan <- dupChan chan-       sampleThread <- forkIO $ forever $ do-         value <- readChan ourChan-         sampleBuilder value >>= graphAddSample graphHandle+       ourChan <- newBChanListener chan+       sampleThread <- forkIO $ forever $+         readBChan ourChan >>=+         traverse_ (graphAddSample graphHandle <=< sampleBuilder)        void $ onWidgetUnrealize graphWidget $ killThread sampleThread   return graphWidget
src/System/Taffybar/Widget/Generic/ChannelWidget.hs view
@@ -1,16 +1,18 @@ module System.Taffybar.Widget.Generic.ChannelWidget where +import BroadcastChan import Control.Concurrent import Control.Monad import Control.Monad.IO.Class+import Data.Foldable (traverse_) import GI.Gtk -channelWidgetNew :: (MonadIO m, IsWidget w) => w -> Chan a -> (a -> IO ()) -> m w+channelWidgetNew :: (MonadIO m, IsWidget w) => w -> BroadcastChan In a -> (a -> IO ()) -> m w channelWidgetNew widget channel updateWidget = do   void $ onWidgetRealize widget $ do-    ourChan <- dupChan channel+    ourChan <- newBChanListener channel     processingThreadId <- forkIO $ forever $-      readChan ourChan >>= updateWidget+      readBChan ourChan >>= traverse_ updateWidget     void $ onWidgetUnrealize widget $ killThread processingThreadId   widgetShowAll widget   return widget
src/System/Taffybar/Widget/Generic/Graph.hs view
@@ -228,7 +228,7 @@    Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1)   _ <- Gtk.onWidgetDraw drawArea (\ctx -> renderWithContext (drawGraph mv drawArea) ctx >> return True)-  box <- Gtk.hBoxNew False 1+  box <- Gtk.boxNew Gtk.OrientationHorizontal 1    case graphLabel cfg of     Nothing  -> return ()
src/System/Taffybar/Widget/Generic/Icon.hs view
@@ -51,7 +51,7 @@  putInBox :: IsWidget child => child -> IO Widget putInBox icon = do-  box <- hBoxNew False 0+  box <- boxNew OrientationHorizontal 0   boxPackStart box icon False False 0   widgetShowAll box   toWidget box
src/System/Taffybar/Widget/Generic/PollingLabel.hs view
@@ -1,18 +1,17 @@ -- | This is a simple text widget that updates its contents by calling -- a callback at a set interval.-module System.Taffybar.Widget.Generic.PollingLabel-  ( pollingLabelNew-  , pollingLabelNewWithTooltip-  ) where+module System.Taffybar.Widget.Generic.PollingLabel where  import           Control.Concurrent import           Control.Exception.Enclosed as E import           Control.Monad import           Control.Monad.IO.Class-import           System.Taffybar.Util import qualified Data.Text as T import           GI.Gtk+import           System.Log.Logger+import           System.Taffybar.Util import           System.Taffybar.Widget.Util+import           Text.Printf  -- | Create a new widget that updates itself at regular intervals.  The -- function@@ -29,31 +28,42 @@ -- not update until the update interval expires. pollingLabelNew   :: MonadIO m-  => T.Text -- ^ Initial value for the label-  -> Double -- ^ Update interval (in seconds)+  => Double -- ^ Update interval (in seconds)   -> IO T.Text -- ^ Command to run to get the input string   -> m GI.Gtk.Widget-pollingLabelNew initialString interval cmd =-  pollingLabelNewWithTooltip initialString interval $ (, Nothing) <$> cmd+pollingLabelNew interval cmd =+  pollingLabelNewWithTooltip interval $ (, Nothing) <$> cmd  pollingLabelNewWithTooltip   :: MonadIO m-  => T.Text -- ^ Initial value for the label-  -> Double -- ^ Update interval (in seconds)+  => Double -- ^ Update interval (in seconds)   -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string   -> m GI.Gtk.Widget-pollingLabelNewWithTooltip initialString interval cmd =+pollingLabelNewWithTooltip interval action =+  pollingLabelWithVariableDelay $ withInterval <$> action+    where withInterval (a, b) = (a, b, interval)++pollingLabelWithVariableDelay+  :: MonadIO m+  => IO (T.Text, Maybe T.Text, Double)+  -> m GI.Gtk.Widget+pollingLabelWithVariableDelay action =   liftIO $ do     grid <- gridNew-    label <- labelNew $ Just initialString+    label <- labelNew Nothing -    let updateLabel (labelStr, tooltipStr) =+    let updateLabel (labelStr, tooltipStr, delay) = do           postGUIASync $ do-            labelSetMarkup label labelStr-            widgetSetTooltipMarkup label tooltipStr+             labelSetMarkup label labelStr+             widgetSetTooltipMarkup label tooltipStr+          logM "System.Taffybar.Widget.Generic.PollingLabel" DEBUG $+               printf "Polling label delay was %s" $ show delay+          return delay+        updateLabelHandlingErrors =+          E.tryAny action >>= either (const $ return 1) updateLabel      _ <- onWidgetRealize label $ do-      sampleThread <- foreverWithDelay interval $ E.tryAny cmd >>= either (const $ return ()) updateLabel+      sampleThread <- foreverWithVariableDelay updateLabelHandlingErrors       void $ onWidgetUnrealize label $ killThread sampleThread      vFillCenter label
src/System/Taffybar/Widget/Generic/VerticalBar.hs view
@@ -174,7 +174,7 @@       }   widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1)   _ <- onWidgetDraw drawArea $ \ctx -> renderWithContext (drawBar mv drawArea) ctx >> return True-  box <- hBoxNew False 1+  box <- boxNew OrientationHorizontal 1   boxPackStart box drawArea True True 0   widgetShowAll box   giBox <- toWidget box
src/System/Taffybar/Widget/Layout.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module      : System.Taffybar.Widget.Layout@@ -31,6 +32,7 @@ import           System.Taffybar.Context import           System.Taffybar.Information.X11DesktopInfo import           System.Taffybar.Util+import           System.Taffybar.Widget.Util  -- $usage --@@ -69,6 +71,7 @@ layoutNew config = do   ctx <- ask   label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text)+  _ <- widgetSetClassGI label "layout-label"    -- This callback is run in a separate thread and needs to use   -- postGUIASync
src/System/Taffybar/Widget/MPRIS2.hs view
@@ -11,7 +11,7 @@ -- -- This is a "Now Playing" widget that listens for MPRIS2 events on DBus. You -- can find the MPRIS2 specification here at--- (https://specifications.freedesktop.org/mpris-spec/latest/).+-- (<https://specifications.freedesktop.org/mpris-spec/latest/>). ----------------------------------------------------------------------------- module System.Taffybar.Widget.MPRIS2 ( mpris2New ) where
src/System/Taffybar/Widget/SimpleClock.hs view
@@ -1,37 +1,45 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-}---- | This module implements a very simple text-based clock widget.--- The widget also toggles a calendar widget when clicked.  This--- calendar is not fancy at all and has no data backend. module System.Taffybar.Widget.SimpleClock   ( textClockNew   , textClockNewWith   , defaultClockConfig   , ClockConfig(..)+  , ClockUpdateStrategy(..)   ) where  import           Control.Monad.IO.Class+import           Data.Maybe+import qualified Data.Text as T import           Data.Time.Calendar ( toGregorian ) import qualified Data.Time.Clock as Clock import           Data.Time.Format import           Data.Time.LocalTime import qualified Data.Time.Locale.Compat as L-import GI.Gtk-import qualified GI.Gdk as D+import qualified GI.Gdk as Gdk+import           GI.Gtk import           System.Taffybar.Widget.Generic.PollingLabel import           System.Taffybar.Widget.Util-import qualified Data.Text as T +diffLocalTime :: LocalTime -> LocalTime -> Clock.NominalDiffTime+diffLocalTime a b = Clock.diffUTCTime (localTimeToUTC utc a) (localTimeToUTC utc b)++-- | addLocalTime a b = a + b+addLocalTime :: Clock.NominalDiffTime -> LocalTime -> LocalTime+addLocalTime x = utcToLocalTime utc . Clock.addUTCTime x . localTimeToUTC utc++-- | This module implements a very simple text-based clock widget. The widget+-- also toggles a calendar widget when clicked. This calendar is not fancy at+-- all and has no data backend.+ makeCalendar :: IO TimeZone -> IO Window makeCalendar tzfn = do   container <- windowNew WindowTypeToplevel   cal <- calendarNew   containerAdd container cal-  -- update the date on show   _ <- onWidgetShow container $ resetCalendarDate cal tzfn-  -- prevent calendar from being destroyed, it can be only hidden:+  -- Hide the calendar instead of destroying it   _ <- onWidgetDeleteEvent container $ \_ -> widgetHide container >> return True   return container @@ -55,36 +63,48 @@  -- | 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 :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget-textClockNew userLocale =+-- (<http://developer.gnome.org/pango/stable/PangoMarkupFormat.html>).+textClockNew ::+  MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget+textClockNew userLocale format interval =   textClockNewWith cfg   where-    cfg = defaultClockConfig { clockTimeLocale = userLocale }+    cfg = defaultClockConfig { clockTimeLocale = userLocale+                             , clockFormatString = format+                             , clockUpdateStrategy = ConstantInterval interval+                             } -data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone-                               , clockTimeLocale :: Maybe L.TimeLocale-                               }-                               deriving (Eq, Ord, Show)+data ClockUpdateStrategy+  = ConstantInterval Double+  | RoundedTargetInterval Int Double+  deriving (Eq, Ord, Show) +data ClockConfig = ClockConfig+  { clockTimeZone :: Maybe TimeZone+  , clockTimeLocale :: Maybe L.TimeLocale+  , clockFormatString :: String+  , clockUpdateStrategy :: ClockUpdateStrategy+  } deriving (Eq, Ord, Show)+ -- | A clock configuration that defaults to the current locale defaultClockConfig :: ClockConfig-defaultClockConfig = ClockConfig Nothing Nothing--data TimeInfo = TimeInfo { getTZ :: IO TimeZone-                         , getLocale :: IO L.TimeLocale-                         }+defaultClockConfig = ClockConfig+  { clockTimeZone = Nothing+  , clockTimeLocale = Nothing+  , clockFormatString = "%a %b %_d %r"+  , clockUpdateStrategy = RoundedTargetInterval 5 0.0+  }  systemGetTZ :: IO TimeZone systemGetTZ = setTZ >> getCurrentTimeZone --- | Old versions of time do not call localtime_r properly.  We set--- the time zone manually, if required.+-- | Old versions of time do not call localtime_r properly. We set the time zone+-- manually, if required. setTZ :: IO () #if MIN_VERSION_time(1, 4, 2) setTZ = return () #else-setTZ = c_tzset+setTZ = c_tzsetp  foreign import ccall unsafe "time.h tzset"   c_tzset :: IO ()@@ -94,27 +114,55 @@ -- a configurable time zone through the 'ClockConfig'. -- -- See also 'textClockNew'.-textClockNewWith :: MonadIO m => ClockConfig -> String -> Double -> m Widget-textClockNewWith cfg fmt updateSeconds = liftIO $ do-  let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone-                    , getLocale = maybe (return L.defaultTimeLocale) return userLocale-                    }-  l    <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt)+textClockNewWith :: MonadIO m => ClockConfig -> m Widget+textClockNewWith ClockConfig+                   { clockTimeZone = userZone+                   , clockTimeLocale = userLocale+                   , clockFormatString = formatString+                   , clockUpdateStrategy = updateStrategy+                   } = liftIO $ do+  let getTZ = maybe systemGetTZ return userZone+      locale = fromMaybe L.defaultTimeLocale userLocale++  let getUserZonedTime =+        utcToZonedTime <$> getTZ <*> Clock.getCurrentTime++      doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime++      getRoundedTimeAndNextTarget = do+        zonedTime <- getUserZonedTime+        return $ case updateStrategy of+          ConstantInterval interval ->+            (doTimeFormat zonedTime, Nothing, interval)+          RoundedTargetInterval roundSeconds offset ->+            let roundSecondsDiffTime = fromIntegral roundSeconds+                addTheRound = addLocalTime roundSecondsDiffTime+                localTime = zonedTimeToLocalTime zonedTime+                ourLocalTimeOfDay = localTimeOfDay localTime+                seconds = round $ todSec ourLocalTimeOfDay+                secondsFactor = seconds `div` roundSeconds+                displaySeconds = secondsFactor * roundSeconds+                baseLocalTimeOfDay =+                  ourLocalTimeOfDay { todSec = fromIntegral displaySeconds }+                ourLocalTime =+                  localTime { localTimeOfDay = baseLocalTimeOfDay }+                roundedLocalTime =+                  if seconds `mod` roundSeconds > roundSeconds `div` 2+                  then addTheRound ourLocalTime+                  else ourLocalTime+                roundedZonedTime =+                  zonedTime { zonedTimeToLocalTime = roundedLocalTime }+                nextTarget = addTheRound ourLocalTime+                amountToWait = realToFrac $ diffLocalTime nextTarget localTime+            in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset)++  label <- pollingLabelWithVariableDelay getRoundedTimeAndNextTarget   ebox <- eventBoxNew-  containerAdd ebox l+  containerAdd ebox label   eventBoxSetVisibleWindow ebox False-  cal <- makeCalendar $ getTZ ti-  _ <- onWidgetButtonPressEvent ebox $ onClick [D.EventTypeButtonPress] (toggleCalendar l cal)+  cal <- makeCalendar getTZ+  _ <- onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $+       toggleCalendar label cal   widgetShowAll ebox   toWidget ebox-  where-    userZone = clockTimeZone cfg-    userLocale = clockTimeLocale cfg-    -- alternate getCurrentTime that takes a specific TZ-    getCurrentTime' :: TimeInfo -> String -> IO T.Text-    getCurrentTime' ti f = do-      l <- getLocale ti-      z <- getTZ ti-      t <- Clock.getCurrentTime-      return $ T.pack $ formatTime l f $ utcToZonedTime z t
+ src/System/Taffybar/Widget/SimpleCommandButton.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module      : System.Taffybar.Widget.SimpleCommandButton+-- Copyright   : (c) Ulf Jasper+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Ulf Jasper <ulf.jasper@web.de>+-- Stability   : unstable+-- Portability : unportable+--+-- Simple button which runs a user defined command when being clicked+--------------------------------------------------------------------------------++module System.Taffybar.Widget.SimpleCommandButton (+  -- * Usage+  -- $usage+  simpleCommandButtonNew)+where++import           Control.Monad.IO.Class+import           GI.Gtk+import           System.Process+import qualified Data.Text as T++-- $usage+--+-- In order to use this widget add the following line to your+-- @taffybar.hs@ file:+--+-- > import System.Taffybar.Widget+-- > main = do+-- >   let cmdButton = simpleCommandButtonNew "Hello World!" "xterm -e \"echo Hello World!; read x\""+--+-- Now you can use @cmdButton@ like any other Taffybar widget.++-- | Creates a new simple command button.+simpleCommandButtonNew :: MonadIO m =>+                          T.Text -- ^ Contents of the button's label.+                       -> T.Text -- ^ Command to execute. Should be in $PATH or an absolute path+                       -> m Widget+simpleCommandButtonNew  txt cmd = do+  but <- buttonNewWithLabel txt+  _ <- onButtonClicked but $ spawnCommand (T.unpack cmd) >> return ()+  toWidget but+
src/System/Taffybar/Widget/Text/CPUMonitor.hs view
@@ -5,7 +5,6 @@ import System.Taffybar.Information.CPU import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk-import qualified Data.Text as T  -- | Creates a simple textual CPU monitor. It updates once every polling -- period (in seconds).@@ -13,7 +12,7 @@                   -> Double -- ^ Polling period (in seconds)                   -> IO GI.Gtk.Widget textCpuMonitorNew fmt period = do-  label <- pollingLabelNew (T.pack fmt) period callback+  label <- pollingLabelNew period callback   GI.Gtk.widgetShowAll label   return label   where
src/System/Taffybar/Widget/Text/MemoryMonitor.hs view
@@ -4,7 +4,6 @@ import System.Taffybar.Information.Memory import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) import qualified GI.Gtk-import qualified Data.Text as T  -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds).@@ -12,7 +11,7 @@                      -> Double -- ^ Polling period in seconds.                      -> IO GI.Gtk.Widget textMemoryMonitorNew fmt period = do-    label <- pollingLabelNew (T.pack fmt) period callback+    label <- pollingLabelNew period callback     GI.Gtk.widgetShowAll label     return label     where
src/System/Taffybar/Widget/Util.hs view
@@ -17,7 +17,6 @@ import           Control.Concurrent ( forkIO ) import           Control.Monad import           Control.Monad.IO.Class-import           Control.Monad.Trans.Maybe import           Data.Functor ( ($>) ) import           Data.Int import qualified Data.Text as T@@ -79,7 +78,8 @@ displayPopup widget window = do   windowSetPosition window WindowPositionMouse   (x, y ) <- windowGetPosition window-  (_, y') <- widgetGetSizeRequest widget+  (_, natReq) <- widgetGetPreferredSize =<< widgetGetToplevel widget+  y' <- getRequisitionHeight natReq   widgetShowAll window   if y > y'     then windowMove window x (y - y')
src/System/Taffybar/Widget/Weather.hs view
@@ -73,16 +73,17 @@ import qualified Data.ByteString.Lazy as LB import Data.List (stripPrefix) import Data.Maybe (fromMaybe)-import GI.Gtk+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import GI.GLib(markupEscapeText)+import GI.Gtk import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status+import System.Log.Logger import Text.Parsec import Text.Printf import Text.StringTemplate-import qualified Data.Text as T-import qualified Data.Text.Encoding as T  import System.Taffybar.Widget.Generic.PollingLabel @@ -243,7 +244,7 @@           lbl <- markupEscapeText rawLabel (-1)           return (lbl, Just lbl)     Left err -> do-      putStrLn err+      logM "System.Taffybar.Widget.Weather" ERROR $ "Error in weather: " <> show err       return ("N/A", Nothing)  -- | The NOAA URL to get data from@@ -329,7 +330,7 @@   let labelTpl' = newSTMP labelTpl       tooltipTpl' = newSTMP tooltipTpl -  l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60)+  l <- pollingLabelNewWithTooltip (delayMinutes * 60)        (getCurrentWeather getter labelTpl' tooltipTpl' formatter)    GI.Gtk.widgetShowAll l
src/System/Taffybar/Widget/Workspaces.hs view
@@ -88,7 +88,7 @@ data WorkspacesContext = WorkspacesContext   { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)   , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)-  , workspacesWidget :: Gtk.HBox+  , workspacesWidget :: Gtk.Box   , workspacesConfig :: WorkspacesConfig   , taffyContext :: Context   }@@ -206,7 +206,8 @@   workspacesRef <- asks workspacesVar   updateVar workspacesRef buildWorkspaceData -getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window)+getWorkspaceToWindows ::+  [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window) getWorkspaceToWindows =   foldM     (\theMap window ->@@ -285,7 +286,7 @@      -- 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+    hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0     parent <- Gtk.widgetGetParent workspaceWidget     if isJust parent       then Gtk.widgetReparent workspaceWidget hbox@@ -294,7 +295,7 @@  workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget workspacesNew cfg = ask >>= \tContext -> lift $ do-  cont <- Gtk.hBoxNew False $ fromIntegral (widgetGap cfg)+  cont <- Gtk.boxNew Gtk.OrientationHorizontal $ fromIntegral (widgetGap cfg)   controllersRef <- MV.newMVar M.empty   workspacesRef <- MV.newMVar M.empty   let context =@@ -464,7 +465,7 @@   controllers <- mapM ($ ws) constructors   ctx <- ask   tempController <- lift $ do-    cons <- Gtk.hBoxNew False 0+    cons <- Gtk.boxNew Gtk.OrientationHorizontal 0     mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers     outerBox <- Gtk.toWidget cons >>= buildPadBox     _ <- widgetSetClassGI cons "contents"@@ -570,7 +571,7 @@       }  data IconController = IconController-  { iconsContainer :: Gtk.HBox+  { iconsContainer :: Gtk.Box   , iconImages :: [IconWidget]   , iconWorkspace :: Workspace   }@@ -579,7 +580,7 @@ buildIconController ws = do   tempController <-     lift $ do-      hbox <- Gtk.hBoxNew False 0+      hbox <- Gtk.boxNew Gtk.OrientationHorizontal 0       return         IconController         {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}@@ -593,9 +594,8 @@   updateWidget ic (IconUpdate updatedIcons) =     updateWindowIconsById ic updatedIcons >> return ic -updateWindowIconsById :: IconController-                      -> [X11Window]-                      -> WorkspacesIO ()+updateWindowIconsById ::+  IconController -> [X11Window] -> WorkspacesIO () updateWindowIconsById ic windowIds =   mapM_ maybeUpdateWindowIcon $ iconImages ic   where@@ -610,9 +610,8 @@   getter size >=>   lift . traverse (scalePixbufToSize size Gtk.OrientationHorizontal) -constantScaleWindowIconPixbufGetter :: Int32-                                    -> WindowIconPixbufGetter-                                    -> WindowIconPixbufGetter+constantScaleWindowIconPixbufGetter ::+  Int32 -> WindowIconPixbufGetter -> WindowIconPixbufGetter constantScaleWindowIconPixbufGetter constantSize getter =   const $ scaledWindowIconPixbufGetter getter constantSize @@ -670,7 +669,9 @@ sortWindowsByPosition wins = do   let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)       getGeometries = mapM-                      (forkM return ((((sel2 &&& sel3) <$>) .) getGeometryWorkspaces) . windowId)+                      (forkM return+                               ((((sel2 &&& sel3) <$>) .) getGeometryWorkspaces) .+                               windowId)                       wins   windowGeometries <- liftX11Def [] getGeometries   let getLeftPos wd =
src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs view
@@ -23,15 +23,16 @@   ) where -import Control.Monad-import Control.Monad.IO.Class+import           Control.Monad+import           Control.Monad.IO.Class import qualified Data.Text as T-import GI.Gtk hiding (Menu)-import GI.GdkPixbuf-import System.Directory-import System.FilePath.Posix-import System.Process-import System.Taffybar.Widget.XDGMenu.Menu+import           GI.GdkPixbuf+import           GI.Gtk hiding (Menu)+import           System.Directory+import           System.FilePath.Posix+import           System.Log.Logger+import           System.Process+import           System.Taffybar.Widget.XDGMenu.Menu  -- $usage --@@ -71,7 +72,7 @@   menuShellAppend ms item   _ <- onMenuItemActivate item $ do     let cmd = feCommand de-    putStrLn $ "Launching '" ++ cmd ++ "'"+    logM "System.Taffybar.Widget.XDGMenu.MenuWidget" DEBUG $ "Launching '" ++ cmd ++ "'"     _ <- spawnCommand cmd     return ()   return ()@@ -114,7 +115,7 @@                else return Nothing   case mImg of     Just img -> imageMenuItemSetImage item (Just img)-    Nothing -> putStrLn $ "Icon not found: " ++ iconName+    Nothing -> logM "System.Taffybar.Widget.XDGMenu.MenuWidget" WARNING $ "Icon not found: " ++ iconName  -- | Create a new XDG Menu Widget. menuWidgetNew :: MonadIO m => Maybe String -- ^ menu name, must end with a dash,@@ -126,13 +127,3 @@   addMenu mb m   widgetShowAll mb   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
taffybar.cabal view
@@ -1,10 +1,10 @@ name: taffybar-version: 3.1.2+version: 3.2.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE-author: Tristan Ravitch-maintainer: tristan@nochair.net+author: Ivan Malison+maintainer: IvanMalison@gmail.com category: System build-type: Simple cabal-version: >=1.10@@ -42,6 +42,8 @@                , ConfigFile                , HStringTemplate >= 0.8 && < 0.9                , X11 >= 1.5.0.1+               , ansi-terminal+               , broadcast-chan >= 0.2.0.0                , bytestring                , containers                , dbus >= 1.2.1 && < 2.0.0@@ -52,8 +54,8 @@                , enclosed-exceptions >= 1.0.0.1                , filepath                , gi-cairo-               , gi-cairo-render                , gi-cairo-connector+               , gi-cairo-render                , gi-gdk                , gi-gdkpixbuf >= 2.0.18                , gi-gdkx11@@ -76,7 +78,7 @@                , rate-limit >= 1.1.1                , regex-compat                , safe >= 0.3 && < 1-               , scotty >= 0.11.2 && < 0.12.0+               , scotty >= 0.11.0 && < 0.12.0                , split >= 0.1.4.2                , status-notifier-item >= 0.3.0.1                , stm@@ -121,6 +123,7 @@                  , System.Taffybar.Information.X11DesktopInfo                  , System.Taffybar.Information.XDG.DesktopEntry                  , System.Taffybar.Information.XDG.Protocol+                 , System.Taffybar.LogFormatter                  , System.Taffybar.SimpleConfig                  , System.Taffybar.Support.PagerHints                  , System.Taffybar.Util@@ -147,6 +150,7 @@                  , System.Taffybar.Widget.NetworkGraph                  , System.Taffybar.Widget.SNITray                  , System.Taffybar.Widget.SimpleClock+                 , System.Taffybar.Widget.SimpleCommandButton                  , System.Taffybar.Widget.Text.CPUMonitor                  , System.Taffybar.Widget.Text.MemoryMonitor                  , System.Taffybar.Widget.Text.NetworkMonitor
taffybar.hs.example view
@@ -63,11 +63,11 @@       cpu = pollingGraphNew cpuCfg 0.5 cpuCallback       mem = pollingGraphNew memCfg 1 memCallback       net = networkGraphNew netCfg Nothing-      clock = textClockNew Nothing "%a %b %_d %r" 1+      clock = textClockNewWith defaultClockConfig       layout = layoutNew defaultLayoutConfig       windows = windowsNew defaultWindowsConfig-          -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher-          -- for a better way to set up the sni tray+      -- See https://github.com/taffybar/gtk-sni-tray#statusnotifierwatcher+      -- for a better way to set up the sni tray       tray = sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt       myConfig = defaultSimpleTaffyConfig         { startWidgets =